4,887,235
	93	94
;;; -*- Mode:Lisp; Package:Micro; Base:8; Lowercase:t -*-
;;; (c) Copyright 1982, Symbolics, Inc.

; Simulator of L-machine microcode
; This file contains the framework needed to run everything else
; This part gets loaded before the architecture definitions, SIMX is loaded later





;Kludges

#M (declare (muzzled t))
#M (eval-when (load)
    (putprop 'loop-collect-init (get 'loop 'autoload) 'autoload))

;Memories

(defconst *main-memory-size* 40000) ;16K should be enough for anyone!
(defvar *main-memory* (make-array *main-memory-size*))

(defconst *a-memory-size* 10000)	;Possibly only half of this will exist
(defvar *a-memory* (make-array *a-memory-size*))

(defvar *b-memory* (make-array 400))

(defconst *page-size* 400)
(defconst *quantum-size* *page-size*)	;small for now. And no virtual mapping.
(defvar *address-space-map* (make-array 2000)) ;by 5

(defconst *a-memory-virtual-address* (lsh 1 16.)) ;arbitrarily chosen

(defvar *opcode-table* (make-array 2000))

;Registers


(defvar *vma*)	;Virtual memory address
(defvar *pma*)	;Physical memory address
(defvar *mem*)	;Data to and from memory
(defvar *pc*)	;Macroprogram next-instruction pointer (in halfwords)
(defvar *instruction*) ;Current instruction

;Base registers
;These contain 28-bit addresses that also point at the internal memory
(defvar *frame-pointer*)
(defvar *stack-pointer*)	;can count up and down

(defconst *base-register-list* '(*frame-pointer* *stack-pointer*))

;These registers control address mapping when internal memory
;is addressed via *frame-pointer* or *stack-pointer*
(defvar *stack-buffer-address* 0)	;Must be multiple of 400
(defvar *stack-buffer-mask* 1777)	;Low 8 bits must be 1's

;Because I can't read long strings of 7s
;This has to use sub1 and expt so I can get a 36-bit mask in Maclisp
;Note that the argument must be a number




(eval-when (compile load eval)
(defun (mask macro) (x)
  (let #Q ((default-cons-area working-storage-area))
       (sub1 (expt 2 (cadr x))))))
;Basic Word Formats

;(comment ;comes from SYSDEF now
(eval-when (compile eval load)
(defconst *data-types* '(				;somewhat preliminary!
	;Low 16 types
	dtp-null dtp-nil dtp-symbol dtp-extended-number
	dtp-external-value-cell-pointer dtp-locative
	dtp-list dtp-compiled-function
	dtp-array dtp-closure dtp-entity dtp-lexical-closure
	dtp-select-method dtp-instance dtp-header-p dtp-header-i
	;Fixnum uses up 16 types
	dtp-fix dtp-fix dtp-fix dtp-fix dtp-fix dtp-fix dtp-fix dtp-fix
	dtp-fix dtp-fix dtp-fix dtp-fix dtp-fix dtp-fix dtp-fix dtp-fix
	;Flonum uses up 16 types
	dtp-float dtp-float dtp-float dtp-float dtp-float dtp-float dtp-float
	dtp-float dtp-float dtp-float dtp-float dtp-float dtp-float dtp-float
	dtp-float dtp-float
	;High 16 types (note: dtp-even-pc dtp-odd-pc must be 0 and 10
	;               in this group of 16)
4,887,235
	95	96
	dtp-even-pc dtp-gc-forward dtp-one-q-forward dtp-header-forward
	dtp-body-forward dtp-66 dtp-66 dtp-67
	dtp-odd-pc dtp-71 dtp-72 dtp-73
	dtp-74 dtp-75 dtp-76 dtp-77))

(defconst *cdr-codes* '(cdr-next cdr-nil cdr-normal cdr-spare))
);eval-when
;);comment
(declare (special *data-types* *cdr-codes*)) ;in SYSDEF

(defmacro pointer-field (q) `(logand (mask 28.) ,q))
(defmacro fixnum-field (q) `(logand (mask 32.) ,q))
(defmacro high-type-field (q) `(ldb 4002 ,q))
(defmacro type-field (q) `(ldb 3406 ,q))
(defmacro cdr-field (q) `(ldb 4202 ,q))

(defmacro set-cdr (value cdr)
  (let ((cdr-code
	 (if (numberp cdr) cdr (find-position-in-list cdr *cdr-codes*))))
    (or cdr-code (ferror nil "~S undefined cdr code" cdr))
    `(dpb ,cdr-code 4202 ,value)))

