;; ASM / DASM SUPPORT

#lang scheme/base

(require
 "../tools.ss"
 "../target.ss"
 "decoder.ss"
 "dictionary.ss"
 "pointers.ss"
 (lib "match.ss"))

(provide

 ;; operand assemblers
 pc-relative
 ignore-overflow

 ;; misc asm routines
 chain
 dasm-step
 asm-fits?
 operand:signed
 operand:unsigned

 ;; misc dasm routines
 disassemble->word
 compose-asm
 )

(define (compose-asm . lst)
  (apply append (reverse lst)))


;; For the imperative algos, use a hash table data structure.
;(define get hash-table-get)
;(define put! hash-table-put!)
;(define table alist->hash-table)
;(define table->alist hash-table->alist)


;; *** ASM GEN SUPPORT ***

;; The current PC.


;; 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 ---

;; 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 operand:signed -1)
(define operand:unsigned 1)
(define (operand-type type)
  (cond
   ((eq? type operand:unsigned) 'unsigned)
   ((eq? type operand:signed) 'signed)
   (error 'no-sign-type "~a" type)))
   

(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.
     )))


;; Operand assemblers: called depending on operand type (see
;; asmgen-tx.ss paramclass->asm)

(define (ignore-overflow value bits acc)
  (bitwise-ior
   (bitwise-and (int value) (bitmask bits))
   (arithmetic-shift acc bits)))

(define (catch-overflow type value bits acc)
  (unless (or
           (> (asm-phase) 0) ;; ignore overflows in phase 0
           (asm-fits? value bits type))
    ;; (printf "WARNING: ~a overflow val:~a bits:~a\n" (asm-phase) value bits)
    ((asm-error) 'overflow (operand-type type) value bits)
    )
  (ignore-overflow value bits acc))

(define (unsigned . a) (apply catch-overflow operand:unsigned a))
(define (signed . a)   (apply catch-overflow operand:signed a))

(define (pc-relative value . a)
  (apply signed
         ((asm-offset) value) a))



;; Offset computation for relative addressing. The following seems to
;; be a standard: relative to the PC after the jump instruction.
(define asm-offset
  (make-parameter
   (lambda (addr)
     (let ((here (pointer-get 'code)))
;;        (printf "OFFSET: ~a ~a ~a ~a\n"
;;                (let ((c (asm-current-chain)))
;;                  (and c (target-word-name c)))
;;                (instruction->string (asm-current-instruction))
;;                here addr)
       (- addr (+ here 1))))))




;; --- 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-step name bits in out)
  (list (>>> in bits)
        (cons
         (cons name
               (extract-bitfield in bits
                                 (signed? name)))
         out)))



;; Note that this is for RISC instruction sets only. All instructions
;; have the same size and are word-addressed. Any mult-word
;; instructions need to be parsed in a later step. (This works well
;; for PIC18 because the 2nd word is a valid NOP instruction, but
;; might need some reworking).

(define (disassemble->word binary address wordsize
                           ;; + 1 because base is AFTER instruction. i think
                           ;; this is as good as universal, so hardcoded here.
                           [resolve (lambda (x) x)]
                           [rel->abs (lambda (addr rel) (+ 1 (+ addr rel)))])
  (define *bin* '())
  (define *code* '())

  (define (dasm addr ins)
    (match ((dasm-find ins wordsize) ins)
       ((rator . rands)
        (cons rator
              (map
               (match-lambda
                ((type . value)
                 (case type 
                   ((R) (resolve (rel->abs addr value)))
                   (else value))))
               rands)))))

  (for ((a (in-naturals address))
        (b binary))
    (push! *bin*  (list b))
    (push! *code* (dasm a b)))

  (new-target-word #:realm 'code
                   #:address address
                   #:code *code*
                   #:bin *bin*))