;;; -*- Mode:LISP; Package:SIM; Readtable:CL; Base:10 -*- (defvar *local-symbols*) ; dest, s1, s2 could be: ; (open 4) ; (active 2) ; (return 0) ; (global 555) ; (func vma) ; (alu dest <- s1 aluop s2) ; (jump condition target) ; (jump-xct-next condition target) ; (sim sim-halt) (defprop halt ((%%i-halt 1)) sim-asm) (defun assemble-inst (sym-inst) (when (eq (car sym-inst) 'vma-start-read) (setq sym-inst `(alu (func ,(car sym-inst)) <- ,(cadr sym-inst) setl (garbage)))) (let ((func (get (car sym-inst) 'sim-asm-function))) (cond ((null func) (ferror nil "unknown form ~s" sym-inst)) (t (funcall func sym-inst))))) (defun parse-register-adr (inst clause reg-base reg-offset &aux load-time-stuff) (declare (values new-inst load-time-stuff)) (let ((reg-base-field (eval reg-base)) (reg-offset-field (eval reg-offset))) (ecase (car clause) (open (setq inst (dpb %i-base-open reg-base-field inst)) (setq inst (dpb (cadr clause) reg-offset-field inst))) (active (setq inst (dpb %i-base-active reg-base-field inst)) (setq inst (dpb (cadr clause) reg-offset-field inst))) (return (setq inst (dpb %i-base-return reg-base-field inst)) (setq inst (dpb (cadr clause) reg-offset-field inst))) (garbage (setq inst (dpb %i-base-return reg-base-field inst)) (setq inst (dpb -1 reg-offset-field inst))) (global (setq inst (dpb %i-base-global reg-base-field inst)) (let ((val (eval (cadr clause)))) (setq inst (dpb (ldb (byte 4 0) val) reg-offset-field inst)) (when (and (not (zerop (ldb %%i-immediate inst))) (not (= (ldb %%i-immediate inst) (ldb (byte 8 4) val)))) (ferror nil "inconsistant globals")) (setq inst (dpb (ldb (byte 8 4) val) %%i-immediate inst)))) (constant (setq inst (dpb %i-base-global reg-base-field inst)) (setq load-time-stuff (append `(%%i-immediate (constant-frame ,(cadr clause))) load-time-stuff)) (setq load-time-stuff (append `(,reg-offset (constant-offset ,(cadr clause))) load-time-stuff))) (func (setq inst (dpb %i-base-func reg-base-field inst)) (let ((adr (get (cadr clause) 'sim-func))) (when (null adr) (ferror nil "unknown functional register ~s" (cadr clause))) (setq inst (dpb (eval adr) reg-offset-field inst)))) ) (values inst load-time-stuff))) (defprop alu assemble-inst-alu sim-asm-function) (defprop alu ((%%i-opcode %i-op-alu)) sim-asm) (defprop no-op assemble-inst-alu sim-asm-function) (defprop no-op ((%%i-dest-base 3)) sim-asm) (defprop noop assemble-inst-alu sim-asm-function) (defprop noop ((%%i-dest-base 3)) sim-asm) (defprop add ((%%i-aluf lam:lam-alu-add) (%%i-uses-alu 1)) sim-asm) (defprop set1 ((%%i-aluf lam:lam-alu-setm)) sim-asm) (defprop set-source-1 ((%%i-aluf lam:lam-alu-setm)) sim-asm) (defprop setl ((%%i-aluf lam:lam-alu-setm)) sim-asm) (defprop setm ((%%i-aluf lam:lam-alu-setm)) sim-asm) (defprop setz ((%%i-aluf lam:lam-alu-setz)) sim-asm) (defprop m-a-1 ((%%i-aluf lam:lam-alu-m-a-1) (%%i-uses-alu 1)) sim-asm) (defprop l-r-1 ((%%i-aluf lam:lam-alu-m-a-1) (%%i-uses-alu 1)) sim-asm) (defprop sub ((%%i-aluf lam:lam-alu-sub) (%%i-uses-alu 1)) sim-asm) (defprop or ((%%i-aluf lam:lam-alu-ior) (%%i-uses-alu 1)) sim-asm) (defprop and ((%%i-aluf lam:lam-alu-and) (%%i-uses-alu 1)) sim-asm) (defprop l+r+1 ((%%i-aluf lam:lam-alu-m+a+1) (%%i-uses-alu 1)) sim-asm) (defprop <- t sim-asm) (defprop vma %func-vma sim-func) (defprop vma-start-write %func-vma-start-write sim-func) (defprop vma-start-read %func-vma-start-read sim-func) (defprop md %func-md sim-func) (defprop return %func-return sim-func) (defprop instruction-counter %func-instruction-counter sim-func) (defun assemble-inst-alu (sym-inst) (let ((inst 0) (regs '((%%i-dest-base %%i-dest-offset) (%%i-src-1-base %%i-src-1-offset) (%%i-src-2-base %%i-src-2-offset))) load-time-stuff x) (dolist (clause sym-inst) (cond ((consp clause) (multiple-value-bind (new-inst load-stuff) (parse-register-adr inst clause (caar regs) (cadar regs)) (setq inst new-inst) (setq load-time-stuff (append load-time-stuff load-stuff))) (pop regs)) ((setq x (get clause 'sim-asm)) (when (consp x) (dolist (field x) (setq inst (dpb (eval (cadr field)) (eval (car field)) inst))))) (t (ferror nil "unknown atom ~s" clause)))) (cons inst load-time-stuff))) (defprop store-immediate assemble-inst-immediate sim-asm-function) (defprop store-immediate ((%%i-opcode %i-op-store-immediate)) sim-asm) (defprop boxed ((%%i-unboxed-dest 0)) sim-asm) (defprop unboxed ((%%i-unboxed-dest 1)) sim-asm) (defun assemble-inst-immediate (sym-inst) (let ((inst 0) x load-time-stuff) (dolist (clause sym-inst) (cond ((consp clause) (multiple-value-bind (new-inst load-stuff) (parse-register-adr inst clause '%%i-dest-base '%%i-dest-offset) (setq inst new-inst) (setq load-time-stuff (append load-time-stuff load-stuff)))) ((setq x (get clause 'sim-asm)) (when (consp x) (dolist (field x) (setq inst (dpb (eval (cadr field)) (eval (car field)) inst))))) (t (ferror nil "unknown atom ~s" clause)))) (cons inst load-time-stuff))) (defprop immediate-data assemble-inst-immediate-data sim-asm-function) (defun assemble-inst-immediate-data (sym-inst) (cons 0 `(immediate-data ,(cadr sym-inst)))) (defprop jump assemble-inst-jump sim-asm-function) (defprop jump ((%%i-opcode %i-op-jump) (%%i-noop-next-bit 1)) sim-asm) (defprop jump-xct-next assemble-inst-jump sim-asm-function) (defprop jump-xct-next ((%%i-opcode %i-op-jump)) sim-asm) (defprop always ((%%i-jump-cond %i-jump-cond-unc)) sim-asm) (defprop less-than ((%%i-jump-cond %i-jump-cond-less-than)) sim-asm) (defprop equal ((%%i-jump-cond %i-jump-cond-equal)) sim-asm) (defprop not-equal ((%%i-jump-cond %i-jump-cond-not-equal)) sim-asm) (defprop greater-than ((%%i-jump-cond %i-jump-cond-greater-than)) sim-asm) (defprop greater-or-equal ((%%i-jump-cond %i-jump-cond-greater-or-equal)) sim-asm) (defprop data-type-equal ((%%i-jump-cond %i-jump-cond-data-type-equal)) sim-asm) (defprop data-type-not-equal ((%%i-jump-cond %i-jump-cond-data-type-not-equal)) sim-asm) (defun assemble-inst-jump (sym-inst) (let ((inst 0) x load-time-stuff) (dolist (clause sym-inst) (cond ((consp clause) (ferror nil "??")) ((setq x (get clause 'sim-asm)) (when (consp x) (dolist (field (get clause 'sim-asm)) (setq inst (dpb (eval (cadr field)) (eval (car field)) inst))))) ((numberp clause) (setq inst (dpb clause %%i-jump-adr inst))) ((assq clause *local-symbols*) (setq load-time-stuff (append `(%%i-jump-adr (local-jump-target ,clause)) load-time-stuff))) (t (setq load-time-stuff (append `(%%i-jump-adr (jump-target ,clause)) load-time-stuff))))) (cons inst load-time-stuff))) (defun assemble-inst-generic (sym-inst) (let ((inst 0) x) (dolist (clause sym-inst) (cond ((consp clause) (ferror nil "??")) ((setq x (get clause 'sim-asm)) (when (consp x) (dolist (field (get clause 'sim-asm)) (setq inst (dpb (eval (cadr field)) (eval (car field)) inst))))) (t (ferror nil "unknnown atom ~s" clause)))) (list inst))) (defprop open assemble-inst-open sim-asm-function) (defprop open ((%%i-opcode %i-op-open)) sim-asm) (defprop tail-recursive-open assemble-inst-open sim-asm-function) (defprop tail-recursive-open ((%%i-opcode %i-op-tail-recursive-open)) sim-asm) (defun assemble-inst-open (sym-inst) (let ((inst 0) x load-time-stuff (regular-open-p (eq (car sym-inst) 'open)) (seen-dest-p nil) ) (dolist (clause sym-inst) (cond ((consp clause) (setq seen-dest-p t) (multiple-value-bind (new-inst load-stuff) (parse-register-adr inst clause '%%i-dest-base '%%i-dest-offset) (setq inst new-inst) (setq load-time-stuff (append load-time-stuff load-stuff)))) ((setq x (get clause 'sim-asm)) (when (consp x) (dolist (field (get clause 'sim-asm)) (setq inst (dpb (eval (cadr field)) (eval (car field)) inst))))) (t (ferror nil "unknnown atom ~s" clause)))) (cond ((and regular-open-p (not seen-dest-p)) (ferror nil "open must have dest")) ((and (not regular-open-p) seen-dest-p) (ferror nil "tail-recursive-open doesn't have a dest"))) (cons inst load-time-stuff))) (defprop call-xct-next assemble-inst-call sim-asm-function) (defprop call-xct-next ((%%i-opcode %i-op-call)) sim-asm) (defprop tail-recursive-call-xct-next assemble-inst-call sim-asm-function) (defprop tail-recursive-call-xct-next ((%%i-opcode %i-op-tail-recursive-call)) sim-asm) (defprop tail-recursive-call-xct-next-indirect assemble-inst-call sim-asm-function) (defprop tail-recursive-call-xct-next-indirect ((%%i-opcode %i-op-tail-recursive-call-indirect)) sim-asm) (defun assemble-inst-call (sym-inst) (let ((inst 0) x load-time-stuff (symbolic-op (car sym-inst))) (dolist (clause sym-inst) (cond ((consp clause) (when (not (eq symbolic-op 'tail-recursive-call-xct-next-indirect)) (ferror nil "??")) (multiple-value-bind (new-inst load-stuff) (parse-register-adr inst clause '%%i-src-1-base '%%i-src-1-offset) (setq inst new-inst) (setq load-time-stuff (append load-time-stuff load-stuff)))) ((setq x (get clause 'sim-asm)) (when (consp x) (dolist (field (get clause 'sim-asm)) (setq inst (dpb (eval (cadr field)) (eval (car field)) inst))))) ((numberp clause) (setq inst (dpb clause %%i-jump-adr inst))) ((assq clause *local-symbols*) ;(setq load-time-stuff (append `(%%i-jump-adr (jump-target ,clause)) load-time-stuff))) (ferror nil "what are you trying to call that is on the *local-symbols* list?")) (t (setq load-time-stuff (append `(%%i-jump-adr (jump-target ,clause)) load-time-stuff)) ))) (cons inst load-time-stuff))) (defprop return-xct-next assemble-inst-generic sim-asm-function) (defprop return-xct-next ((%%i-opcode %i-op-return)) sim-asm) (defun disassemble-inst (inst) (select (ldb %%i-opcode inst) (%i-op-alu (disassemble-inst-alu inst)) (%i-op-jump (disassemble-inst-jump inst)) (%i-op-sim (disassemble-inst-sim inst)) (%i-op-open (disassemble-inst-open inst)) (%i-op-tail-recursive-open (disassemble-inst-tail-recursive-open inst)) (%i-op-call (disassemble-inst-call inst)) (%i-op-tail-recursive-call (disassemble-inst-tail-recursive-call inst)) (%i-op-return (disassemble-inst-return inst)) (%i-op-store-immediate (disassemble-inst-store-immediate inst)) (%i-op-tail-recursive-call-indirect (disassemble-inst-tail-recursive-call-indirect inst)) (t (ferror nil "unknown opcode")))) (defun disassemble-inst-store-immediate (original-inst) (let ((inst original-inst) sym-inst) (setq sym-inst `(store-immediate ,(unparse-reg-adr (ldb %%i-dest-base inst) (ldb %%i-dest-offset inst) (ldb %%i-immediate inst)))) (setq inst (dpb 0 %%i-dest-base inst)) (setq inst (dpb 0 %%i-dest-offset inst)) (setq inst (dpb 0 %%i-immediate inst)) (setq inst (dpb 0 %%i-opcode inst)) (when (ldb-test %%i-halt inst) (setq sym-inst (append sym-inst '(halt))) (setq inst (dpb 0 %%i-halt inst))) (when (not (zerop inst)) (ferror nil "leftover bits")) sym-inst)) (defun disassemble-inst-open (original-inst) (let* ((inst original-inst) (sym-inst `(open ,(unparse-reg-adr (ldb %%i-dest-base inst) (ldb %%i-dest-offset inst) (ldb %%i-immediate inst))))) (setq inst (dpb 0 %%i-dest-base inst)) (setq inst (dpb 0 %%i-dest-offset inst)) (setq inst (dpb 0 %%i-immediate inst)) (setq inst (dpb 0 %%i-opcode inst)) (when (ldb-test %%i-halt inst) (setq sym-inst (append sym-inst (list 'halt))) (setq inst (dpb 0 %%i-halt inst))) (when (not (zerop inst)) (ferror nil "leftover bits")) sym-inst)) (defun disassemble-inst-tail-recursive-open (inst) inst `(tail-recursive-open)) (defun disassemble-inst-call (inst) `(,(ecase (ldb %%i-noop-next-bit inst) (0 'call-xct-next) (1 'call)) ,(let ((adr (ldb %%i-jump-adr inst))) (or (adr-to-breakpoint-name adr) adr)))) (defun disassemble-inst-tail-recursive-call (inst) `(,(ecase (ldb %%i-noop-next-bit inst) (0 'tail-recursive-call-xct-next) (1 'tail-recursive-call)) ,(ldb %%i-jump-adr inst))) (defun disassemble-inst-tail-recursive-call-indirect (inst) `(,(ecase (ldb %%i-noop-next-bit inst) (0 'tail-recursive-call-xct-next) (1 'tail-recursive-call)) ,(unparse-reg-adr (ldb %%i-src-1-base inst) (ldb %%i-src-1-offset inst) (ldb %%i-immediate inst)))) (defun disassemble-inst-return (inst) `(,(ecase (ldb %%i-noop-next-bit inst) (0 'return-xct-next) (1 'return)) )) (defun disassemble-inst-sim (inst) `(sim ,(aref *sim-ops* (ldb %%i-immediate inst)))) (defun unparse-reg-adr (base-code offset immediate) (let ((result (list nil nil))) (select base-code (%i-base-active (setf (car result) 'active) (setf (cadr result) offset)) (%i-base-open (setf (car result) 'open) (setf (cadr result) offset)) (%i-base-return (cond ((= offset #o17) (setq result (list 'garbage))) (t (setf (car result) 'return) (setf (cadr result) offset)))) (%i-base-global (setf (car result) 'global) (setf (cadr result) (+ offset (ash immediate 4)))) (%i-base-func (setf (car result) 'func) (setf (cadr result) (select offset (%func-vma 'vma) (%func-vma-start-write 'vma-start-write) (%func-vma-start-read 'vma-start-read) (%func-md 'md) (%func-return 'return) (%func-instruction-counter 'instruction-counter) (t (ferror nil "unknown functional register"))))) (t (ferror nil "unknown base code"))) result)) (defun disassemble-inst-alu (original-inst) (let ((result (make-alu-inst)) (inst original-inst)) (setf (alu-inst-flag result) 'alu) (setf (alu-inst-arrow result) '<-) (setq inst (dpb 0 %%i-opcode inst)) (setf (alu-inst-dest result) (unparse-reg-adr (ldb %%i-dest-base inst) (ldb %%i-dest-offset inst) (ldb %%i-immediate inst))) (setq inst (dpb 0 %%i-dest-base inst)) (setq inst (dpb 0 %%i-dest-offset inst)) (setf (alu-inst-s1 result) (unparse-reg-adr (ldb %%i-src-1-base inst) (ldb %%i-src-1-offset inst) (ldb %%i-immediate inst))) (setq inst (dpb 0 %%i-src-1-base inst)) (setq inst (dpb 0 %%i-src-1-offset inst)) (setf (alu-inst-s2 result) (unparse-reg-adr (ldb %%i-src-2-base inst) (ldb %%i-src-2-offset inst) (ldb %%i-immediate inst))) (setq inst (dpb 0 %%i-src-2-base inst)) (setq inst (dpb 0 %%i-src-2-offset inst)) (setq inst (dpb 0 %%i-immediate inst)) (setf (alu-inst-aluop result) (select (ldb %%i-aluf inst) (0 'setz) (lam:lam-alu-add 'add) (lam:lam-alu-setm 'set1) (lam:lam-alu-m-a-1 'm-a-1) (lam:lam-alu-sub 'sub) (lam:lam-alu-ior 'or) (lam:lam-alu-and 'and) (lam:lam-alu-m+a+1 'l+r+1) (t (ferror nil "unknown alu function")))) (setq inst (dpb 0 %%i-aluf inst)) (when (ldb-test %%i-uses-alu inst) (setq result (append result (list 'uses-alu))) (setq inst (dpb 0 %%i-uses-alu inst))) (when (ldb-test %%i-halt inst) (setq result (append result (list 'halt))) (setq inst (dpb 0 %%i-halt inst))) (when (not (zerop inst)) (ferror nil "leftover bits")) result)) (defun disassemble-inst-jump (original-inst) (let ((result (make-jump-inst)) (inst original-inst)) (setq inst (dpb 0 %%i-opcode inst)) (ecase (ldb %%i-noop-next-bit inst) (0 (setf (jump-inst-type result) 'jump-xct-next)) (1 (setf (jump-inst-type result) 'jump))) (setq inst (dpb 0 %%i-noop-next-bit inst)) (setf (jump-inst-cond result) (select (ldb %%i-jump-cond inst) (%i-jump-cond-unc 'always) (%i-jump-cond-less-than 'less-than) (%i-jump-cond-equal 'equal) (%i-jump-cond-not-equal 'not-equal) (%i-jump-cond-greater-than 'greater-than) (%i-jump-cond-greater-or-equal 'greater-or-equal) (t (ferror nil "unknown jump cond")))) (setq inst (dpb 0 %%i-jump-cond inst)) (let ((adr (ldb %%i-jump-adr inst))) (let ((name (adr-to-breakpoint-name adr))) (cond ((null name) (setf (jump-inst-target result) (ldb %%i-jump-adr inst))) (t (setf (jump-inst-target result) name))))) (setq inst (dpb 0 %%i-jump-adr inst)) (when (not (zerop inst)) (ferror nil "leftover bits")) result)) (defun assemble-program (program) (let ((*local-symbols* nil) (last-inst-was-return nil) ) (loop for sym-inst in program when (symbolp sym-inst) do (push (cons sym-inst :unknown) *local-symbols*)) (loop for sym-inst in program collect (cond ((consp sym-inst) (when (and last-inst-was-return (not (member '(func return) sym-inst :test 'equal))) (ferror nil "return instructions must be followed by dest (FUNC RETURN)")) (setq last-inst-was-return (eq (car sym-inst) 'return-xct-next)) (assemble-inst sym-inst)) (t sym-inst))))) (defmacro define-asm (name &rest form) (declare (arglist name arglist &body body)) `(define-asm-1 ',name ',form)) (defun define-asm-1 (name form) (when (not (symbolp name)) (ferror nil "name must be symbol")) (let ((lambda-exp (si:process-defun-body name form t)) documentation arglist declarations body ) ;;now we have (named-lambda (foo (documentation "foobar")) (args) (declare (...) (...)) body) ;;the declare may be absent (setq documentation (cadr (assq 'si:documentation (si:debugging-info lambda-exp)))) (setq arglist (third lambda-exp)) (setq body (cdddr lambda-exp)) (when (eq (caar body) 'declare) (setq declarations (cdr (car body))) (pop body)) (putprop name (assemble-program body) 'sim-program))) (defvar *constants* (make-array 16.)) (defvar *constants-frame-base* 1) (defun find-or-make-constant (val) (setq val (eval val)) (cond ((eq val t) (setq val (dpb dtp-symbol %%q-data-type 5))) ((eq val nil) (setq val (dpb dtp-symbol %%q-data-type 0)))) (do ((index 0 (1+ index)) ;don't use 0 first-free) ((= index (array-length *constants*)) (when (null first-free) (ferror nil "out of constant slots")) (aset val *constants* first-free) (+ (* *constants-frame-base* 16.) first-free)) (let ((this-val (aref *constants* index))) (when (and (integerp this-val) (= this-val val)) (return (+ (* *constants-frame-base* 16.) index))) (when (and (null this-val) (null first-free)) (setq first-free index))))) (defun install-constants () (do ((index 0 (1+ index)) (register (* *constants-frame-base* 16.) (1+ register))) ((= index (array-length *constants*))) (let ((val (aref *constants* index))) (when val (send *proc* :write-frames register val))))) (defun count-instructions (function) (let ((code (get function 'sim-program))) (when (null code) (ferror nil "no code")) (do ((adr 0) (inst-list code (cdr inst-list))) ((null inst-list) adr) (when (consp (car inst-list)) (incf adr))))) (defun d (f) (grind-top-level (get f 'sim-program))) (defun load-resolve-immediate-data (val) (cond ((consp val) (ecase (car val) (value-cell (cond ((eq (cadr val) nil) (dpb dtp-symbol %%q-data-type 0)) (t (ferror nil "don't know any symbols but nil")))) (function (let ((adr (symbol-lookup (cadr val)))) (when (null adr) (ferror nil "function ~s is not defined" (cadr val))) adr)) (quote (>whole-q (>intern (string (cadr val))))) )) ((integerp val) val) (t (ferror nil "unknown immediate ~s" val)))) (defun store-function-into-main-memory (function starting-adr &aux jump-addresses) (labels ((load-time-update (inst field val) (case field (immediate-data (load-resolve-immediate-data val)) (t (ecase (car val) ((jump-target local-jump-target) (let ((possible-local (assq (cadr val) jump-addresses))) (cond ((null possible-local) (let ((func (symbol-lookup (cadr val)))) (when (null func) (ferror nil "unknown jump target ~s" (cadr val))) (dpb func (eval field) inst))) (t (dpb (cdr possible-local) (eval field) inst))))) (constant-frame (let ((constant-adr (find-or-make-constant (cadr val)))) (let ((frame (ldb (byte 8 4) constant-adr))) (when (and (not (zerop (ldb %%i-immediate inst))) (not (= (ldb %%i-immediate inst) frame))) (ferror nil "two different global frames in same inst")) (dpb frame %%i-immediate inst)))) (constant-offset (let ((constant-adr (find-or-make-constant (cadr val)))) (dpb constant-adr (eval field) inst))) ))))) (when (null (get function 'sim-program)) (ferror nil "no program")) (do ((adr starting-adr) (code (get function 'sim-program) (cdr code))) ((null code) (push (cons '|end| adr) jump-addresses)) (cond ((consp (car code)) (incf adr)) (t (push (cons (car code) adr) jump-addresses)))) (do ((adr starting-adr) numeric-inst (inst-list (get function 'sim-program) (cdr inst-list))) ((null inst-list)) (when (consp (car inst-list)) (setq numeric-inst (caar inst-list)) (do ((load-time-stuff (cdar inst-list) (cddr load-time-stuff))) ((null load-time-stuff)) (setq numeric-inst (load-time-update numeric-inst (car load-time-stuff) (cadr load-time-stuff)))) (send *proc* :write-main-memory adr numeric-inst) (incf adr))) (cdr (assq '|end| jump-addresses))))