;;; -*- Mode:LISP; Package:SIMULATOR; Base:10; Readtable:ZL -*- ;;; Expansion of K machine symbolic instructions ;;; into Lisp code with calls to simulator functions ;;; (MOVE O2 A3) ;;; (MOVE RETURN A1 CH-RETURN) ;;; (MOVE O0 A1 CH-OPEN) ;;; (ALU L+R A0 A2 A3 CH-OPEN BW-24) ;;; (ALU L+R+1 RETURN '0 A1 CH-RETURN) ;;; (TEST BR-EQUAL) ;;; (BRANCH FOO) ;;; (BRANCH FOO (MOVE A0 A1)) ;;; (BRANCH FOO (MOVE A0 A1) CH-OPEN) ;;; (BRANCH FOO (ALU L+R O0 A1 A2) CH-OPEN) ;;; (KCALL FOO '3 A0 (O0 A1) CH-OPEN) ;;; (KCALL FOO '3 O0) ;;; (KOPEN) ;;; (OPEN-CALL CAR '1 O1 (O0 A1)) ;;; (TAIL-CALL FOO '2) ;;; (TAIL-CALL FOO '2 (O1 A2)) ;;; (JUMP FOO) ;;; (JUMP FOO (A0 A1)) (defparameter *statistics-p* t) (defparameter *i-time* 75. "Instruction cycle time in nanoseconds") (defvar *i-count* 0) (defun do-stats () (cond (*statistics-p* `(incf *i-count*)) (t nil))) (defun stats (form) (setq *i-count* 0) (prog1 (si:eval-special-ok form) (format t "~&~d Instruction~:p, ~,9f Seconds (~dns//Inst)" *i-count* (* *i-count* *i-time* 1e-9) *i-time*))) (defvar *global-registers* '()) (defmacro defreg (name frame offset) `(progn (pushnew (list ',name ,frame ,offset) *global-registers*) (defvar ,name))) ;;;; Alu Ops (defvar *low-level-alu* nil) (defmacro K:L+R+1 (l r w) `(1+ (+ ,l ,r))) (defmacro K:L+R-1 (l r w) `(1- (+ ,l ,r))) (defmacro K:L+R (l r w) (if *low-level-alu* `(alu-operation #'add ,w ,l ,r) `(+ ,l ,r))) (defmacro K:L-R (l r w) `(si:%pointer-difference ,l ,r)) ; `(- ,l ,r)) ;; (micro:sub w l r) (defmacro K:SETR (l r w) (declare (ignore l)) r) (defmacro K:SETL (l r w) (declare (ignore r)) l) (defmacro K:ALU-OR (l r w) `(logior ,l ,r)) (defmacro K:ALU-AND (l r w) `(logand ,l ,r)) (defun get-width (options) (cond ((member 'K:BW-32 options) 0) ((member 'K:BW-8 options) 1) ((member 'K:BW-16 options) 2) ((member 'K:BW-24 options) 3) (t 0.))) ;;; Optional fields (defvar *default-options* ()) (defmacro def-option (name default arglist &body body) `(progn (pushnew ',default *default-options*) (setf (get ',name 'option-default) ',default) (defmacro ,name ,arglist ,@body))) (defun do-options (options left right) (setq options (remove-if #'(lambda (option) (member option '(K:BW-32 K:BW-24 K:BW-16 K:BW-8))) options)) (let ((defaults *default-options*)) `(progn ,(do-stats) ,@(mapcar #'(lambda (option) (setq defaults (remove (get option 'option-default) defaults)) (list option left right)) options) ,@(mapcar #'(lambda (option) (list option left right)) defaults)))) ;;;; Call Hardware (def-option K:CH-NOOP K:CH-NOOP (l r) nil) (def-option K:CH-OPEN K:CH-NOOP (l r) (declare (ignore l r)) `(%k-open)) (def-option K:CH-TAIL-OPEN k:CH-NOOP (l r) (declare (ignore l r)) `(%k-t-open)) ;;; this is done in the dest (def-option K:CH-RETURN K:CH-NOOP (l r) (declare (ignore l r)) nil) ;;;; Branch Conditions ;;; This is not quite right ;;; because it should test TEMP of the last instruction ;;; (before the one with the condition) but either this ;;; instruction or the branch might change TEMP ... (defvar *condition* 'always) (def-option K:BR-NEVER K:BR-NEVER (l r) (setq *condition* 'nil) nil) (def-option K:BR-ALWAYS K:BR-NEVER (l r) (declare (ignore l r)) (setq *condition* 'true) nil) (def-option K:BR-EQUAL K:BR-NEVER (l r) (declare (ignore l r)) (setq *condition* '(zerop temp)) nil) (def-option K:BR-NOT-EQUAL K:BR-NEVER (l r) (declare (ignore l r)) (setq *condition* '(not (zerop temp))) nil) (def-option K:BR-NOT-LESS-THAN K:BR-NEVER (l r) (declare (ignore l r)) (setq *condition* '(not (< temp 0))) nil) (def-option K:BR-NOT-GREATER-THAN K:BR-NEVER (l r) (declare (ignore l r)) (setq *condition* '(not (> temp 0))) nil) (def-option K:BR-NOT-LESS-THAN-OR-EQUAL K:BR-NEVER (l r) (declare (ignore l r)) (setq *condition* '(not (<= temp 0)))) ;;;; Data type checking ;(defun trap (trap) (error "Trap: ~a" trap)) (def-option K:DT-NOOP K:DT-NOOP (l r) (declare (ignore l r)) nil) ;(def-option K:DT-BOTH-FIX K:DT-NOOP (l r) ; `(unless (and (fixp ,l) (fixp ,r)) ; (trap 'not-both-fix))) ;;;; Sources ;;; specifies a global register (defmacro K:%REGISTER (name frame offset) name) (defmacro K:%VALUE-CELL (name) name) (defvar *functional-sources* '((read-gc-ram . sim:k-read-gc-ram) (read-map . sim:k-read-map) (read-md . sim:k-read-md) (read-memory-control . sim:k-read-memory-control) (read-memory-status . sim:k-read-memory-status) (read-processor-control . sim:k-read-processor-control) (read-processor-status . sim:k-read-processor-status) (read-transporter-ram . sim:k-read-transporter-ram) (read-trap . sim:k-read-trap) (read-vma . sim:k-read-vma))) (defun read-right-source (right-source) (cond ((symbolp right-source) (cond ((or (member right-source *active-registers*) (member right-source *open-registers*) (member right-source *return-registers*)) right-source) (t (let ((fsource (assoc right-source *functional-sources*))) (if fsource `(,(cdr fsource)) (error "Unknown source: ~a" right-source)))))) ((eq (car-safe right-source) 'quote) right-source) ((eq (car-safe right-source) 'K:%REGISTER) (cadr right-source)) ((eq (car-safe right-source) '%VALUE-CELL) `(progn (incf *i-count* 2) ,(cadr right-source))) (t (cerror "call it" "unknown source: ~a" right-source) `(,right-source)))) ;;;; Destinations (defvar *functional-destinations* '((K:md-start-write-no-gc-write-test . sim:k-md-start-write-option-0) (K:md-start-write . sim:k-md-start-write-option-1) (K:md-start-write-unboxed-no-gc-write-test . sim:k-md-start-write-unboxed-option-0) (K:md-start-write-unboxed . sim:k-md-start-write-unboxed-option-1) (K:vma-start-read-cdr . sim:k-vma-start-read-cdr-option-0) (K:vma-start-read-cdr-no-transport . sim:k-vma-start-read-cdr-option-1) (K:vma-start-read-cdr-option-2 . sim:k-vma-start-read-cdr-option-2) (K:vma-start-read-cdr-option-3 . sim:k-vma-start-read-cdr-option-3) (K:vma-start-read-md-unboxed-cdr . sim:k-vma-start-read-md-unboxed-cdr-option-0) (K:vma-start-read-md-unboxed-cdr-no-transport . sim:k-vma-start-read-md-unboxed-cdr-option-1) (K:vma-start-read-md-unboxed-cdr-option-2 . sim:k-vma-start-read-md-unboxed-cdr-option-2) (K:vma-start-read-md-unboxed-cdr-option-3 . sim:k-vma-start-read-md-unboxed-cdr-option-3) (K:vma-start-read-md-unboxed . sim:k-vma-start-read-md-unboxed-option-0) (K:vma-start-read-md-unboxed-no-transport . sim:k-vma-start-read-md-unboxed-option-1) (K:vma-start-read-md-unboxed-option-2 . sim:k-vma-start-read-md-unboxed-option-2) (K:vma-start-read-md-unboxed-option-3 . sim:k-vma-start-read-md-unboxed-option-3) (K:vma-start-read . sim:k-vma-start-read-option-0) (K:vma-start-read-no-transport . sim:k-vma-start-read-option-1) (K:vma-start-read-option-2 . sim:k-vma-start-read-option-2) (K:vma-start-read-option-3 . sim:k-vma-start-read-option-3) (K:vma-start-read-unboxed-cdr . sim:k-vma-start-read-unboxed-cdr-option-0) (K:vma-start-read-unboxed-cdr-no-transport . sim:k-vma-start-read-unboxed-cdr-option-1) (K:vma-start-read-unboxed-cdr-option-2 . sim:k-vma-start-read-unboxed-cdr-option-2) (K:vma-start-read-unboxed-cdr-option-3 . sim:k-vma-start-read-unboxed-cdr-option-3) (K:vma-start-read-unboxed-md-unboxed-cdr . sim:k-vma-start-read-unboxed-md-unboxed-cdr-option-0) (K:vma-start-read-unboxed-md-unboxed-cdr-no-transport . sim:k-vma-start-read-unboxed-md-unboxed-cdr-option-1) (K:vma-start-read-unboxed-md-unboxed-cdr-option-2 . sim:k-vma-start-read-unboxed-md-unboxed-cdr-option-2) (K:vma-start-read-unboxed-md-unboxed-cdr-option-3 . sim:k-vma-start-read-unboxed-md-unboxed-cdr-option-3) (K:vma-start-read-unboxed-md-unboxed . sim:k-vma-start-read-unboxed-md-unboxed-option-0) (K:vma-start-read-unboxed-md-unboxed-no-transport . sim:k-vma-start-read-unboxed-md-unboxed-option-1) (K:vma-start-read-unboxed-md-unboxed-option-2 . sim:k-vma-start-read-unboxed-md-unboxed-option-2) (K:vma-start-read-unboxed-md-unboxed-option-3 . sim:k-vma-start-read-unboxed-md-unboxed-option-3) (K:vma-start-read-unboxed . sim:k-vma-start-read-unboxed-option-0) (K:vma-start-read-unboxed-no-transport . sim:k-vma-start-read-unboxed-option-1) (K:vma-start-read-unboxed-option-2 . sim:k-vma-start-read-unboxed-option-2) (K:vma-start-read-unboxed-option-3 . sim:k-vma-start-read-unboxed-option-3) (K:vma-start-write-no-gc-write-test . sim:k-vma-start-write-option-0) (K:vma-start-write . sim:k-vma-start-write-option-1) (K:vma-start-write-unboxed-no-gc-write-test . sim:k-vma-start-write-unboxed-option-0) (K:vma-start-write-unboxed . sim:k-vma-start-write-unboxed-option-1) (K:write-gc-ram . sim:k-write-gc-ram) (K:write-map . sim:k-write-map) (K:write-md-boxed . sim:k-write-md-boxed) (K:write-md-unboxed . sim:k-write-md-unboxed) (K:write-memory-control . sim:k-write-memory-control) (K:write-processor-control . sim:k-write-processor-control) (K:write-transporter-ram . sim:k-write-transporter-ram) (K:write-vma-boxed . sim:k-write-vma-boxed) (K:write-vma-unboxed . sim:k-write-vma-unboxed) (K:return . ???) (K:noop . ???) (K:noop-no-overflow-trap . noop-no-overflow-trap))) (defmacro noop-no-overflow-trap (value) (declare (ignore value)) ()) (defun store-dest (dest options) (cond ((symbolp dest) (cond ((or (member dest *active-registers*) (member dest *open-registers*) (member dest *return-registers*)) `((setq ,dest temp))) ((and (eq dest 'K:RETURN) (member 'K:CH-RETURN options)) `((%k-return temp))) (t (let ((fdest (assoc dest *functional-destinations*))) (if fdest `((,(cdr fdest) temp)) (error "Unknown destination: ~a" dest)))))) ((eq (car-safe dest) 'K:%REGISTER) `((setq ,(cadr dest) temp))) ((eq (car-safe dest) '%VALUE-CELL) `((incf *i-count*) (setq ,(cadr dest) temp))) (t (cerror "call it" "unknown destination: ~a" dest) `((,dest temp))))) ;---------------------------------------------------------------- ;;;; Instructions ;;; temp represents the value on the output of the ALU ;;; before it gets put in a dest (defmacro K:ALU (op dest left right &rest options) `(progn (setq temp (,op ,left ,(read-right-source right) ,(get-width options))) ,(do-options options left right) . ,(store-dest dest options))) (defmacro K:ALU-FIELD (op dest left right byte-spec pw &rest options) `(progn (setq temp (,op ,left ,(read-right-source right) ,byte-spec ,pw)) ,(do-options options left right) . ,(store-dest dest options))) (defmacro K:MOVE (dest source &rest options) `(K:ALU K:SETR ,dest '0 ,source . ,options)) (defmacro K:KDPB (dest left right ppss &rest options) `(progn (setq temp (dpb ,left ,ppss ,(read-right-source right))) ,(do-options options left right) . ,(store-dest dest options))) (defmacro K:KCALL (tag nargs dret &optional move &rest options) (declare (zl:arglist tag nargs dret (dest source) &rest options)) `(progn ,(if move `(K:MOVE ,(car move) ,(cadr move) . ,options) (do-options options nil nil)) (%k-call #',tag ,(cadr nargs) (locf ,(if (eq dret 'IGNORE) 'temp dret))))) (defmacro K:TAIL-CALL (tag nargs &optional move &rest options) (declare (zl:arglist tag nargs (dest source) &rest options)) `(progn ,(if move `(K:MOVE ,(car move) ,(cadr move) . ,options) (do-options options nil nil)) (%k-t-call #',tag ,(cadr nargs)))) (defmacro K:OPEN-CALL (tag nargs dret &optional move &rest options) (declare (zl:arglist tag nargs dret (dest source) &rest options)) `(K:KCALL ,tag ,nargs ,dret ,move K:CH-OPEN . ,options)) (defmacro K:OPEN-TAIL-CALL (tag nargs &optional move &rest options) (declare (zl:arglist tag nargs (dest source) &rest options)) `(K:TAIL-CALL ,tag ,nargs ,move K:CH-TAIL-OPEN . ,options)) ;;; this is not right (defmacro K:KOPEN () `(progn ,(do-stats) (%k-open))) (defmacro K:TAIL-OPEN () `(progn ,(do-stats) (%k-t-open))) (defmacro K:JUMP (tag &optional move &rest options) (declare (zl:arglist tag (dest source) &rest options)) `(progn ,(if move `(K:MOVE ,(car move) ,(cadr move) . ,options) (do-options options nil nil)) (go ,tag))) (defmacro K:TEST (cond) `(progn ,(do-stats) (,cond nil nil))) (defmacro K:BRANCH (tag &optional alu &rest options) `(progn ,(if alu `(K:ALU ,alu . ,options) (do-options options nil nil)) (if ,*condition* (go ,tag))))