;; RUNTIME ASSEMBLER CODE

; this could be cleaned up a bit:
; - unify assembly and disassembly steps
; - move some compile time (syntax) code from bin.ss to runtime
; - handle multiple words better

; * The last one makes only sense if there's an architecture that is
;   very non risc. Note that the 'proto' is ready to accomodate
;   multiple instruction words, but i'm not using that feature:
;   especially, the disassembler ignores all but the first word. The
;   assembler can assemble multiple words, but that's not used in the
;   PIC18 set.

; * This code is not using the core.ss to run the translation process,
;   but instead uses 'asm-next'. It's of course possible to do so, but
;   since the 'atoms' in assembly code take explicit arguments, the
;   basic language structure is different enough to justify writing a
;   special purpose interpreter. Also, this code doesn't need to be
;   extensible. extensions can be made to the compiler easily.

(module asmgen-runtime mzscheme

  (require "ns.ss"
           "decoder.ss"
           "binary-utils.ss"
           (lib "match.ss")
           )

  (provide
;;    asm-find
;;    here
;;    asm-error
;;    proto->asm-error-handler
;;    asm-ignore-overflow
;;    asm-signed
   (all-defined)
   )

  
  ;; *** ASM GEN SUPPORT ***

  ;; The current PC.

  (define here (make-parameter #f))
  
  
  ;; data flow macro: parallel data is passed as lists, which is
  ;; appended to other arguments before applying. this is an alternative
  ;; to folding, in case the number of elements to fold is known in
  ;; advance. i use this in the (dis)assembler.


  (define-syntax chain
    (syntax-rules ()

      ((_ input (fn args ...))
       (apply fn (append (list args ...) input)))

      ((_ input (fn args ...) more ...)
       (chain (chain input (fn args ...)) more ...))))

  ;; (chain `(,257 ()) (dasm 4) (dasm 4) (dasm 4))


  ;; now, a similar thing with fold. convert a tree:

  ;;     IN1 IN2 IN3
  ;;      |   |   |
  ;; S0---x---x---x-|
  ;;
  ;; into an invocation of a single function

;  (define (fold-chain  fn init-state inputs)
;    (fold (lambda (input state)
;            (apply fn (append input state)))
;          init-state
;          inputs))



  

  ;; --- assembler store ---


  ;; This maps name -> assembler function returning a list of binary words.

  ;; Instead of using a local hash table, i'm using the global
  ;; hierarchical hash table space for easy access.
  

  ;; (ns-new '(opcode))

  (define (asm-register! name code)
    (ns-set! `(opcode ,name) code))

  (define (asm-find name)
    (ns-ref `(opcode ,name)
            (lambda ()
              (error 'invalid-opcode "~a" name))))

  ;; (run-asm 'reset)
  ;; (run-asm 'movlw 1)
  ;; (run-asm '_goto 1 1)
  ;; (run-asm 'setf 1 1)
  (define (run-asm name . args)
    (apply (asm-find name) args))


  ;; --- disassembler store ---

  ;; decoder implemented as a binary tree

  ;; The decoder tree contains opcode->code maps. The default node
  ;; contains a numeric word quote instruction for both branches.
  
  (define disassemblers (decoder-leaf))

  (define (dasm-register! address bits code)
    (decoder-set! decoder-leaf disassemblers
                  address bits code))

  (define (dasm-find address bits)
    (decoder-get disassemblers address bits))

  (define (run-dasm word)
    ((dasm-find word) word 16)) ;; PIC specific

  

                                        ; --- assembler ---

  ;; assemble chunk:

  ;;        (bits value) ...
  ;;             |        |
  ;;             V        V    
  ;; opcode -> [asm] -> [asm] -> ... -> instruction

  ;; (asm 1 8 (asm 1 8 0))   ;=> 257


  ;; To check overflow, we need to know wether the byte is signed or
  ;; unsigned. For a word of b bits, we inspect the bits left of the
  ;; first b-1 bits.

  ;; Type is 1 for unsigned and -1 for signed.
  (define signed -1)
  (define unsigned 1)
  
  (define (asm-fits? value bits type)
    (let ((rest (>>> value (- bits 1))))
      (or
       (zero? rest)    ;; always correct: fits in both signed and unsigned rep.
       (eq? rest type) ;; the other legal value is 1 for unsigned and -1 for signed.
       )))


  ;; The 3 kind of field assemblers: the 2 check for signed/unsigned
  ;; overflow, while the 1 ignores overflow. This is used for relative
  ;; jumps and data respectively: the assembler is responsable for
  ;; catching jump overflows, but the programmer is responsable for
  ;; respecting (or using) limited word size. See asmgen-tx.ss for the
  ;; point where this is decided in terms of the parameter class.
  
  (define (asm-ignore-overflow value bits acc)
    (bitwise-ior
     (bitwise-and (int value) (bitmask bits))
     (arithmetic-shift acc bits)))

  (define (asm-unsigned . a) (apply asm-catch-overflow unsigned a))
  (define (asm-signed . a)   (apply asm-catch-overflow signed a))

  (define (asm-catch-overflow type value bits acc)
    (unless (asm-fits? value bits type)
      ((asm-error) 'overflow value bits type))
    (asm-ignore-overflow value bits acc))
  

  (define asm-error
    (make-parameter
     (lambda a (error 'asm-error-not-in-asm-context))))


  ;; Assembler error handler. This catches all possible errors that
  ;; occur inside an assembler function.

  (define (proto->asm-error-handler asm-proto arguments)
    (match-lambda*
     (('overflow . args)
      (error 'asm-overflow
             "~a ~a ~a"
             asm-proto
             (cons (car asm-proto) arguments)
             args))))


  
  ;; --- disassembler ---

  ;; dasm is just asm run in reverse.

  ;;           bits     bits
  ;;             |        |
  ;;             V        V    
  ;; opcode <- [asm] <- [asm] <- ... <- instruction
  ;;             |        |
  ;;             V        V    
  ;;           value    value

  ;; it's probably easiest if the values are propagated to the left
  ;; together with the instruction. the asm doesn't have this topology
  ;; because for list input we can use parameter names. (see the
  ;; instruction-set macro)

;;  (define (dasm-resolve thing)
;;    (let ((name (dasm-constant-find thing)))
;;      (if name name thing)))

  (define (sign-extend unsigned bits)
    (let ((signmask (<<< 1 (- bits 1))))
      (- (bxor unsigned signmask) signmask)))

  (define (extract-bitfield num bits signed)
    (let ((unsigned
           (bitwise-and num (bitmask bits))))
      (if signed (sign-extend unsigned bits) unsigned)))

  ;; Upper case parameter names are signed.
  (define (signed? sym)
    (char-upper-case?
     (car (string->list (symbol->string sym)))))
  
  (define (dasm name bits in out)
    (list (>>> in bits)
          (cons
           (cons name
                 (extract-bitfield in bits
                                   (signed? name)))
           out)))




  ;; The shared part of the disassembler just maps the numeric opcode
  ;; to a symbolic opcode + parameter names (specified in the
  ;; instruction set spec). the rest needs to be done in platform
  ;; specific code, including rel->abs translation. This does perform
  ;; distinction between signed/unsigned, depending on the
  ;; capitalization of the formal operand names.
  
  (define (disassemble->bindings wordsize  in)
    (map
     (lambda (opcode)
       ((dasm-find opcode wordsize) opcode))
     in))



  (define (dasm-absolute in address)
    
      (define result '())
      (define (save! x) (set! result (cons x result)))
      (define (process-op! op)
        (save! `(label (R . ,address)))
        (save!
         (match op
                ((operator . operand)
                 (cons operator
                       (map process-operand operand)))))
        (set! address (+ 1 address)))
      
      (define process-operand
        (match-lambda
         ((name . value)
          (cons name
                (if (eq? 'R name)
                    ;; + 1 because base is AFTER instruction. i think
                    ;; this is as good as universal, so hardcoded here.
                    (+ 1 (+ address value)) 
                    value)))
         (other
          (error 'cannot-process-operand "~a" other))))

      (for-each process-op! in)
      (reverse result))
              
  
  
  

)