diff options
Diffstat (limited to 'atk16_schasm/lib.scm')
| -rw-r--r-- | atk16_schasm/lib.scm | 233 |
1 files changed, 233 insertions, 0 deletions
diff --git a/atk16_schasm/lib.scm b/atk16_schasm/lib.scm new file mode 100644 index 0000000..adf681b --- /dev/null +++ b/atk16_schasm/lib.scm @@ -0,0 +1,233 @@ +(import (chicken base) + (chicken bitwise) + (chicken format)) + +(define *buffer* (make-vector (expt 2 16) #f)) +(define *cursor* 0) +(define *labels* '()) + +;; Directives + +(define (def-label sym) + (set! *labels* (cons (cons sym *cursor*) *labels*))) + +(define (at-addr addr) + (unless (and (number? addr) + (>= addr 0) + (< addr (expt 2 16))) + (error "invalid addr" addr)) + + (set! *cursor* addr)) + +;; Value constructors and references + +(define (label sym) + (assocdr sym *labels*)) + +(define (reg n) + (cond + ((or (< n 0) (>= n 16)) (error "invalid arg to reg" n)) + (else `(reg ,n)))) + +(define (imm n) + (let* ((n16 (modulo n (expt 2 16)))) + `(imm ,n16))) + +(define (alu-op n) + (cond + ((or (< n 0) (>= n 8)) (error "invalid arg to alu-op" n)) + (else `(alu-op ,n)))) + +(define alu-plus (alu-op 0)) +(define alu-minus (alu-op 1)) +(define alu-and (alu-op 2)) +(define alu-or (alu-op 3)) +(define alu-xor (alu-op 4)) +(define alu-shl (alu-op 5)) +(define alu-shr (alu-op 6)) +(define alu-sar (alu-op 7)) + +;; Encode and emit + +(define (emit . chunks) + (unless (eq? (vector-ref *buffer* *cursor*) #f) + (error "overwriting already written memory at" *cursor*)) + (define word + (if (and (= (length chunks) 1) + (number? (car chunks))) + ;; single argument + (car chunks) + ;; multiple (bits . value) pairs + (apply encode chunks))) + + (vector-set! *buffer* *cursor* word) + (set! *cursor* (+ *cursor* 1))) + +(define (encode . chunks) + (let ((total-bits (apply + (map car chunks)))) + (unless (= total-bits 16) + (error "emit: total bits in chunks must equal 16, got" total-bits))) + + (let loop ((chs chunks) (acc 0)) + (if (null? chs) + acc + (let* ((chunk (car chs)) + (n (car chunk)) + (val (cdr chunk))) + + (when (>= val (expt 2 n)) + (error "emit: value" val "does not fit in" n "bits")) + + ;; shift acc left by n bits and combine with val + (loop (cdr chs) + (bitwise-ior (arithmetic-shift acc n) val)))))) + +;; Instructions + +(define (hlt) + ;; just full zeros + (emit 0)) + +(define (alu op lhs rhs) + (unless (eq? 'alu-op (type-of op)) (error "invalid op" op)) + (unless (eq? 'reg (type-of lhs)) (error "invalid lhs" lhs)) + + (define mode + (cond ((eq? 'reg (type-of rhs)) 0) + ((eq? 'imm (type-of rhs)) 1) + (else (error "invalid rhs" rhs)))) + + (if (= mode 0) + ;; reg mode + (emit `(4 . 1) ; opcode = 1 + `(3 . ,(cadr op)) ; alu op + `(1 . ,mode) ; reg/imm mode + `(4 . ,(cadr lhs)) ; lhs + `(4 . ,(cadr rhs))) ; rhs + + ;; immediate mode + (begin + (emit `(4 . 1) ; opcode = 1 + `(3 . ,(cadr op)) ; alu op + `(1 . ,mode) ; reg/imm mode + `(4 . ,(cadr lhs)) ; lhs + `(4 . 0)) ; unused + (emit `(16 . ,(cadr rhs)))) ; rhs + )) + +(define (add lhs rhs) (alu (alu-op 0) lhs rhs)) +(define (sub lhs rhs) (alu (alu-op 1) lhs rhs)) +(define (and lhs rhs) (alu (alu-op 2) lhs rhs)) +(define (or lhs rhs) (alu (alu-op 3) lhs rhs)) +(define (xor lhs rhs) (alu (alu-op 4) lhs rhs)) +(define (shl lhs rhs) (alu (alu-op 5) lhs rhs)) +(define (shr lhs rhs) (alu (alu-op 6) lhs rhs)) +(define (sar lhs rhs) (alu (alu-op 7) lhs rhs)) + +(define (ld lhs rhs #!key (indirect #f) (pop #f)) + (unless (eq? 'reg (type-of lhs)) (error "invalid lhs" lhs)) + + (define d-mode (if indirect 1 0)) + (define p-mode (if pop 1 0)) + + (define m-mode + (cond ((eq? 'reg (type-of rhs)) 0) + ((eq? 'imm (type-of rhs)) 1) + (else (error "invalid rhs" rhs)))) + + (if (= m-mode 0) + ;; reg mode + (emit `(4 . 2) ; opcode = 2 + `(1 . ,d-mode) ; indirect mode + `(1 . ,p-mode) ; pop mode + `(1 . 0) ; unused + `(1 . ,m-mode) ; reg/imm mode + `(4 . ,(cadr lhs)) ; lhs + `(4 . ,(cadr rhs))) ; rhs + + ;; immediate mode + (begin + (emit `(4 . 2) ; opcode = 2 + `(1 . ,d-mode) ; indirect mode + `(1 . ,p-mode) ; pop mode + `(1 . 0) ; unused + `(1 . ,m-mode) ; reg/imm mode + `(4 . ,(cadr lhs)) ; lhs + `(4 . 0)) ; unused + (emit `(16 . ,(cadr rhs)))) ; rhs + )) + +(define (mov lhs rhs) + (unless (eq? 'reg (type-of lhs)) (error "invalid lhs" lhs)) + (unless (eq? 'reg (type-of rhs)) (error "invalid rhs" rhs)) + + (emit `(4 . 3) ; opcode = 3 + `(4 . 0) ; unused + `(4 . ,(cadr lhs)) ; lhs + `(4 . ,(cadr rhs)))) ; rhs + +(define (st lhs rhs #!key (indirect #f) (push #f)) + (unless (eq? 'reg (type-of lhs)) (error "invalid lhs" lhs)) + + (define d-mode (if indirect 1 0)) + (define p-mode (if push 1 0)) + + (define m-mode + (cond ((eq? 'reg (type-of rhs)) 0) + ((eq? 'imm (type-of rhs)) 1) + (else (error "invalid rhs" rhs)))) + + (if (= m-mode 0) + ;; reg mode + (emit `(4 . 4) ; opcode = 4 + `(1 . ,d-mode) ; indirect mode + `(1 . ,p-mode) ; pop mode + `(1 . 0) ; unused + `(1 . ,m-mode) ; reg/imm mode + `(4 . ,(cadr lhs)) ; lhs + `(4 . ,(cadr rhs))) ; rhs + + ;; immediate mode + (begin + (emit `(4 . 4) ; opcode = 4 + `(1 . ,d-mode) ; indirect mode + `(1 . ,p-mode) ; pop mode + `(1 . 0) ; unused + `(1 . ,m-mode) ; reg/imm mode + `(4 . ,(cadr lhs)) ; lhs + `(4 . 0)) ; unused + (emit `(16 . ,(cadr rhs)))) ; rhs + )) + +(define (br flag offset #!key (asserted #t)) + (unless (eq? 'flag (type-of flag)) (error "invalid flag selector" flag)) + (define asserted + (cond (#t 1) + (#f 0) + (else (error "invalid asserted bool" asserted)))) + + (unless (eq? 'imm (type-of offset)) (error "invalid offset" offset)) + (define offset (cadr offset)) + (unless (< offset (expt 2 8)) (error "offset too large" offset)) + + (emit `(4 . 5) ; opcode = 5 + `(2 . ,(cadr flag)) ; flag selector + `(1 . 0) ; unused + `(1 . ,asserted) ; asserted (set / not set) + `(8 . ,offset)) ; offset + ) + +;; Utils + +(define (type-of v) + (if (and (list? v) + (> (length v) 0)) + (car v) + #f)) + +(define (assocar k alist) + (let ((v (assoc k alist))) + (and v (car v)))) +(define (assocdr k alist) + (let ((v (assoc k alist))) + (and v (cdr v)))) |