#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
 "../op.ss"
 "../tools.ss"
 "../ns.ss"
 "../scat.ss"
 "../target.ss"
 "../asm.ss"
 "../coma/macro.ss"
 "reflection.ss"
 "../port/piklab.ss" ;; icd2 interface
;; "../pk2/pk2.ss"
 "../comp/state.ss" ;; state for macro eval
 scheme/system
 scheme/match)

;; CHIP SPECIFIC CONFIG
(define datastack (make-parameter #f))

(define (pic18-datastack)
  (list
   (macro-constant 'stack-data)
   (macro-constant 'stack-data-ptr)))
(datastack pic18-datastack)


;; Debug
(define-syntax-rule (d: fmt . e)
  (let ((val (begin . e)))
    ;; (printf fmt val)
    val))


;; CONNECTION

(define tethered-in    (make-parameter (lambda _ (error 'no-input-connected))))
(define tethered-out   (make-parameter (lambda _ (error 'no-output-connected))))
(define tethered-close (make-parameter void))
(define tethered-reset (make-parameter (lambda () (treset))))

(define (cold) ((tethered-reset)))

;; serial port

(define stty
  (let ((fmt #f)
        (fmts
         '(("Linux"         . "stty -F ~a ~a raw min 1 -echo")
           ("CYGWIN_NT-5.1" . "stty -F ~a ~a min 1 -echo ixon -icanon pass8")
           ("windows"       . "mode ~a: baud=~a parity=n data=8 stop=1 xon=off dtr=off rts=off"))))
    (lambda (name baud)
      (unless fmt
        ;; Fixme: do autodetect using 'uname' or something..
        (set! fmt (cdr (assoc "Linux" fmts))))
      (system (format fmt name baud)))))


(define (tethered-serial-port name baud)

  (define (standard-serial-port)
    (let-values
        (((i o)
          (open-input-output-file name #:exists 'append)))
      (file-stream-buffer-mode o 'none)
      (stty name baud)
      (tethered-reset (lambda () (treset)))
      (tethered-in    (lambda () (d: "in ~x\n"
                                     ;; (read-byte-timeout i 3)
                                     (read-byte i)
                                       )))
      (tethered-out   (lambda (b) (write-byte (d: "out ~x\n" b) o)))
      (tethered-close (lambda () (close-input-port i) (close-output-port o)))))

  ;; FIXME: re-enable pk2 support through external console interface.
  
  '(define (pk2-serial-port)
    (define (stop)
      (uart-stop) (target-off) (msleep 300))
    (define (start)
      (target-on)
      (uart-start baud)
      (tethered-in uart-read)
      (tethered-out uart-write)
      (tethered-close
       (lambda () (stop) (pk2-close)))
      (tethered-reset
       (lambda ()
         (printf "PK2: target cold reset.\n")
         (stop)     ;; don't pk2-close!
         (sleep 1)  ;; this ensures proper shutdown.  FIXME: fix thread sync!
         (start)))

      ;; Hack to start up communication.  For some reason, the first
      ;; ACK request doesn't seem to get through.  It does work when
      ;; proper PK2 shutdown is disabled (EXIT_UART_MODE), but then
      ;; programming doesn't work on next try.  This is probably a
      ;; glitch on the TX line...
      (begin
        (uart-write 1 6)
        (msleep 100)
        (let ((ret (uart-try-read)))
          ;; (printf "usart-start: ~a\n" ret)
          (unless ret
            (printf "uart-start hack\n"))))
      )
    (pk2-boot)
    (start))

  

  ((tethered-close))


  '(if (equal? "pk2" name)
       (pk2-serial-port)
       (standard-serial-port))
  (standard-serial-port)


  )
  

;; SIMULATOR

;; A simulator for testing and definition of target interpreter
;; semantics.  Obviously, this doesn't execute native code.

(define (make-memory [size #x4096] [filler #xFF])
  (define v (make-vector size filler))
  (define (addr x) (modulo x size))
  (case-lambda
    ((ref) (vector-ref v (addr ref)))
    ((ref val) (vector-set! v (addr ref) val))))

(define (make-simulator [amem (make-memory)]
                        [fmem (make-memory)])
  ;; machine state
  (define a 0)
  (define f 0)
  (define stack '())
  
  ;; functionality
  (define (p x) (printf "target: ~a\n" x))
  (define (push x) (push! stack x))
  (define (pop)
    (with-handlers
        ((void (lambda _
                 (p 'stack-underflow)
                 0)))
      (pop! stack)))
  (define I (make-channel))
  (define O (make-channel))
  (define (recv) (channel-get I))
  (define (trns x) (channel-put O x))
  (define (ack) (trns 0))
  (define (ferase) (p '(ferase)) (ack))
  (define (fprog)  (p '(fprog)) (ack))
  (define (recv2) (b->w (recv) (recv)))
  (define (b->w l h) (car (bytes->words (list l h))))

  (define (chkblk)
    (let ((x #xff))
      (for ((i (in-range 64)))
        (set! x (band x (fetch++ fmem f))))
      (trns 1)
      (trns x)))

  (define (stacksize)
    (trns 1)
    (trns (length stack)))

  (define-syntax-rule (fetch++ mem ptr)
    (let ((x (mem ptr)))
      (set! ptr (add1 ptr)) x))
  (define-syntax-rule (store-buf mem ptr)
    (begin
      (for ((i (in-range (recv))))
        (mem ptr (recv))
        (set! ptr (add1 ptr)))
      (ack)))
  (define-syntax-rule (fetch-buf mem ptr)
    (let ((n (recv)))
      (trns n)
      (for ((i (in-range n)))
         (trns (fetch++ mem ptr)))))
  
  (define (interpret cmd)
    (case cmd
      ((0) (ack))
      ((1) (push (recv)) (ack))
      ((2) (trns 1) (trns (pop)))
      ((3) (p (list 'jsr (recv2))) (ack))
      ((4) (set! a (recv2)) (ack))
      ((5) (set! f (recv2)) (ack))
      ((6) (ack))
      ((7) (p '(reset)))  ;; no ack here!
      ((8) (fetch-buf amem a))
      ((9) (fetch-buf fmem f))
      ((10) (store-buf amem a))
      ((11) (store-buf fmem f))
      ((12) (chkblk)) 
      ((13) (stacksize))
      ((14) (ferase))
      ((15) (fprog))))

  (define (interpreter)
    (unless (zero? (recv))
      (interpret (recv)))
    (interpreter))


  (thread interpreter)
  (values I O))
  
(define (tethered-simulator)
  (let-values (((to from) (make-simulator)))
    (tethered-in
     (lambda () (channel-get from)))
    (tethered-out
     (lambda (b) (channel-put to b)))))

;; (tethered-simulator)

;; 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)       ((tethered-in)))
(define (out/b byte) ((tethered-out) byte))

;; 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 (treset)         (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 (stacksize)      (target-rpc/b 13)) ;; get size of data stack
(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>)))

;; Stack is abstract on the target, so we don't know where it is in
;; memory, and thus cannot copy it as such.
(define (ts-move) (tstack> (stacksize)))
(define (ts-copy) (let ((s (ts-move))) (>tstack s) s))


;; All partial-evaluating macros can be simulated at the console.
;; Whenever an identifier is not found in the (target) namespace, its
;; (macro) binding is passed to this function, which will attempt to
;; perform the operation on live stack data.

;; FIXME: this is probably ok, but hardcoded now.
(define (init-state)
  (state:compiler))

(define (simulate-macro macro)
  (let ((s (ts-move))) ;; save
    (dynamic-wind
        void
        (lambda ()
          (interpret-cw/qw
           (state->code (macro init-state)
                        (tag-stack s (asm: qw))))
          (set! s #f)          ;; mark done
          ;; (printf "(sim)")  ;; FIXME: this is confusing, so leave it out.
          )
        (lambda ()
          (when s (>tstack s)))))) ;; possibly restore

(define (interpret-cw/qw code)
  (define num target-value->number)
  (define (qw? x) (eq? (asm: qw) x))
  (define (cw? x) (eq? (asm: cw) x))
  (for ((ins (reverse code)))
    (match ins
      ([list (? qw?) n] (>t (num n)))
      ([list (? cw?) a] (texec/w (num a)))
      ([list-rest opc _]
       (error 'cannot-simulate-opcode "~a\n~a"
              (asm-name opc)
              (reverse code))))))



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

;; 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.
;; (require scheme/pretty)
(define (upload-bytes bin [align-bits 3])
  ;; (pretty-print bin)
  (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-gen in/b not)))
(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
    (eval 'dasm-collection)
    (f>/w n) (>>> addr 1) 16
    (lambda (addr)
      (or
       (reverse-lookup dict 'code addr)
       addr)))))

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

(define (print-wlist lst)
  (for ((w lst))
     (printf "~a " (symbol->string w)))
  (newline))

;; All words are accessible through macros.
(define (macros)   (print-wlist (ns-mapped-symbols '(macro))))
(define (commands) (print-wlist (ns-mapped-symbols '(target))))
(define (words)    (print-wlist (target-mapped-symbols)))

       

;; 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 words macros commands)))

(snarf as-push (scat)
   (()          (in/b t> _t> ts-copy))
   ((a b)       (sign-extend bit?))
   ((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)

 ;; 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-copy   ts-copy 8 0 join-nibble-list)
 
 (ts   ts-copy psu)
 (tsx  ts-copy psx)
 (tss  ts-copy pss)

 (_ts  _ts-copy psu)
 (_tsx _ts-copy _psx)
 (_tss _ts-copy _pss)


 ;; FIXME: PIC18 specific
 (access-bank dup 7 bit?  (#xF00 xor) if)
              
 (spam     0 out/b spam)
 
 )