#lang scheme/base
(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" "../comp/state.ss" scheme/system
scheme/match)
(define datastack (make-parameter #f))
(define (pic18-datastack)
(list
(macro-constant 'stack-data)
(macro-constant 'stack-data-ptr)))
(datastack pic18-datastack)
(define-syntax-rule (d: fmt . e)
(let ((val (begin . e)))
val))
(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)))
(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
(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 i)
)))
(tethered-out (lambda (b) (write-byte (d: "out ~x\n" b) o)))
(tethered-close (lambda () (close-input-port i) (close-output-port o)))))
'(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) (sleep 1) (start)))
(begin
(uart-write 1 6)
(msleep 100)
(let ((ret (uart-try-read)))
(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)
)
(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)])
(define a 0)
(define f 0)
(define stack '())
(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))) ((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)))))
(define (in/b) ((tethered-in)))
(define (out/b byte) ((tethered-out) byte))
(define (bytes->words lst) (join-nibble-list lst 0 8))
(define (words->bytes lst) (split-nibble-list lst 0 8))
(define (void/values lst)
(if (null? lst) (void) (apply values lst)))
(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)))
(define (target-receive/b) (for/list ((i (in-range (in/b)))) (in/b)))
(define (target-receive/w) (bytes->words (target-receive/b)))
(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)))
(define (tnop) (target-send/b)) (define (treset) (target-send/b 7)) (define (tstart/b addr) (target-send/w 3 addr))
(define (tstart/w addr) (tstart/b (<<< addr 1)))
(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)) (define (erase) (target-rpc/b 14)) (define (program) (target-rpc/b 15))
(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))
(define (chunked-receive command addr!)
(lambda (total-size [at #f])
(when at (addr! at))
(flatten
(map command
(chunk-size-list
total-size
#x80)))))
(define a>/b (chunked-receive ~a>/b a!))
(define f>/b (chunked-receive ~f>/b f!))
(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))))
(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))))
(define (>tstack lst) (for-each >t (reverse lst)))
(define (tstack> n) (for/list ((i (in-range n))) (t>)))
(define (ts-move) (tstack> (stacksize)))
(define (ts-copy) (let ((s (ts-move))) (>tstack s) s))
(define (init-state)
(state:compiler))
(define (simulate-macro macro)
(let ((s (ts-move))) (dynamic-wind
void
(lambda ()
(interpret-cw/qw
(state->code (macro init-state)
(tag-stack s (asm: qw))))
(set! s #f) )
(lambda ()
(when s (>tstack s))))))
(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))))))
(define (_>t val) (>tstack (words->bytes (list val))))
(define (_t>) (car (bytes->words (tstack> 2))))
(define (bf! n) (f! (* 64 n)))
(define (ba! n) (f! (* 64 n)))
(define (free-block? b)
(bf! b)
(= #xff (check-block)))
(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)))
(define (upload-bytes-line org bytes [bits 3])
(define n (<<< 1 bits))
(unless (= n (length bytes))
(error 'non-normalized-line "~s" bytes))
(target-sync) (>f/b bytes org)
(program))
(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))))
(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"))
(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))))
(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))
(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))
(define (macros) (print-wlist (ns-mapped-symbols '(macro))))
(define (commands) (print-wlist (ns-mapped-symbols '(target))))
(define (words) (print-wlist (target-mapped-symbols)))
(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?)))
(compositions (scat) scat:
(>byte round #xff and)
(>hilo dup 8 >>> >byte swap >byte)
(hilo> swap 8 <<< or)
(tlit >t)
(_tlit _>t)
(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)
(_cold cold)
(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)
(access-bank dup 7 bit? (#xF00 xor) if)
(spam 0 out/b spam)
)