#lang scheme/base

;; TETHERED INTERPRETER / COMPILER


;; FIXME: This is highly PIC/8bit-specific. Porting to a new
;; architecture is going to involve some disentangling, but the code
;; here is quite straightforward bit and buffer twiddling.

(provide (all-defined-out))

(require
 "../tools.ss"
 "../scat.ss"
 "../target.ss"
 "../asm.ss"
 "reflection.ss"
 "console.ss"
 "../port/piklab.ss" ;; icd2 interface
 "../purrr/repl.ss"  ;; FIXME: weird dependency here..
 (lib "match.ss"))

;; Shortcut access.

;; (define (io-debug x) (x))
(define default-portspec '("/dev/ttyUSB0" 9600))
(define (io-debug x)
  (with-io-device default-portspec x))
(define-syntax-rule (io> . expr)
  (io-debug (lambda () . expr)))

(define (in)
  (read-byte-timeout (i-port) 3))  ;; FIXME: make this configurable

(define (out byte)
  (write-byte byte (o-port)))



;; BOOT MONITOR PROTOCOL

(define (tnop)           (out 0))

;; data stack access
(define (>t val)         (out 1) (out (int8 val)) (wait-ack))
(define (t>)             (out 2) (in))

;; sync/async code
(define (tstart/b addr)  (out 3) (_out addr)) ;; async (*)
(define (tstart/w addr)  (tstart/b (<<< addr 1)))
(define (texec/b addr)   (tstart/b addr) (wait-ack)) ;; sync
(define (texec/w addr)   (texec/b (<<< addr 1)))

;; (*) Note that 'start' in interactive.ss uses this. Because the
;; Purrr console closes the serial port after every command, running
;; 'start' on a word that DOES return an ack byte is ok: the ack byte
;; is just ignored.


;; set ram/flash pointers
(define (a! addr)        (out 4) (_out addr) (wait-ack))
(define (f! addr)        (out 5) (_out addr) (wait-ack))

(define (tsync)          (out 6) (wait-ack))  ;; explicit target sync
(define (cold)           (out 7))             ;; reset target

;; These send size for symmetry with the 2 below
(define (n@a+ n)         (out 8)  (out n))
(define (n@f+ n)         (out 9)  (out n))
;; This send size to make host->target protocol context-free
(define (n!a+/async n)   (out 10) (out n))
(define (n!f+/async n)   (out 11) (out n))

(define (chkblk)         (out 12))  ;; check code block
(define (echorq)         (out 13))  ;; echo request
(define (ferase/async)   (out 14))  ;; erase current flash block
(define (fprog/async)    (out 15))  ;; program current flash line

;; HUB commands
(define (client c)       (out 16) (out c))
(define (hub)            (out 17))

(define (wait-ack) (in)) ;; ignore

;; DATA TRANSFER

(define (byte-split fn)
  (lambda (x)
    (fn (int8 x))
    (fn (int8 (>>> x 8)))))

(define (byte-join fn)
  (lambda ()
    (let* ((lo (fn))
           (hi (fn)))
      (bior (<<< hi 8) lo))))

(define _out (byte-split out))
(define _>t  (byte-split >t))

(define _in  (byte-join in))
(define _t>  (byte-join t>))

(define (t@ addr)     (a! addr) (n@a+ 1) (in))

(define (twrite . vals)
  (n!a+/async (length vals))
  (for-each out vals)
  (wait-ack))

(define _twrite (byte-split twrite))

(define (t!  val addr) (a! addr) (twrite val))
(define (_t! val addr) (a! addr) (_twrite val))

;; Move a list of numbers to/from stack (not bulk transfer). The
;; first element in the list is the top of stack, so it can be used
;; with 'apply' for simulation.

(define (>tstack lst)
  (for-each >t (reverse lst)))
(define (tstack> n)
  (for/list ((i (in-range n))) (t>)))




;; raw stream
(define (nin>list n)  (for/list ((i (in-range n))) (in)))
(define (_nin>list n) (for/list ((i (in-range n))) (_in)))

;; length + block
(define (in>list)   (nin>list (in)))
(define (in>string) (list->bytes (in>list)))

;; wrapped transfer commands (can take 0)
(define (fbytes n) (unless (zero? n) (n@f+ n)))
(define (abytes n) (unless (zero? n) (n@a+ n)))
(define (fwords n) (fbytes (<<< n 1)))
(define (awords n) (abytes (<<< n 1)))

;; create a chunked reader to work around 8 bit target count size.
(define (chunked max-size command reader)
  (lambda (total-size)
    (flatten
     (map
      (lambda (n) (command n) (reader n))
      (chunk-size-list total-size
                       max-size)))))

;; transfer functions: n -> list
(define abytes>list (chunked #x80 abytes nin>list))
(define fbytes>list (chunked #x80 fbytes nin>list))
(define awords>list (chunked #x40 awords _nin>list))
(define fwords>list (chunked #x40 fwords _nin>list))


;; Including start.
(define (fbytes->list f n) (f! f) (fbytes>list n))
(define (abytes->list a n) (a! a) (abytes>list n))
(define (fwords->list f n) (f! f) (fwords>list n))
(define (awords->list a n) (a! a) (awords>list n))

;; block access
(define (bf! n) (f! (* 64 n)))
(define (ba! n) (f! (* 64 n)))
(define (free-block? b)
  (bf! b)
  (chkblk)
  (= #xff (in)))


;; UTILS


;; (word dict -- )IO
;; (define (dict-tinterpret word dict)
;;   (cond
;;    ((dict-find-code dict word) => texec/w)
;;    ((dict-find-data dict word) => >t)
;;    (else (error 'undefined-word "~s" word))))

(define (stack>list bottom stkptr)
  (let* ((top (t@ stkptr))
         (n   (- top bottom)))
    ;; FIXME: check overflow too
    (when (< n 0)
      (error 'target-stack-underflow "~s" n))
    (a! (add1 bottom)) ;; due to TOP=wreg
    (reverse (abytes>list n))))

;; PROGRAMMING
(define (program) (fprog/async) (wait-ack))
(define (erase)   (ferase/async) (wait-ack))

;; To minimise mistakes, these will all set f. This as opposed to
;; the readout, which uses words relative to current position.

(define (erase-block b)
  (bf! b) (erase))

(define (erase-blocks b n)
  (unless (zero? n)
    (erase-block b)
    (erase-blocks (+ b 1) (- n 1))))

;; keep erasing until free block
(define (erase-from-block b)
  (if (free-block? b)
      (printf "\n")
      (begin
        (printf "~s " b)
        (erase-block b)
        (erase-from-block (+ b 1)))))

(define (erase-from/w addr)
  (erase-from-block
   (ceiling-block addr 32))) ;; 32 words in a block


(define (upload-bytes-line org bytes [bits 3])
  (define n (<<< 1 bits))
  (unless (= n (length bytes))
    (error 'non-normalized-line "~s" bytes))
  (tsync) ;; make sure target is live
  (f! org)
  (n!f+/async n)
  (for ((b bytes)) (out (int8 b)))
  (wait-ack)
  (program))

;; Upload line-aligned bytes obtained from flattened code chunks.
(define (upload-bytes bin
                      ;; PIC18 default = 8 bytes/line
                      [align-bits 3])
                    
  (for ((chunk (bin-flatten bin)))
    (for (((org line) (in-binchunk/lines chunk align-bits -1)))
       (display ".")
       ;; (printf "~a ~a\n" org line)
       (upload-bytes-line org line align-bits)
       )))
    


;; PRINTING

(define printf-stack stack-print)

;; print stacks
(define (psu lst)  (printf-stack lst " ~s"))
(define (psx lst)  (printf-stack (map byte->string lst) " ~a"))
(define (_psx lst) (printf-stack (map word->string lst) " ~a"))
(define (pss lst)  (printf-stack (map (sign-extender 8) lst) " ~s"))
(define (_pss lst) (printf-stack (map (sign-extender 16) lst) " ~s"))


;; print a memory map of the first n kb.
(define (kb n)
  (define (current-block)
    (if
     (begin
       (chkblk)
       (= #xff (in)))
     ". " "x "))
  (define (print-line)
    (printf
     "~a\n"
     (apply
      string-append
      (for/list ((i (in-range 8))) (current-block)))))

  (bf! 0)
  (let ((lines (* 2 n)))
    (for ((i (in-range lines)))
         (print-line))))

(define (slurp)
  (for ((i (in-thunk in))
        (p (in-hex-printer))) (p i)))


;; DISASSEMBLY
(define (tsee word [n #x20])
  (define addr (if (number? word) word (<<< (tfind word) 1)))
  (define dict (target-words))
  (when addr (f! addr))
  (print-target-word
   (disassemble->word (fwords>list n) (>>> addr 1) 16
                      (lambda (addr)
                        (or
                         (reverse-lookup dict 'code addr)
                         addr)))))

(define (bd block)
  (tsee (* 64 block) 32))


(define (sim-or-target name sim-code)
  (let ((word (tfind/false name)))
    (if word
        (scat: ',word texec/w)
        sim-code)))

(snarf as-push (scat)
  ((name code) (sim-or-target)))

(compositions
 (scat) scat:

 (sim/target sim-or-target run))


;; SNARFS
  
  (snarf as-void (scat)
    ((a)   (_out >t _>t >tstack
            texec/w texec/b tstart/w tstart/b
            awords abytes fwords fbytes
            a! f! ba! bf!
            n@a+ n@f+
            n!a+/async n!f+/async
            erase-block erase-from-block erase-from/w
            kb bd tsee
            client
            piklab-prog))
    ((a b) (t! _t!
            erase-blocks
            ))

    ((a)   (psu psx pss _psx _pss))

    (()    (tnop wait-ack tsync cold chkblk echorq
            ferase/async fprog/async program erase hub
            )))

  (snarf as-push (scat)
    (()    (_in t> _t> in>string in>list))
    ((a)   (t@ tstack> nin>list _nin>list 
            fwords>list fbytes>list abytes>list awords>list
            free-block?
            ))
    ;; ((a b) (dict-tinterpret))
    ((a b) (stack>list))
    )

  




;; transparant cat functions, independent of badnop state. i'm trying
;; to sever the PIC specific part from the more general part, so
;; proper separation later is feasible.

(compositions (scat) scat:

 ;; target I/O
 (>byte round #xff and)
 (>hilo dup 8 >>> >byte swap >byte)
 (hilo> swap 8 <<< or)


 (sim  "(sim)" d cr
       swap tstack> apply >tstack)

 ;; support for interactive.ss that has little use in scheme code.
 (tlit        >t)
 (_tlit       _>t)

 ;; (find        swap dict-find)            ;; maybe make this polymorphic
 ;; (find/false  swap dict-find/false)

 


 (@f+       1 n@f+ in)

 (identify  echorq in>string bytes->string/utf-8)
 
 (ping      identify d cr)

 

 (ps        8 sign-extend p)
 (_ps       16 sign-extend p)
 
 (px        pbyte)
 (_px       pword)
 (_p        p)
 
 (pbyte     byte->string d)  (h pbyte)
 (pword     word->string d)


 ;; misc wrappers for commands
 (_cold     cold)
 (_ping     ping)

 
 ;; An attempt to do this the smart way: it's easier to always
 ;; transfer unsigned bytes, since they don't need sign
 ;; extension. That's what xxx>list does. However, for plots of
 ;; signals, it's mostly useful to use signed data, so plot will
 ;; convert to signed, and assume the data is in offset binary format.

; (plot      abytes>list (#x80 -) map plot-list)
; (2plot     awords>list (#x8000 -) map plot-list)
            
 
 
 (pfline    4 fwords>list (pword) for-each cr)
 (fdump     8 (pfline) for)

 
 
 ;; 'target-stack' gives (bottom stkptr) for the current target

 ;; FIXME: get it from somewhere else. see brood-4/host/pic18-console.ss
 (target-stack 128 4073)
 
 
 (ts>list    target-stack stack>list)
 (_ts>list   ts>list 8 0 join-nibble-list)
 
 (ts   ts>list psu)
 (tsx  ts>list psx)
 (tss  ts>list pss)

 (_ts  _ts>list psu)
 (_tsx _ts>list _psx)
 (_tss _ts>list _pss)


 ;; FIXME: PIC18 specific
 (access-bank dup 7 bit?  (#xF00 xor) if)
              

 
 ;; disassemble one block

 (codeblock 32 fwords>list)

 ;; data mem
 (paline   8 n@a+ 8 (in pbyte) for cr)
 (adump    8 (paline) for)

 (abd      ba! adump)
 (fbd      bf! fdump)
 
 ;; slurp and spam
 ;; (slurp    16 (in pbyte) for cr slurp)
 (spam     0 out spam)
 

 ;; code memory check
 (fresh?    chkblk in #xff =)

 ;; round addresses to next block boundary
 (ceil-word->block   1 - -32 and 32 +)
 (ceil-byte->block   1 - -64 and 64 +)




 
;;  ;; upload binary code ( bin -- )
;;  (upload    bin->chunks words->bytes
;;             (3 chunk-align-bits) map
;;             (upload-chunk) for-each)



; (<ab>--ba      uncons car swap)
; (porg          "org" d p cr)


;;  ;; verbose printing
;;  (print-chunk
;;                 <ab>--ba
;;                 porg
;;                 8 list->table
;;                 ((pbyte) for-each cr) for-each)

 

;;  (~upload-line  tsync  ;; make sure target's there
;;                 8 n!f+/async
;;                 (>byte ;; dup pbyte
;;                        out) for-each
;;                 wait-ack
;;                 program ;; cr
;;                 )

;;  (upload-line   dup '() eq? (drop) (~upload-line) ifte)
                

;;  (upload-chunk  <ab>--ba dup f! porg
;;                 8 list->table
;;                 (upload-line "." display) for-each cr)


 ;; constants + macros
;; (macros       '(macro) ns-ls
;;               (symbol->string d) for-each cr)

                
 ;; printing
 
 ;; (print-dict   (uncons p tab p cr) for-each)
 (print-dict   pp) ;; no nonsense
 (print-words  (car p) for-each cr)

;; (print-formatted-asm (format-asm display) for-each)
 
;; (print-asm    pretty-asm print-formatted-asm)
 
 (print-bin    8 list->table 
               ((dup number?
                     (word->string d space)
                     (p) ifte)
                for-each cr)
               for-each)


 ;; file output
;; (export-ihex   (print-ihex) swap with-output-to-file/safe)
;; (save-tree     (write-tree) swap with-output-to-file/safe)


 ;; FIXME: used in substitions, but not defined
;;  (tsee #f)
;;  (msee #f)
;;  (vsee #f)
;;  (print-doc #f)
;;  (plot #f)
;;  (2plot #f)

 
 )



;; from old host/badnop.ss
(snarf as-push (scat)
   (()          (in))
       
   ((a b)       (sign-extend bit?))
   ((number)    (word->string byte->string))
   ((lst a b)   (binchunk-split join-nibble-list))

)

(snarf as-void (scat)
   (()          (slurp))
   ((byte)      (out)))