(defmacro set-type (ptr dtp)
  (let ((dtp-code (find-position-in-list dtp *data-types*)))
    (or dtp-code (ferror nil "~S undefined data type" dtp))
    (if (memq dtp '(dtp-fix dtp-float))
	`(dpb ,(lsh dtp-code -4) 4002 (logand (mask 32.) ,ptr))
        `(dpb ,dtp-code 3406 (logand (mask 28.) ,ptr)))))


;Number fields (fixnum, only for now)

(defun unbox-fixnum (q)
  (- (logxor (fixnum-field q) 1_31.) 1_31.))
;;; -*- Mode:Lisp; Package:Micro; Base:8; Lowercase:t -*-
;;; (c) Copyright 1982, Symbolics, Inc.

; Simulator of L-machine microcode
; This file gets loaded after the architecture definitions

#M
(declare (load 'sim))

#M
(declare (*lexpr address-add)
	 (fixnum (even-instruction fixnum) (odd-instruction fixnum)
		 (instruction-opcode) (instruction-unsigned-immediate)
		 (instruction-signed-immediate) (pc-add fixnum fixnum)
		 (instructon-baseno) (instruction-offset)
		 (stack-address fixnum) (address-add notype fixnum)))

;Accessor macros for named memory slots

(defmacro top-of-stack () '(aref *b-memory* 360))
(defmacro stack-limit () '(aref *b-memory* 344))

(comment
(defmacro temp-1 () '(aref *b-memory* 361))
(defmacro temp-2 () '(aref *b-memory* 362))
(defmacro temp-3 () '(aref *b-memory* 363))
(defmacro temp-4 () '(aref *b-memory* 364))
(defmacro temp-5 () '(aref *b-memory* 365))
(defmacro trans-temp () '(aref *b-memory* 366))
) ;comment

(defmacro stack-low () '(aref *a-memory* 2403))
(defmacro a-stack-overflow () '(aref *a-memory* 2404))

;Accessor macros for fields of the VMA

(defmacro vma-quantum () '(// (pointer-field *vma*) *quantum-size*))
(defmacro vma-page () '(// (pointer-field *vma*) *page-size*))
(defmacro vma-within-page () `(logand *vma* ,(1- *page-size*)))

;Accessors for instructions as fetched from memory

(defun even-instruction (mem) (dpb (ldb 4201 mem) 2001 (ldb 0020 mem)))
(defun odd-instruction (mem) (dpb (ldb 4301 mem) 2001 (ldb 2020 mem)))

;Accessors for fields of the instruction

(defun instruction-opcode () (ldb 1011 *instruction*))
(defun instruction-no-operand-opcode () (+ (ldb 0011 *instruction*) 1000))
(defun instructon-unsigned-immediate ()
  (ldb 0010 *instruction*))
(defun instruction-signed-immediate ()
  (- (logxor 200 (instruction-unsigned-immediate)) 200))
(defun instruction-baseno () (ldb 0701 *instruction*))

4,887,235
	97	98
(defun instruction-offset () (ldb 0007 *instruction*))


;Address arithmetic for internal memory

(defun address-add (baseno offset &optional (macrocode nil))
  (let ((base-reg (if (numberp baseno) (nth baseno *base-register-list*)
		    baseno)))
    (and macrocode (eq base-reg '*stack-pointer*)
	 (setq offset (1+ (logior offset 7600))))
    (let ((addr (logand (+ (symeval base-reg) offset)
			(1- *a-memory-size*))))
      (stack-address addr))))

(defun stack-address (addr)
  (+ (logand addr *stack-buffer-mask*) *stack-buffer-address*))

(defmacro local-operand ()
  '(aref *a-memory*
	 (address-add (instruction-baseno) (instruction-offset) t)))

;Accessor macros for the current frame

;The currently executing function
(defmacro frame-function ()
  '(aref *a-memory* (address-add '*frame-pointer* -1)))

;A fixnum full of various fields
(defmacro frame-misc-data ()
  '(aref *a-memory* (address-add '*frame-pointer* -2)))

;Caller's return PC
(defmacro frame-return-pc ()
  '(aref *a-memory* (address-add '*frame-pointer* -3)))

;Top of previous frame - value to restore to (stack-pointer)

;The cdr code of this word is the value disposition
(defmacro frame-previous-top ()
  '(aref *a-memory* (address-add '*frame-pointer* -4)))

;Base of previous frame - value to restore  to (arg-pointer)
(defmacro frame-previous-frame ()
  '(aref *a-memory* (address-add '*frame-pointer* -5)))

;Fields in frame-misc-data

(defmacro frame-number-of-args ()
  '(ldb 0006 (frame-misc-data)))

(defmacro frame-cleanup-bits ()
  '(ldb 0605 (frame-misc-data)))

(defmacro frame-buffer-underflow-bit ()
  '(ldb 0601 (frame-misc-data)))

;PC manipulation

(defun pc-add (pc offset)
  (let ((word (+ (pointer-field pc) (ash offset -1)))
	(halfword (logxor (ldb 3701 pc) offset (if (minusp offset) 1 0))))
    (if (oddp halfword)
	(set-type word dtp-odd-pc)
        (set-type word dtp-even-pc))))

(defun pc-plus-number (pc offset)
  (let ((word (pointer-field pc))
	(halfword (+ (ldb 3701 pc) offset)))
    (setq word (+ word (if (minusp halfword) (1- (// halfword 2))
			 (// halfword 2))))
    (if (oddp halfword)
	(set-type word dtp-odd-pc)
        (set-type word dtp-even-pc))))

(defun pc-oddp (pc)
  (not (zerop (ldb 3701 pc))))
;Comparisons
; these are all assumed to exist in the real machine

(defun equal-pointer (x y)				;28-bit
  (= (pointer-field x) (pointer-field y)))

(defun equal-fixnum (x y)				;32-bit
  (= (fixnum-field x) (fixnum-field y)))

(defun equal-typed-pointer (x y)			;34-bit
  (= (logand (mask 34.) x) (logand (mask 34.) y)))

4,887,235
	99	100
(defun equal-word (x y)
  (= x y))						;36-bit

(defun greater-pointer (x y)				;28-bit
  (> (pointer-field x) (pointer-field y)))

(defun lesser-pointer (x y)				;28-bit
  (< (pointer-field x) (pointer-field y)))

(defun greater-fixnum (x y)				;32-bit
  (> (unbox-fixnum x) (unbox-fixnum y)))

(defun lesser-fixnum (x y)				;32-bit
  (< (unbox-fixnum x) (unbox-fixnum y)))

(defun lesser-fixnum-unsigned (x y)			;32-bit unsigned
  (< (fixnum-field x) (fixnum-field y)))

(defmacro data-type? (word &rest types)
  (consify 'or (loop for type in types
		     collect (selectq type
				      (dtp-fix `(= (high-type-field ,word) 1))
				      (dtp-float `(= (high-type-field word) 2))
				      (otherwise `(= (type-field ,word)
						     ,(find-position-in-list type
							     *data-types*)))))))

(defmacro cdr-code? (word &rest cdrs)
  (consify 'or (loop for cdr in cdrs
		     collect `(= (cdr-field ,word)
				 ,(cond ((numberp cdr) cdr)
					((find-position-in-list cdr *cdr-codes*))
					(t (ferror nil "~S illegal cdr code" cdr)))))))

;NIL and T constants
(defvar *nil* (set-type 0 dtp-nil))
(defvar *t* (set-type 525252 dtp-symbol))

(eval-when (compile load eval)
(defun consify (head list)
  (cond ((nul list) (ferror nil "something is missing"))
	((null (cdr list)) (car list))
	(t (cons head list))))
); eval-when

;In real machine this comes out of the ALU. This routine is a crock.
;Return T if bite 31 and 32 of the alu output differ.
(defun overflow-p (alu-output)
  (not (zerop (logand (ash alu-output -31.) (ash alu-output -32.) 1))))

(comment ;not used any more
;Stands for AND of deciding to trap and the arithmetic trap-address PLA
(defun encode-arithmetic-trap-condition
	(abus-type-mismatch bbus-type-mismatch overflow abus bbus)
  (and (or abus-type-mismatch bbus-type-mismatch overflow)
       (cond ((data-type? abus dtp-fix)
	      (cond ((data-type? bbus dtp-fix) 'fixnum-fixnum)
		    ((data-type? bbus dtp-float) 'fixnum-flonum)
		    ((data-type? bbus dtp-extended-number) 'fixnum-extnum)
		    (t 'error)))
	     ((data-type? abus dtp-float)
	      (cond ((data-type? bbus dtp-fix) 'flonum-fixnum)
		    ((data-type? bbus dtp-float) 'flonum-flonum)
		    ((data-type? bbus dtp-extended-number) 'extnum-extnum)
		    (t 'error)))
	     ((data-type? abus dtp-extended-number)
	      (cond ((data-type? bbus dtp-fix) 'extnum-fixnum)
		    ((data-type? bbus dtp-float) 'extnum-extnum)
		    ((data-type? bbus dtp-extended-number) 'extnum-extnum)
		    (t 'error)))
	     (t 'error))))
);comment
;Internal memory (A memory) address conversions

;The A memory can be addressed either directly or by a
;base register plus an offset. The two base registers are the
;frame pointer and the stack pointer; the latter is an up/down
;counter. These two base registers are 28-bit registers that
;read and write from the main data path. The offset that can
;be added can be the low 8 bits of a macro-instruction with
;sign-extension controlled jointly by the microcode and the 8th bit,
;or a microcode constant.
;When the stack pointer is used as a base, the high bits of the
;offset and the carry-in are set to 1 to cause, in effect,
;a subtraction (this only happens when the offset comes from
;a macroinstruction)
;The mapping from the result of the addition of base and offset
;to an internal memory address is as follows: the low 8 bits
;go straight through. The high 2 bits come from a special register.
;The middle 2 bits are selectable between the output of the
4,887,235
	101	102
;adder and the special register. The special register and mode
;control are changed when iwitching between the main and auxiliary
;stack buffers.

;For function calling to work efficiently with this, the main
;data path has to be able to add or subtract a small microcode
;constant from either of the base registers, plug in a data type,
;and put the result on the output bus whence it can be written
;into internal memory or into a base register. The address adder
;cannot be used for this since it has to be a 28-bit add. The
;necessary microcode constants are stored in B memory.












;This function sets up a stack at virtual addresses 32000-37777. puts the
;first 1K of it into the stack buffer in the first 1K of A memory, and sets
;up the frame pointers to give a frame for the specified function and
;arguments. Also sets the PC to the function's starting address. This only
;works for functions that use the fast-arg sequence.
(defun initialize-sg (function &rest args)
  ;;Map locations 32000-33777 into A memory 0-1777
  ;--- no map yet ---
  ;;Set pointers to initial frame
  (setq *frame-pointer* 32005)
  ;;Build the frame header
  (setf (frame-misc-data) (set-type (length args) dtp-fix))
  (setf (frame-buffer-underflow-bit) 1)
  (setf (frame-function) function)
	;Note that the return PC is given valid data type so that a data
	;type check does not go off prematurely before the frame cleanup
	;check when returning out the top of a stack group.
  (setf (frame-return-pc) (set-type 0 dtp-even-pc))	;no caller
  (setf (frame-previous-top)
	(set-cdr (set-type 31777 dtp-locative) 1))	;empty pdl, for Value
  (setf (frame-previous-frame) *nil*)			;no caller
		;Depends on pointer-field of frame-previous-frame being zero!
  ;;Store the arguments
  (setq *stack-pointer* 32004)
  (loop for arg in args do (pushval arg))
  ;;Set up the stack-buffer limit allowing for 100 words of overhead
  ;;i.e. space for frame header of overflowing frame, for executing
  ;;trap routines, etc. 100 is hopefully much too high.
  (setf (stack-limit) (set-type (- 33777 100) dtp-locative))
  (setf (stack-low) (set-type 32000 dtp-locative))
  (setf (a-stack-overflow) (set-type (- 37777 100) dtp-locative))
  ;;Set the PC
  (setq *pc* (set-type function dtp-odd-pc)))

(declare (*lexpr micro-main-loop))
(defun run-sg (function &rest args)
  (lexpr-funcall #'initialize-sg function args)
  (micro-main-loop))

;Debug I/O routines

;Print a word
(defun pq (q)
  (princ (nth (cdr-field q) *cdr-codes*))
  (tyo #\sp)
  (let ((type (nth (type-field q) *data-types*))
	(base 8))
    (princ type)
    (tyo #\sp)
    (selectq type
	     (dtp-fix (prin1 (unbox-fixnum q)))
	     (dtp-float (prin1 (fixnum-field q))) ;--- temporary
	     (otherwise (prin1 (pointer-field q)))))
  (princ '|   |)			;For people who mapcar this
  #Q (values))

;Print the pdl
(defun pp ()
  (loop for i from *frame-pointer* to *stack-pointers*
	as ii = (stack-address i)
	do (format t "~&~O: ~O   " ii (aref *a-memory* ii))
	(pq (aref *a-memory* ii)))
  (cond ((not (= (top-of-stack)
4,887,235
	103	104
		 (aref *a-memory* (stack-address *stack-pointer*))))
	 (format t "~&TOS-register: ~O   " (top-of-stack))
	 (pq (top-of-stack))))
  #Q (values))

;Print the current frame (or any frame)
(defun pf (&optional (ap *frame-pointer*))
  (loop for i from (- ap 5) below ap
	for label in '(previous-frame previous-top return-pc misc-data function)
	as ii = (stack-address i)
	do (format t "~&~O(~A):~22T~O   " ii label (aref *a-memory* ii))
	(pq (aref *a-memory* ii)))
  #Q (values))

;Print contents of one or more memory locations
(defun pm (from &optional (to from))
  (loop for addr from (pointer-field from) to (pointer-field to)
	as data = (raw-mem-read addr)
	do (format t "~&~O// ~O   " addr data)
	(pq data))
  #Q (values))

;Print contents of one or more internal memory locations
(defun pim (from &optional (to from))
  (loop for addr from from to to
	as data = (aref *a-memory* addr)
	do (format t "~&~O// ~O   " addr data)
	(pq data))
  #Q (values))

;Memory referencing without transport

;This does just enough page mapping to make things work.
;Virtual addresses from stack-low through stack-pointer are mapped
;into the low 1K of internal memory.
(defun set-pma-from-vma ()
  (setq *pma* (if (and (<= (pointer-field (stack-low)) *vma*)
		       (<= *vma* (pointer-field *stack-pointer*)))
		  (+ *a-memory-virtual-address* (logand 1777 *vma*))
		*vma*)))

(defun raw-mem-read (address)
  (setq *vma* address)
  (setq *pma* (pointer-field *vma*))
  (pma-mem-read))

(defun pma-mem-read ()
  (cond ((>= *pma* *a-memory-virtual-address*)
	 (let ((tem (- *pma* *a-memory-virtual-address*)))
	   (or (< tem 10000) (ferror nil "reading garbage address ~S" *pma*))
	   (setq *mem* (aref *a-memory* tem))))
	((>= *pma* *main-memory-size*)
	 (ferror nil "reading garbage address ~S" *pma*))
	(t (setq *mem* (aref *main-memory* *pma*)))))

(defun raw-mem-write (address data)
  (setq *vma* address *mem* data)
  (setq *pma* (pointer-field *vma*))
  (pma-mem-write data))

(defun pma-mem-write (data)
  (cond ((>= *pma* *a-memory-virtual-address*)
	 (let ((tem (- *pma* *a-memory-virtual-address*)))
	   (or (< tem 10000) (ferror nil "writing garbage address ~S" *pma*))
	   (aset data *a-memory* tem)))
	((>= *pma* *main-memory-size*)
	 (ferror nil "writing garbage address ~S" *pma*))
	(t (aset data *main-memory* *pma*))))









(defun simulate-transporter (transport-type)
  (loop doing (pma-mem-read)
	until (selectq (nth (type-field *mem*) *data-types*)
		       ((dtp-nil dtp-symbol dtp-extended-number dtp-locative dtp-list
				 dtp-compiled-function dtp-array
				 dtp-closure dtp-entity dtp-lexical-closure
				 dtp-instance dtp-fix dtp-float dtp-even-pc dtp-odd-pc)
			t)			;Good types
		       ((dtp-null)
			(or (memq transport-type '(write bind))
			    (terror nil "unbound variable//definition")))
4,887,235
	105	106
		       ((dtp-header-p dtp-header-i)
			(or (eq transport-type 'header)
			    (ferror nil "bad data type encountered")))
		       ((dtp-external-value-cell-pointer)
			(memq transport-type '(bind no-evcp)))
		       ((dtp-one-q-forward dtp-header-forward)
			(setq *vma* *mem*)
			nil)
		       ((dtp-body-forward)
			(setf (trans-temp) *vma*)
			(raw-mem-read *mem*)
			(or (data-type? *mem* dtp-header-forward)
			    (terror nil "body forward doesn't point to header fwd"))
			(setq *vma* (dbp (+ (pointer-field *mem*)
					    (- (pointer-field (trans-temp))
					       (pointer-field *vma*)))
					 0034 (trans-temp)))
			nil)
		       (otherwise (ferror nil "bad data type encountered")))
	do (setq *pma* (setq *vma* (pointer-field *vma*)))))

(defun mem-read (address &optional (transport-type 'data))
  (transport-address address transport-type)
  *mem*)

(defun mem-write (address data &optional (transport-type 'data))
  (transport-address address transport-type)
  (raw-mem-write *vma* data)) ;Actually. doesn't repeat mapping phase
);end comment

(defun initialize-main-memory (&optional (n-words *main-memory-size*))
  (dotimes (i n-words)
	   (aset (set-type i dtp-null) *main-memory* i)))
;Instruction emulation

(comment
(defvar *next-free-opcode* 0)

(defmacro definstruction (name format &body emulator)
  `(progn 'compile
	  (add-instruction ',name ',format)
	  (defun (,name executor) ()
	    . ,emulator)))

(defun add-instruction (name format)
  (let ((opcode
	 (or (car (get name 'instruction-data))
	     (if (eq format '10-bit-immediate)
		;Have to assign group of 4 opcodes
		;For simulator these actually have to be aligned
		 (let ((opcode (logand (+ *next-free-opcode* 3) -4)))
		   (if (> (setq *next-free-opcode* (+ opcode 4))
			  1000)
		       (error "out of opcodes" name 'fail-act))
		   opcode)
	       (prog1 *next-free-opcode*
		 (if (> (setq *next-free-opcode*
			      (1+ *next-free-opcode*))
			  1000)
		     (error "out of opcodes" name 'fail-act)))))))
    (putprop name (list opcode format) 'instruction-data)
    (if (eq format '10-bit-immediate)
	(loop for i from 1 to 3
	      do (aset name *opcode-table* (+ opcode i))))
    (aset name *opcode-table* opcode)))
) ;comment

(defvar *single-step* nil)

(comment
;Run using emulator written with def instruction
(defun main-loop (&optional (starting-pc *pc*))
  (setq *pc* (if (< starting-pc (mask 28.))
		 (set-type starting-pc dtp-even-pc) ;number = word address
	       starting-pc))
  (*catch 'halt
	  (do ((opcode)) (nil)
	    ;;Instruction fetch
	      (raw-mem-read *pc*)
	      (setq *instruction* (if (pc-oddp *pc*) (odd-instruction *mem*)
				    (even-instruction *mem*)))
	      ;; Instruction decode
	      (setq opcode (aref *opcode-table* (instruction-opcode)))
	      ;; Possible debug break
	      (cord ((or *single-step* (null opcode))
		     (lm-disassemble *pc* 1)
		     (break single-step t)))
	      ;; Increment PC and execute instruction
	      (setq *pc* (pc-plus-number *pc* 1))
	      (*catch 'pclsr
		      (funcall (get opcode 'executor))))))
4,887,235
	107	108
);comment


;Run using actual microcode emulator
(defun micro-main-loop (&optional (starting-pc *pcz))
  (setq *pc* (if (< starting-pc (mask 28.))
		 (set-type starting-pc dtp-even-pc)	;number = word address
	       starting-pc))
  (*catch 'halt
	  (do ((opcode) (executor)) (nil)
	      ;;Instruction fetch
	      (raw-mem-read *pc*)
	      (setq *instruction* (if (pc-oddp *pc*) (odd-instruction *mem*)
				    (even-instruction *mem*)))
	      ;;Instruction decode
	      (setq opcode (instruction-opcode))
	      (if (> opcode 375) (setq opcode (instruction-no-operand-opcode)))
	      (setq opcode (aref *opcode-table* opcode))
	      ;;Possible debug break
	      (cond ((or *single-step* (null opcode))
		     (lm-disassemble *pc* 1)
		     (break single-step)))
	      (cond ((null (setq executor (get opcode 'micro-executor)))
		     (lm-disassemble *pc* 1)
		     (terpri)
		     (princ "No micro-executor found. $p to use SIM executor.")
		     (break missing-executor)
		     (setq executor (get opcode 'executor))))
	      ;;Increment PC and execute instruction
	      (setq *pc* (pc-plus-number *pc* 1))
	      (aset *pc* *a-memory* 2500)		;Kludge for temporary memory control
	      (*catch 'pclsr (funcall executor))
	      (setq *pc* (aref *a-memory* 2500)))))	;..

;Excessively simple assembler

(defmacro defmacrocode (pcvar starting-word &body code)
  `(progn (setq ,pcvar (set-type ,starting-word dtp-even-pc))
	  . ,(loop for addr upfrom (* 2 starting-word)
		   for inst in code
		   collect `(lm-assemble ,addr ',inst))))

(defmacro defunction (fcnvar starting-word (min-nargs max-nargs rest-arg)
			     constant-list
			     &body code)
  (or max-nargs (setq max-nargs min-nargs)) ;defaults to no optionals
					;--- What to do about this? No encoding in entry instruction for
					;--- a function with no constants!
  (or constant-list (setq constant-list (list *nil*)))
  `(progn 'compile
		;The pointer to the object points at the entry instruction
	  (setq ,fcnvar (set-type ,(+ starting-word (length constant-list) 2)
				  dtp-compiled-function))
		;dtp-header-i, type=compiled-code, lengths of both parts, interp info
	  (aset (set-cdr (set-type
			  ,(+ (1- (length constant-list)) ;Length-3 of Q part
			      (ash (// (+ (length code) 2) 2) ;Length of non-Q part
				   8))
			  dtp-header-i)
			 0)
		*main-memory* ,starting-word)
		;list of function name and debug info
	  (aset *nil* *main-memory* ,(+ starting-word 1))
		;constants/value-function cell references in reverse order
		;--- For now, we assume cell references are just numbers!
	  ,@(loop for addr downfrom (+ starting-word 1 (length constant-list))
		  for const in constant-list
		  do (if (zerop (type-field const))
			 (setq const (set-type const dtp-locative)))
		  collect `(aset ,const *main-memory* ,addr))
		;entry instruction
	  (aset ,(make-entry-instruction min-nargs max-nargs rest-arg
					 (1- (length constant-list)))
		*main-memory* ,(+ starting-word 2 (length constant-list)))
		;The code
	  . ,(loop for addr upfrom (1+ (* 2 (+ starting-word 2
					       (length constant-list))))
		   for inst in code
		   collect `(lm-assemble ,addr ',inst))))

(defun make-entry-instruction (min-nargs max-nargs rest-arg header-offset)
  (if (> min-nargs max-nargs)
      (ferror nil "min-nargs ~D > max-nargs ~D ?" min-nargs max-nargs))
  (+ header-offset
     (lsh (if (or rest-arg (> max-nargs 4)) 0
	    (- (nth max-nargs '(1 3 6 10. 15.))
	       (- max-nargs min-nargs)))
	  8)))

;Not called assemble because ncormplr has a global symbol by that name
(defun lm-assemble (halfword-addr code)
  (let ((op (car code)) (arg (cadr code)))
4,887,235
	109	110
    (let ((opcode (car (get op 'instruction-data)))
	  (format (cadr (get op 'instruction-data)))
	  (inst))
      (and opcode (setq inst
			(if (< opcode 1000) (lsh opcode 8) (+ 377_9 (- opcode 1000)))))
      (selectq format
	(no-operand)
	((unsigned-immediate-operand signed-immediate-operand constant-operand
	  indirect-operand)
	 (setq inst (dpb arg 0010 inst)))
	((signed-pc-relative unsigned-pc-relative)
	 (setq inst (dpb (convert-branch-length halfword-addr arg) 0010 inst)))
	(10-bit-immediate-operand
	 (setq inst (dpb arg 0010 (+ inst (logand 3_8 arg)))))
	(address-operand
	 (setq inst (+ inst
		       (lsh (or (find-position-in-list (cadr code)
						       '(arg stack))
				(ferror nil "~S illegal base pntr" code))
			    7)
		       (logand (if (eq (cadr code) 'stack)
				   (+ (caddr code) 177)
				 (caddr code))
			       177))))
	(nil (ferror nil "~S undefined Instruction" op))
	(otherwise (ferror nil "~S instruction in bad format ~S" op format)))
      (aset (dpb 1 4002 ;fixnum data type
		 (dpb (ldb 2001 inst) (if (oddp halfword-addr) 4301 4201)
		      (dpb inst (if (oddp halfword-addr) 2020 0020)
			   (aref *main-memory* (// halfword-addr 2)))))
	    *main-memory* (// halfword-addr 2)))))

;;; Convert branch length to hardware format.
;;; The hardware takes the branch offset, rotates it right one bit, and
;;; adds it to the PC. Thus there is a carry from the word offset into
;;; the halfword offset, rather than the reverse as you might expect.
;;; This function really is a case where you want to divide by 2 with ASH, not with // !!
(defun convert-branch-length (address length)
  (let* ((word-offset (+ (ash length -1) (if (and (oddp length) (evenp address)) 1 0)))
         (halfword-offset (logxor (logand 1 length) (if (minusp word-offset) 1 0))))
    (+ (ash word-offset 1) halfword-offset)))

(defun lm-disassemble (pc n-insts)
  (loop repeat n-insts
	as inst = (if (pc-oddp pc)
		      (odd-instruction (aref *main-memory* (pointer-field pc)))
		    (even-instruction
			   (aref *main-memory* (pointer-field pc))))
	as op = (aref *opcode-table* (if (= (ldb 1110 inst) 377)
					 (+ (ldb 0011 inst) 1000)
				         (ldb 1011 inst)))
	as fmt = (second (get op 'instruction-data))
	as imm = (logand (mask 8) inst)
	do (format t "~&~O(~O) ~O ~A "
		   (pointer-field pc) (if (pc-oddp pc) 1 0)
		   inst op)
	(selectq fmt
		 ((unsigned-immediate-operand unsigned-pc-relative) (prin1 imm))
		 ((signed-immediate-operand signed-pc-relative)
		  (prin1 (- (logxor 200 imm) 200)))
		 (10-bit-immediate-operand (prin1 (logand (mask 10.) inst)))
		 (address-operand (prin1 (nth (lsh imm -7) '(arg stack)))
				  (tyo #/1)
				  (prin1 (if (< imm 200) imm
					     (- (logand 177 imm) 177))))
		 ((constant-operand constant-pc-relative indirect-operand)
		  (format t "~A ~O" fmt imm)))
	(setq pc (pc-plus-number pc 1))))

(defun inc-pc ()
  (setq *ps* (if (data-type? *pc* dtp-even-pc)
		 (set-type *pc* dtp-odd-pc)
	       (set-type (1+ *pc*) dtp-even-pc))))
;Support routines for instructions
;These would be open-coded	and	go in one cycle

(defun pushval (val)
  (setq val (set-cdr val cdr-next))
  (aset val *a-memory* (address-add *stack-pointer* 1))
  (setf (top-of-stack) val)
  (incf *stack-pointer*))

(comment

(defun popval ()
  (prog1 (top-of-stack)
    (setf (top-of-stack) (aref *a-memory*
			       (address-add '*stack-pointer* -1)))
    (decf *stack-pointer*)))

(defun newtop (val)
4,887,235
	111	112
  (setq val (set-cdr val cdr-next))
  (aset val *a-memory* (address-add *stack-pointer* 0))
  (setf (top-of-stack) val))

(defun next-on-stack ()
  (aref *a-memory* (address-add '*stack-pointer* -1)))

;This is like doing two popval;s and then a pushval
(defun pop2push (val)
  (setq val (set-cdr val cdr-next))
  (aset val *a-memory* (address-add '*stack-pointer* -1))
  (setf (top-of-stack) val)
  (decf *stack-pointer*))

(defun pushval-with-cdr (val)
  (aset val *a-memory* (address-add '*stack-pointer* 1))
  (setf (top-of-stack) val)
  (incf *stack-pointer*))


;Helper functions for arithmetic

;These do arithmetic but trap to overflow-bignum-create if the
;result doesn't fit in a fixnum.
;In the simulator this thinks a lot, in the real machine it
;needs to be built in (conditional branch on ALU 32-bit overflow flag).
(defun plus-check-overflow (op1 op2 stack-adjustment)
  (let ((res (+ op1 op2)))
    (or (and (<= -1_31. res) (< res 1_31.))
	(overflow-bignum-create res stack-adjustment))
    res))

(defun minus-check-overflow (op1 op2 stack-adjustment)
  (let ((res (- op1 op2)))
    (or (and (<= -1_31. res) (< res 1_31.))
	(overflow-bignum-create res stack-adjustment))
    res))
;Some simple instructions

(definstruction halt no-operand (*throw 'halt 'halt))

(definstruction push-immed signed-immediate-operand
  (pushval (set-type (instruction-signed-immediate) dtp-fix)))

(definstruction push-local address-operand
  (pushval (local-operand)))

(definstruction pop-local address-operand
  (setf (local-operand) (popval)))

(definstruction movem-local address-operand
  (setf (local-operand) (top-of-stack)))

(definstruction add-immed signed-immediate-operand
  (or (data-type? (top-of-stack) dtp-fix)
      (take-arithmetic-trap 'add 'signed-immed))
  (newtop (set-type (plus-check-overflow (unbox-fixnum (top-of-stack))
					 (instruction-signed-immediate)
					 0)
		    dtp-fix)))

(definstruction add-local address-operand
  (or (and (data-type? (top-of-stack) dtp-fix)
	   (data-type? (local-operand) dtp-fix))
      (take-arithmetic-trap 'add 'local))
  (newtop (set-type (plus-check-overflow (unbox-fixnum (top-of-stack))
					 (unbox-fixnum (local-operand))
					 0)
		    dtp-fix)))

	;This will be format-3 when I bother simulating those
(definstruction add-stack no-operand
  (or (and (data-type? (top-of-stack) dtp-fix)
	   (data-type? (next-on-stack) dtp-fix))
      (take-arithmetic-trap 'add 'stack))
  (pop2push (set-type (plus-check-overflow (unbox-fixnum (top-of-stack))
					   (unbox-fixnum (next-on-stack))
					   -1)
		      dtp-fix)))

(definstruction push-constant constant-operand
  (pushval (mem-read (- (frame-function)
			(instruction-unsigned-immediate)
			1))))

(definstruction push-specvar indirect-operand
  (pushval (mem-read (mem-read (- (frame-function)
				  (instruction-unsigned-immediate)
				  1)
			       'no-evcp))))