Start working on new ISA, add scheme assembler

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