;; -*- Mode: Lisp; -*- ;; --------------------------------------------------------------------------- ;; Title: Assembler for B32 ;; Created: 2021-02-13 ;; Author: Gilbert Baumann ;; License: MIT style (see below) ;; --------------------------------------------------------------------------- ;;; (c) copyright 2021 by Gilbert Baumann ;; Permission is hereby granted, free of charge, to any person obtaining ;; a copy of this software and associated documentation files (the ;; "Software"), to deal in the Software without restriction, including ;; without limitation the rights to use, copy, modify, merge, publish, ;; distribute, sublicense, and/or sell copies of the Software, and to ;; permit persons to whom the Software is furnished to do so, subject to ;; the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (defpackage :b32-asm (:use :common-lisp) (:export #:seg #:@ #:asm-to-vector #:asm) ) (in-package :b32-asm) ;;;; -- Overview -------------------------------------------------------------- ;; The assembler is two pass. ;;;; -------------------------------------------------------------------------- (defvar *segments* nil "List of segments.") (defvar *cur-segment* nil "The current segment, we emit instructions or data to.") (defvar *symbol-table* nil "Hash table of symbols to their definitions (expressions).") (defvar *macros* nil "Hash table mapping to macro functions.") (defvar *partial-eval-p* nil "Whether EVAL-EXPRESSION (1) tolerates unresolved values and (2) collects constants.") (defparameter *instructions* nil "A-List mapping from instruction names to macro functions.") (defvar *constant-queue* nil "A list of all (QUOTE expr) forms found. Or rather the _expr_ in it.") (defvar *allocated-constants* nil "A list of all allocated constants. The position in this list is the offset into the :CONST segment, where this constant could be found.") (defvar *anno-level*) (defstruct segment name ;; data is a vector of expressions initially (data (make-array 0 :adjustable t :fill-pointer 0)) (size 0) (base nil) ;base address of segment, if ;any (annos (make-hash-table)) ) (defstruct anno level form) (defun find-segment (name) (or (find name *segments* :key #'segment-name) (error "There is no sgement named ~S." name))) (defun emit (datum &optional (segment *cur-segment*)) "Emit (add) the datum, which is handled as an expression to the segment _seg_." (vector-push-extend datum (segment-data segment)) (incf (segment-size segment))) (defun emit-space (n) ;; ### (dotimes (i n) (emit 0))) (defun anno (form &optional (segment *cur-segment*)) ;; ### perhaps the wrong place to filter! (unless (and (consp form) (member (car form) '(progn tagbody block defconstant defmacro))) (push (make-anno :level *anno-level* :form form) (gethash (segment-size segment) (segment-annos segment))))) (defun lookup-symbol (sym &optional (errorp nil)) (multiple-value-bind (val foundp) (gethash sym *symbol-table*) (when (and errorp (not foundp)) (error "Symbol ~S not found." sym)) (values val foundp))) (defun enter-symbol (sym value) (when (gethash sym *symbol-table*) (error "Symbol/label ~S already defined." sym)) (setf (gethash sym *symbol-table*) value)) ;;;; -- Evaluation ------------------------------------------------------------ ;; ### explain *PARTIAL-EVAL-P*. (defparameter +standard-functions+ '(+ * - / floor ceiling truncate mod rem logior logxor logand lognot ash ldb dpb byte) "List of functions we borrow from CL.") (defun eval-expression (expr &aux it) (cond ((integerp expr) expr) ((characterp expr) (char-code expr)) ((symbolp expr) ;; ### Watch for recursive definitions? (cond ((string= '@ expr) (cond (*partial-eval-p* (eval-expression `(SEG ,(segment-name *cur-segment*) ,(segment-size *cur-segment*)))) (t (error "Gilberth could use more coffee -- How did this happen?")))) (t (multiple-value-bind (value foundp) (lookup-symbol expr) (cond (foundp (eval-expression value)) (*partial-eval-p* expr) (t (error "Undefined symbol ~S." expr))))))) ((or (atom expr) (not (symbolp (car expr)))) (error "Bad expression - ~S" expr)) ;; Macros ((setq it (gethash (car expr) *macros*)) (eval-expression (funcall it expr nil))) ;; Instructions as expressions ((setq it (find-instruction (car expr))) (eval-expression (funcall it expr nil))) ;; Standard functions ((member (car expr) +standard-functions+) (let ((args (mapcar #'eval-expression (cdr expr)))) (let ((res (cond ((every #'(lambda (x) (or (integerp x) (and (consp x) (eq (car x) 'lispval)))) args) ;; (print `(args = ,args)) (apply (car expr) (mapcar (lambda (x) (cond ((and (consp x) (eq (car x) 'lispval)) (cadr x)) (t x))) args))) (t `(,(car expr) ,@args))))) ;; Some fine implementations made BYTE evaluate to sth not-self ;; evaluating. QUOTE is taken, so we use LISPVAL to escape. (cond ((eq (car expr) 'byte) `(lispval ,res)) (t res))))) ;; Other builtins ((eq 'lispval (car expr)) expr) ((eq 'quote (car expr)) (destructuring-bind (sub-expr) (cdr expr) (let ((sub-expr (eval-expression sub-expr))) (cond (*partial-eval-p* (note-constant sub-expr) `(QUOTE ,sub-expr)) (t (find-constant sub-expr)))))) ((string= 'seg (car expr)) (destructuring-bind (segment &optional (offset 1)) (cdr expr) (let ((base (segment-base (find-segment segment))) (offset (eval-expression offset))) (cond ((null base) (unless *partial-eval-p* (error "How did this happen?")) `(seg ,segment ,offset)) (t (+ base offset)))))) (t (error "Bad expression - ~S" expr)) )) ;;;; -- Instructions ---------------------------------------------------------- (defun find-instruction (name &optional (errorp nil)) (cdr (or (assoc name *instructions* :test #'string=) (and errorp (error "Undefined instruction ~S." name))))) (defun (setf find-instruction) (new-value name &optional errorp) (declare (ignore errorp)) (let ((q (assoc name *instructions* :test #'string=))) (unless q (push (setq q (cons name nil)) *instructions*)) (setf (cdr q) new-value))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun parse-macro (name lambda-list body) ;; Poor man's version (let ((whole (gensym "WHOLE.")) (env (gensym "ENV."))) `(lambda (,whole ,env) (declare (ignore ,env)) (block ,name (destructuring-bind ,lambda-list (cdr ,whole) ,@body)))))) (defmacro definsn (name lambda-list &body body) `(progn (setf (find-instruction ',name) ,(parse-macro name lambda-list body)) ',name)) ;;;; New design: B32/381 #+NIL (progn (definsn clr () `(dpb #x0 (byte 4 28) 0)) (definsn rsb (addr) `(dpb #x1 (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn sub (addr) `(dpb #x2 (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn add (addr) `(dpb #x3 (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn xor (addr) `(dpb #x4 (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn ior (addr) `(dpb #x5 (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn and (addr) `(dpb #x6 (byte 4 28) (ldb (byte 28 0) ,addr))) ;; (definsn set () `(dpb #x7 (byte 4 28) 0)) (definsn asr () `(dpb #x7 (byte 4 28) 0)) (definsn sto (addr) `(dpb #x8 (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn jmp (addr) `(dpb #xC (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn jnz (addr) `(dpb #xD (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn jnc (addr) `(dpb #xE (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn jnv (addr) `(dpb #xF (byte 4 28) (ldb (byte 28 0) ,addr)))) ;;; Old design: B32/181 ;; opcode instruction action ;; ----------------------------------------------------------- ;; 0 add A = A + [addr] ;CF, OV affected ;; 1 undefined ;; 2 sub A = A - [addr] ;CF, OV affected ;; 3 undefined ;; 4 ior A = A | [addr] ;CF, OV undefined ;; 5 xor A = A ^ [addr] ;CF, OV undefined ;; 6 and A = A & [addr] ;CF, OV undefined ;; 7 asr 1 A = A >> 1 ;CF, OV undefined ;; 8 lod A = [addr] ;; 9 undefined ;; A sto [addr] = A ;; B undefined ;; C jmp PC = addr ;; D jnz PC = addr, if A != 0 ;; E jnc PC = addr, if CF clear ;; F jnv PC = addr, if OV clear (progn (definsn add (addr) `(dpb #x0 (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn sub (addr) `(dpb #x2 (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn ior (addr) `(dpb #x4 (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn xor (addr) `(dpb #x5 (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn and (addr) `(dpb #x6 (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn asr () `(dpb #x7 (byte 4 28) (ldb (byte 28 0) 0))) (definsn lod (addr) `(dpb #x8 (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn sto (addr) `(dpb #xA (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn jmp (addr) `(dpb #xC (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn jnz (addr) `(dpb #xD (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn jnc (addr) `(dpb #xE (byte 4 28) (ldb (byte 28 0) ,addr))) (definsn jnv (addr) `(dpb #xF (byte 4 28) (ldb (byte 28 0) ,addr))) ) ;;;; -- Top Level Forms ------------------------------------------------------- (defun asm-top-level (form &aux it) (declare (ignorable it)) (anno form) (cond ((symbolp form) (enter-symbol form (eval-expression '@))) ((or (atom form) (not (symbolp (car form)))) (error "Bad top level form - ~S" form)) ;; ((string= 'dw (car form)) (destructuring-bind (&rest values) (cdr form) (dolist (value values) (cond ((stringp value) (map nil (lambda (c) (emit (char-code c))) value)) (t (emit (eval-expression value))))))) ;; ((string= 'ds (car form)) (destructuring-bind (size) (cdr form) (let ((size (eval-expression size))) (unless (integerp size) (error "Size argument must be known at this point - ~S" form))) (emit-space size))) ;; ((string= 'seg (car form)) (destructuring-bind (segment) (cdr form) (setf *cur-segment* (find-segment segment)))) ;; ((string= 'text (car form)) (asm-top-level '(seg :text))) ((string= 'data (car form)) (asm-top-level '(seg :data))) ((string= 'bss (car form)) (asm-top-level '(seg :bss))) ;; ((or (eq 'tagbody (car form)) (eq 'progn (car form))) (destructuring-bind (&body body) (cdr form) (dolist (form body) (asm-top-level form)))) ;; ((eq 'defconstant (car form)) (destructuring-bind (name value &optional documentation) (cdr form) (declare (ignore documentation)) (enter-symbol name (eval-expression value)))) ;; ((eq 'defmacro (car form)) (destructuring-bind (name lambda-list &body body) (cdr form) (setf (gethash name *macros*) (compile nil (parse-macro name lambda-list body))))) ;; ((member (car form) '(in-package defpackage)) ;; ### Hmm?! (eval form)) ;; ((string= (car form) 'include) (with-open-file (input ;; (merge-pathnames (cadr form) (or *compile-file-pathname* *load-pathname*)) (cadr form) ) (loop for form = (read input nil input) until (eq form input) do (asm-top-level form)))) ;; ((setq it (find-instruction (car form))) (emit (eval-expression form))) ;; ((setq it (gethash (car form) *macros*)) (let ((*anno-level* (1+ *anno-level*))) (asm-top-level (funcall it form nil)))) ;; (t (error "Bad top level form - ~S" form)))) ;;;; -- Constants ------------------------------------------------------------- (defun note-constant (expr) "Called in the first path on any (QUOTE expr) found." (push expr *constant-queue*)) (defun find-constant (expr) "Called in the second path to get at the address of a constant. Returns an expression." (eval-expression `(seg :const ,(or (position expr *allocated-constants* :test #'equal) (error "Hugh?! This shouldn't happen."))))) (defun allocate-constants () "Merges and allocates all constants." (dolist (expr *constant-queue*) (print (list 'allo expr (eval-expression expr))) (pushnew (eval-expression expr) *allocated-constants* :test #'equal))) ;;;; -- Putting it together --------------------------------------------------- (defmacro with-asm-environment (&body body) `(let* ((*segments* (list (make-segment :name :text) (make-segment :name :const) (make-segment :name :data) (make-segment :name :bss))) (*cur-segment* (car *segments*)) (*macros* (make-hash-table)) ;; *partial-eval-p* (*constant-queue* nil) (*allocated-constants* nil) (*anno-level* 0) (*package* *package*)) (setq *symbol-table* (make-hash-table)) ,@body)) (defun e (x) (with-asm-environment (let ((*partial-eval-p* t)) (eval-expression x)))) (defun asm-to-vector (form) (with-asm-environment (let ((*partial-eval-p* t)) (asm-top-level form) ;; Care for constants. (allocate-constants) (let ((s (find-segment :const))) (dolist (c *allocated-constants*) (emit c s)))) ;; Segment bases are fixed now. (let ((base 0)) (dolist (segment *segments*) (setf (segment-base segment) base) (incf base (segment-size segment)))) ;; Eval constants (setq *allocated-constants* (let ((*partial-eval-p* nil)) (mapcar #'eval-expression *allocated-constants*))) ;; Second pass, fix what is in the segments (dolist (segment *segments*) (setf (segment-data segment) (map '(simple-array (unsigned-byte 32) (*)) (lambda (x) (ldb (byte 32 0) (eval-expression x))) (segment-data segment)))) ;; (let ((o *standard-output*)) (dolist (seg *segments*) (format o "~&;; Segment ~S~%" (segment-name seg)) ;; (unless (eq :bss (segment-name seg))) (let ((base (segment-base seg))) (loop for off from 0 for addr from base for word across (segment-data seg) do (format o "~6,'0X ~8,'0X " addr word) (let ((last-was-label-p nil)) (loop for a in (reverse (gethash off (segment-annos seg))) for k from 0 do (let ((form (anno-form a))) (cond ((zerop k) (cond ((symbolp form) (prin1 form o)) (t (format o "~36T") (format o "~v<~>~S" (* 2 (anno-level a)) form)))) (t (cond ((symbolp form) (format o "~%~20T~S" form)) (t (cond (last-was-label-p (format o "~36T")) (t (format o "~%~36<~>"))) (format o "~v<~>~S" (* 2 (anno-level a)) form))) )) (setq last-was-label-p (and (symbolp form) form)))) (terpri o)))) (terpri o))) ;; (maphash (lambda (k v) (setf (gethash k *symbol-table*) (eval-expression v))) *symbol-table*) ;; Return (apply #'concatenate '(simple-array (unsigned-byte 32) (*)) (mapcar #'segment-data *segments*)))) (defmacro asm (&rest body) `(asm-to-vector '(tagbody ,@body))) ;; Emacs: (put 'asm 'common-lisp-indent-function (get 'tagbody 'common-lisp-indent-function)) ;;;; -- Simulator ------------------------------------------------------------- (defvar *prog*) (defconstant +tty+ #xF00000) (defconstant +word-size+ 32) ;; DEFCONSTANT is broken by design so use DEFINE-SYMBOL-MACRO. (define-symbol-macro +opcode-byte+ (byte 4 28)) (define-symbol-macro +address-byte+ (byte 28 0)) (defvar *core* (make-array (expt 2 16) :element-type '(unsigned-byte 32))) (defvar *tty* nil) (defun window-clear (tty) (format tty "~A[H~A[2J" #\Escape #\Escape)(force-output tty)) (defun sim (&key (prog *prog*) (tracep nil) (baud nil) (entry 0) (acc 0) (inits nil) (tty *tty*)) ;; The old machine (setq tty (or tty (make-two-way-stream *standard-input* *standard-output*))) (let ((t0) (insn-count 0) (curcol -1) (swankp (ignore-errors (and (null tty) (typep *standard-output* (find-class (read-from-string "SWANK-BACKEND::SLIME-OUTPUT-STREAM"))))))) (declare (type fixnum insn-count)) ;; (print swankp) (fill *core* #xDEADBEEF) (replace *core* prog) (loop for (addr . val) in inits do (setf (aref *core* addr) val)) ;; (window-clear tty) ;; (format tty "~A[?25l" #\Escape) (setq t0 (get-internal-run-time)) (unwind-protect (let ((core *core*) (pc entry) (acc acc) (ov 0) (cf 0)) (declare (type (unsigned-byte 24) pc) (type (unsigned-byte 32) acc) (type bit ov cf) (type (simple-array (unsigned-byte 32) (*)) core)) ;; NOT! ;; (declare (optimize (speed 3) (safety 0))) (labels ((mem (addr) (cond ((= addr +tty+) (char-code (read-char *tty*))) (t (aref core addr)))) ((setf mem) (new-value addr) (cond ((= addr +tty+) (when swankp (when (= 96 (incf curcol)) (terpri) (setq curcol 0)) (when (= new-value 10) (setq curcol 0))) (write-char (code-char new-value) *tty*) (when baud (sleep (/ 10 baud))) (unless swankp (force-output tty))) (t (setf (aref core addr) new-value))))) (declare (inline mem (setf mem))) (loop (let* ((insn (mem (prog1 pc (incf pc)))) (op (ldb +opcode-byte+ insn)) (addr (ldb +address-byte+ insn))) (incf insn-count) ;; (when tracep (format t "~&~6,'0X: ~8,'0X ~A ~6,'0X ~A A=~8,'0X ~A ~A ~A~%" (1- pc) insn (elt '("add" "ill" "sub" "ill" "ior" "xor" "and" "asr" "lod" "ill" "sto" "ill" "jmp" "jnz" "jnc" "jnv") op) addr (if (and (< op #xA) (< -1 addr (length *core*))) (format nil "(= ~8,'0X)" (mem addr)) (format nil " ~8<~> ")) acc (if (zerop cf) "NC" " C") (if (zerop ov) "NV" " V") (if (zerop acc) " Z" "NZ"))) ;; (ecase op ;; add (0 (let* ((y (mem addr)) (s (+ acc y))) (setf cf (ldb (byte 1 32) s) ov (ldb (byte 1 (1- +word-size+)) (logand (lognot (logxor acc y)) (logxor s acc))) acc (ldb (byte +word-size+ 0) s)))) ;; sub (2 (let* ((y (mem addr)) (s (- acc y))) (setf cf (ldb (byte 1 32) s) ov (ldb (byte 1 (1- +word-size+)) (logand (logxor acc y) (logxor s acc)))) (setf acc (ldb (byte +word-size+ 0) s)))) ;; (4 (setf acc (logior acc (mem addr)))) ;ior (5 (setf acc (logxor acc (mem addr)))) ;xor (6 (setf acc (logand acc (mem addr)))) ;and (7 (setf acc (logior (logand #x80000000 acc) (ash acc -1)))) (8 (setf acc (mem addr))) ;lod (#xA (setf (mem addr) acc)) ;sto ;; jmp (#xC (when (= addr (1- pc)) (format tty "~%*** MACHINE HALTED ***~%") (force-output tty) (return-from sim acc)) (setf pc addr)) ;; (#xD (unless (zerop acc) (setf pc addr))) ;jnz (#xE (when (zerop cf) (setf pc addr))) ;jnc (#xF (when (zerop ov) (setf pc addr))) ))) )) (progn ;; (format t "~A[?25h" #\Escape) (format t "~%Your B32 roamed at ~:D insn/sec.~%" (round (/ insn-count (/ (- (get-internal-run-time) t0) internal-time-units-per-second)))) (force-output *standard-output*)) ))) ;;;; -- Program for testing --------------------------------------------------- (defparameter *chargen* (asm (tagbody (defconstant +tty+ #xF00000) ;; (defmacro lod (addr) `(progn (clr) (ior ,addr))) start (lod '#\Space) (sto curchar) loop (lod curchar) (sto +tty+) (add '1) (sto curchar) (sub '127) (jnz loop) ;; and again ;; halt (jmp halt) (jmp start) (:bss) curchar (ds 1)))) (defparameter *prog* (asm (tagbody (defmacro jc (addr) `(progn (jnc (+ @ 2)) (jmp ,addr))) (defmacro jz (addr) `(progn (jnz (+ @ 2)) (jmp ,addr))) (defmacro call (addr) `(progn (lod '(jmp (+ @ 2))) (jmp ,addr))) (defmacro halt () '(jmp @)) (defmacro stoi (addr) ;; A <- [[addr]] `(progn (sto aux) (lod ,addr) (ior '(sto 0)) (sto (+ @ 2)) (lod aux) (sto 0))) (defmacro lodi (addr) ;; [[addr]] <- A `(progn (lod ,addr) (ior '(lod 0)) (sto (+ @ 1)) (lod 0))) (defconstant +tty+ #xF00000) (:bss) aux (ds 1) (:bss) div.x (ds 1) div.y (ds 1) div.q (ds 1) div.m (ds 1) div.tmp (ds 1) (:text) div (sto div.ret) (lod '0) (sto div.q) (lod '1) (sto div.m) ;m = 1 div.L1 ;; while x <= 2y, shift both y and m left ;; and 2y still fits (lod div.y) (and '#x80000000) (jnz div.L2) (lod div.y) (add div.y) (sto div.tmp) (lod div.x) (sub div.tmp) (jc div.L2) ;does not fit (lod div.tmp) (sto div.y) ;y = y + y (lod div.m) (add div.m) (sto div.m) ;m = m + k (jmp div.L1) div.L2 (lod div.x) (sub div.y) (jc div.L3) (sto div.x) (lod div.q) (add div.m) (sto div.q) div.L3 (lod div.m) (asr) (and '#x7FFFFFFF) (jz div.done) (sto div.m) (lod div.y) (asr) (and '#x7FFFFFFF) (sto div.y) (jmp div.L2) div.done (lod div.q) div.ret (jmp @) ;; ;; pru -- Print unsigned number in PRU.N in decimal ;; (:bss) pru.n (dw 0) ;number to print pru.base (dw 10) ;print base pru.buf (ds 32) ;output buffer pru.ptr (ds 1) (:text) pru (sto pru.done) (lod 'pru.buf) (sto pru.ptr) pru.L1 ;; n = n / base, div.x = n % base (lod pru.n) (sto div.x) (lod pru.base) (sto div.y) (call div) (sto pru.n) ;; put remainder (= digit to print) into buffer (lod div.x) (stoi pru.ptr) ;; until n=0, continue (lod pru.n) (jz pru.L2) ;; ptr++ (lod pru.ptr) (add '1) (sto pru.ptr) (jmp pru.L1) ;loop pru.L2 ;; Output buffer in reverse (lodi pru.ptr) ;A = *ptr (sub '10) (jc pru.L4) ;<= 10 (add '(- #\A #\0 10)) ;correct for printing A..Z pru.L4 (add '(+ 10 #\0)) ;correct for ASCII and prior (SUB '10) (sto +tty+) (lod pru.ptr) (sub '1) (sto pru.ptr) ;ptr++ ;; check for end (sub '(- pru.buf 1)) (jnz pru.L2) ;loop pru.done (jmp 0) ;; ;; pri -- print signed number in pri.n in base pru.base ;; (:bss) (defconstant pri.n pru.n) ;shared (:text) pri (sto pru.done) ;setup for tail call ;; check for negative numbers (lod pri.n) (and '#x80000000) (jz (+ pru 1)) ;positive, tail call ;; print sign (lod '#\-) (sto +tty+) ;; negate (lod '0) (sub pri.n) (sto pru.n) (jmp (+ pru 1)) ;tail call ;; ;; hello -- base 36 demo ;; (:text) hello (sto hello.done) (lod '36) (sto pru.base) (lod '29234652) (sto pru.n) (call pru) (lod '#\space) (sto +tty+) (lod '22342248) (sto pru.n) (call pru) (lod '#\space) (sto +tty+) (lod '13801) (sto pru.n) (call pru) (lod '#\space) (sto +tty+) (lod '1004137) (sto pru.n) (call pru) (lod '573386) (sto pru.n) (call pru) hello.done (jmp 0) ;; ;; prs -- print zero terminated string pointed to by prs.s ;; (:bss) prs.s (dw 0) (:text) prs (sto prs.done) prs.L1 (lodi prs.s) (jz prs.done) (sto +tty+) (lod prs.s) (add '1) (sto prs.s) (jmp prs.L1) prs.done (jmp 0) ;; ;; hello2 -- prs demo ;; hello2 (sto hello2.done) (lod 'msg) (sto prs.s) (call prs) hello2.done (jmp 0) msg (dw "Hello world!" #x0A 0) ;; halt (jmp @) ))) ;;;; -------------------------------------------------------------------------- (defparameter *prog* ;; threaded (asm (tagbody (include "stdlib.asm") (defmacro mov (dst src) `(progn (lod ,src) (sto ,dst))) (defmacro add3 (rd rs rt) `(progn (lod ,rs) (add ,rt) ,@(if (eq rd 'acc) nil (list `(sto ,rd))))) (defmacro sub3 (rd rs rt) `(progn (lod ,rs) (sub ,rt) ,@(if (eq rd 'acc) nil (list `(sto ,rd))))) (defmacro bl (addr) `(progn (lod '(jmp (+ @ 3))) (sto lr) (jmp ,addr))) (defmacro ret () `(progn (lod lr) (sto (+ @ 1)) (jmp 0))) (defmacro push (&rest addrs) `(progn (lod sp) (sub ',(length addrs)) (sto sp) ,@(loop for k below (length addrs) collect `(add ',(if (= k 0) '(sto 0) 1)) collect `(sto (+ @ ,(* 2 (length addrs))))) ,@(loop for a in (reverse addrs) collect `(lod ,a) collect `(sto 0)) )) (defmacro pop (&rest addrs) `(progn (lod sp) (add ',(length addrs)) (sto sp) ,@(loop for k below (length addrs) collect `(add ',(if (= k 0) '(- (lod 0) 1) -1)) collect `(sto (+ @ ,(1- (* 2 (length addrs)))))) ,@(loop for a in addrs collect `(lod 0) collect `(sto ,a)))) (defmacro ld (rd rs &optional rt) `(progn ,@(and (not (eq rs 'acc)) (list `(lod ,rs))) ,@(and rt (list `(add ,rt))) (ior '(lod 0)) (sto (+ @ 1)) (lod 0) ,@(and (not (eq rd 'acc)) (list `(sto ,rd))))) (defmacro st (rd rs &optional rt) `(progn (lod ,rs) ,@(and rt (list `(add ,rt))) (ior '(sto 0)) (sto (+ @ 2)) (lod ,rd) (sto 0))) (:data) sp (dw #xF000) r0 (dw 0) r1 (dw 0) r2 (dw 0) r3 (dw 0) r4 (dw 0) r5 (dw 0) lr (dw 0) foo (dw 42) bar (dw 17) baz (dw 0) (:text) start (sto start.done) (mov r4 '1) start.L1 (mov prs.s 'm1) (call prs) (mov pru.n r4) (call pru) (mov prs.s 'm2) (call prs) (mov r0 r4) (bl fib) (mov pru.n r0) (call pru) (lod '10) (sto +tty+) (add3 r4 r4 '1) (sub3 acc r4 '25) (jnz start.L1) (halt) start.done (jmp @) m1 (dw "fib(" 0) m2 (dw ") = " 0) fib (sub3 acc r0 '3) (jnc fib.L1) (mov r0 '1) (ret) fib.L1 (push r5 r4 lr) ;; (mov r5 r0) (sub3 r0 r5 '1) (bl fib) (mov r4 r0) (sub3 r0 r5 '2) (bl fib) (add3 r0 r0 r4) ;; (pop r5 r4 lr) (ret) ))) ;;;; -------------------------------------------------------------------------- (defun x (s) (let ((*macros* (make-hash-table))) (list s (format nil "#x~8,'0X (~D.)" (aref *core* (eval-expression s)) (aref *core* (eval-expression s)))))) (defun foo () (progn (sim :tracep t) (list (x 'div.x) (x 'div.y) (x 'div.m) (x 'div.q)))) (defun chargen () (sim :prog *chargen* :baud 9600)) (defvar *tracep* nil) (defun call (routine &rest var-val-s) (let ((entry (lookup-symbol routine t))) (sim :tracep *tracep* :entry entry :acc #xC000FFFF :inits (cons (cons #xFFFF #xC000FFFF) (loop for (var val) on var-val-s by #'cddr collect (cons (lookup-symbol var) (ldb (byte 32 0) val)))) ;; :baud 9600 ))) (defun div (x y) (values (call 'div 'div.x x 'div.y y) (aref *core* (lookup-symbol 'div.x)))) (defparameter *chargen* (asm (tagbody (defconstant +tty+ #xF00000) (add 0) ;; constant 0 (add 1) ;; constant 1 print (lod P) (sto L1) (add 1) (sto P) L1 (lod 0) ;; acc = *P++ (sto +tty+) (lod N) (sub 1) (sto N) (jnz print) halt (jmp halt) P (lod MSG) N (dw (- MSG.end MSG)) MSG (dw "Hello dave0!" #x0A) MSG.end ))) ;; (call 'pru 'pru.n 4711 'pru.base 10) ;; (call 'pru 'pru.n -4711 'pru.base 10) ;; (call 'pri 'pri.n -4711 'pru.base 10) ;; (call 'hello)