#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/b)       (read-byte-timeout (i-port) 3))  ;; FIXME: make this configurable
(define (out/b byte) (write-byte byte (o-port)))

;; word/byte lists
(define (bytes->words lst) (join-nibble-list  lst 0 8))
(define (words->bytes lst) (split-nibble-list lst 0 8))

;; values
(define (void/values lst)
  (if (null? lst) (void) (apply values lst)))

;; MESSAGE TRANSPORT PROTOCOL

;; All messages are prepended with size to make them self-delimited.
;; This is in order to facilitate routing without the need for
;; interpretation.

;; Asynchronous send / receive.  All communication code will be built
;; on top of this.
(define (target-send/b . bytes)
  (let ((len (length bytes)))
    (when (> len 255) (error 'message-too-long))
    (out/b len)
    (for ((b bytes)) (out/b (int8 b)))))
(define (target-send/w id . words)
  (apply target-send/b id (words->bytes words)))

;; Receive returns lists.
(define (target-receive/b) (for/list ((i (in-range (in/b)))) (in/b)))
(define (target-receive/w) (bytes->words (target-receive/b)))

;; RPC returns values.
(define (target-rpc/b . args)
  (apply target-send/b args)
  (void/values (target-receive/b)))
(define (target-rpc/w . args)
  (apply target-send/w args)
  (void/values (target-receive/w)))




;; BOOT MONITOR COMMAND PROTOCOL


;; ASYNC COMMANDS

(define (tnop)           (target-send/b))         ;; nop = empty message
(define (cold)           (target-send/b 7))       ;; reset target
(define (tstart/b addr)  (target-send/w 3 addr)) 
(define (tstart/w addr)  (tstart/b (<<< addr 1))) ;; (*)

;; (*) The command 'start in live/commands.ss uses this. Because the
;; 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.


;; RPC COMMANDS

(define (>t val)         (target-rpc/b 1 val))
(define (t>)             (target-rpc/b 2))
(define (texec/b addr)   (target-rpc/w 3 addr))
(define (texec/w addr)   (texec/b (<<< addr 1)))
(define (a! addr)        (target-rpc/w 4 addr))
(define (f! addr)        (target-rpc/w 5 addr))
(define (target-sync)    (target-rpc/b 6))  
(define (check-block)    (target-rpc/b 12))
(define (erase)          (target-rpc/b 14)) ;; erase current flash block
(define (program)        (target-rpc/b 15)) ;; program current flash line


;; RPC LIST COMMANDS

;; Receive data packets as lists.  These postincrement the a and f
;; pointers, and are limited to 255 byte lists.  Use the composite
;; commands instead.
(define (~a>/b n)        (target-send/b 8 n) (target-receive/b))
(define (~f>/b n)        (target-send/b 9 n) (target-receive/b))
(define (~>a/b lst)      (apply target-rpc/b 10 (length lst) lst))
(define (~>f/b lst)      (apply target-rpc/b 11 (length lst) lst))



;; COMPOSITE COMMANDS

;; Written in terms of the low level commands defined above.

(define (chunked-receive command addr!)
  (lambda (total-size [at #f])
    (when at (addr! at))
    (flatten
     (map command
          (chunk-size-list
           total-size
           #x80)))))  ;; allow for some header wrapping.

(define a>/b  (chunked-receive ~a>/b a!))
(define f>/b  (chunked-receive ~f>/b f!))

;; FIXME: implement chunked message send correctly.
(define (chunked-send command addr!)
  (lambda (lst [at #f])
    (when at (addr! at))
    (command lst)))

(define >a/b  (chunked-send ~>a/b a!))
(define >f/b  (chunked-send ~>f/b f!))

(define (f>/w n) (bytes->words (f>/b (<<< n 1))))

;; Target fetch/store + double.
(define (t@  addr)     (a! addr) (car (a>/b 1)))
(define (t!  val addr) (a! addr) (>a/b (list val)))
(define (_t@ addr)     (a! addr) (car (bytes->words (a>/b 2))))
(define (_t! val addr) (a! addr) (>a/b (words->bytes (list 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>)))

;; Double stack.
(define (_>t val)      (>tstack (words->bytes (list val))))
(define (_t>)          (car (bytes->words (tstack> 2))))

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

(define (stack>list bottom stkptr)
  (let* ((top   (t@ stkptr))
         (n     (- top bottom))
         (addr  (add1 bottom)))  ;; due to TOP=wreg
    (when (< n 0)
      (error 'target-stack-underflow "~s" n))
    (reverse (a>/b n addr))))

;; To minimise mistakes, erase and program 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))))

(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))
  (target-sync) ;; make sure target is live
  (>f/b bytes org)
  (program))

;; Upload line-aligned bytes obtained from flattened code chunks.
;; Default is from PIC18, which uses 8 bytes per write line.
(define (upload-bytes bin [align-bits 3])
  (for ((chunk (bin-flatten bin)))
    (for (((org line) (in-binchunk/lines chunk align-bits -1)))
       (display ".")
       (upload-bytes-line org line align-bits))))


;; PRINTING

(define printf-stack stack-print)

(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.  Useful for getting a general
;; idea of chip content.
(define (kb n)
  (define (current-block)
    (if (= #xff (check-block)) ". " "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))))

;; Read raw bytes from input and print.  See tools/print.ss for args.
(define (hex-dump sequence . args)
  (for ((s sequence)
        (p (apply in-hex-printer args)))
    (p s)))

(define (slurp) (hex-dump (in-thunk in/b)))
(define (abd b) (ba! b) (hex-dump (in-list (a>/b 64)) (* 64 b) 3 2 8))
(define (fbd b) (bf! b) (hex-dump (in-list (f>/w 32)) (* 64 b) 4 4 4))


;; 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 (f>/w 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)))



;; SNARFS
(snarf as-void (scat)
   ((a)   (>t _>t >tstack out/b
           texec/w texec/b tstart/w tstart/b
           a! f! ba! bf!
           erase-block erase-from-block erase-from/w
           kb bd tsee
           piklab-prog))
   ((a b) (t! _t! erase-blocks))
   ((a)   (psu psx pss _psx _pss abd fbd a>/b f>/b f>/w))
   (()    (program erase target-sync cold slurp)))

(snarf as-push (scat)
   (()          (in/b t> _t>))
   ((a b)       (sign-extend bit? stack>list sim-or-target))
   ((number)    (word->string byte->string))
   ((lst a b)   (binchunk-split join-nibble-list))
   ((a)         (t@ tstack> free-block?)))



;; SCAT

;; Prefix parsing words in live/command.ss will expand to these Scat words.
(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)

 (sim/target sim-or-target run)
 
 ;; support for interactive.ss that has little use in scheme code.
 (tlit        >t)
 (_tlit       _>t)

 ;; OK means target responds to sync.
 (OK        target-sync "OK" d cr)

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

 ;; misc wrappers for commands
 (_cold     cold)

 
 ;; 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)
            
 
 ;; '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)
              
 (spam     0 out/b spam)
 
 )