4,887,235
	233	234
;Multiplier input registers here named after the busses they are
;on, rather than the TRW names which are reversed.
;Loading the multiplier is not done with ASSIGN, mainly because
;of the weirdnecs that it loads frcm the -high- half of Ybus.

;Writing into the X register. signed or unsigned
(defmicro write-mpy-x (x-source &optional signed)
  (paralyze (get-to-xbus x-source)
	    `(microinstruction spec multiply
			       magic ,(if signed 6 2))))

;Writing into the Y register, signed or unsigned
(defmicro write-mpy-y-from-high (y-source &optional signed)
  (paralyze (get-to-ybus y-source)
	    `(microinstruction spec multiply
			       magic ,(if signed 11 1))))
;;; Main memory

(defatomicro memory-data
  (microdata abus (microinstruction abus memory-data amem-read-addr (bus-address))))

;The virtual-address register
(defatomicro vma
  (vma-kludge))

;For temporary memory control, cannot read back hardware VMA, so keep copy in A-memory
(defareg-at-loc a-vma-copy 2501)	;Location kludgily known about...

(defmicro vma-kludge ()
(if (eq *machine-version* 'proto)
    'a-vma-copy
    '(microdata abus (microinstruction abus vma))))

;Also there is hair in ASSIGN

;Start a memory cycle
;Do this the cycle after loading vma
;The modes argument says what kind of cycle. It is not used on the proto machine;
;the kind of cycle is determined by what you do in parallel with this.
;See the microcompiler documentation for the modes.
(defmicro start-memory (&rest modes)
  (selectq *machine-version*
    ((sim proto) '(microinstruction trap-enables (map-miss) mem start-cycle))
    ((tmc tmc5)
     (let ((direction nil)
	   (physical-address nil)
	   (spec nil)
	   (dma-device nil)
	   (block nil)
	   (ifetch nil)
	   (inst nil))
       (loop until (null modes)
	     as mode = (pop modes)
	     do (selectp code
		  ((read write)
		   (if (null direction)
		       (setq direction mode)
		       (if spec (retch "Conflicting spec funcs: ~S and ~S"
				       spec 'check-write-access))
		       (setq direction 'read spec 'check-write-access)))
		  (physical
		   (if (null modes) (retch "No physical address specified"))
		   (setq physical-address (pop modes)))
		  (dma
		   (if (null (cdr modes)) (retch "No DMA card//subdevice specified"))
		   (if spec (retch "'Conflicting spec funcs: ~S and ~S" spec mode))
		   (setq dma-device (list (pop modes) (pop modes))
			 spec 'dma))
		  ((inhibit-page-tags address-phtc)
		   (if spec (retch Conflicting spec funcs: ~S and ~S spec mode))
		   (setq spec mode))
		  (block
		   (setp block t))
		  (instruction-fetch
		   (setq ifetch t))
		  (otherwise (retch "~S unrecognized START-MEMORY code" mode))))
       (or direction (retch "Neither READ nor WRITE specified in START-MEMORY"))
       (cond ((not physical-address))
	     ((null spec) (setq spec 'addr-from-abus))
	     ((not (memq spec '(dma inhibit-page-tags)))
	      (retch "Conflicting spec funcs: ~S and ~5" spec 'addr-from-abus)))
       (and block spec
	    (retch "Combination of block mode and special memory features is illegal"))
       (setq inst (list 'mem (if (not block)
				 (if (eq direction 'read) 'start-read 'start-write)
			         (if (eq direction 'read) 'block-read 'block-write))))
       (cond (ifetch
	      (if spec (retch "Conflicting spec funcs: ~S and ~S" spec 'ifu-control))
	      (setq inst
4,887,235
	235	236
	(if (eq *machine-version* 'tmc)
	    (list* 'spec 'ifu-control 'magic 0 'magic-mask 1 inst)
	    (list* 'spec 'ifu-control 'magic 2 'magic-mask 3 inst))))
	     (spec
	      (setq inst (lists 'spec spec inst))))
       (setq inst (cons 'microinstruction inst))
       (if dma-device
	   (setq inst `(parallel (select-lbus-dev ,(car dma-device) ,(cadr dma-device))
				 ,inst)))
       (if physical-address
	   ;; Need extra time when taKing addr from amem, and cannot use addr-calc
	   ;; hardware, in order to get enough address-to-clock setup time
	   (let ((addr (get-to-abus physical-address)))
	     (or (atom (get addr 'amem-read-addr))
		 (eq (car (get addr 'amem-read-addr)) 'constant)
		 (retch "~S is too slow as a source of physical address"
			physical-address))
	     (setq inst `(parallel ,addr
				   ,inst
				   (microinstruction speed slow-first-half))))
	 ;; Need extra time when using the map cache because it isn't fast enough
	 (setq inst `(parallel ,inst
			       (microinstruction speed slow-first-half))))
       inst))
    (otherwise (retch "Don't know how to do START-MEMORY on this machine."))))


(defmicro nop ()
  (microinctruction))

;Use this at a subroutine which is jumped to with the memory going,
;to defeat bogus error messages when you know what uou're doing.
;Note: this doesn't distinnuish between IO and emulator tasks.
(defmicro declare-memory-timing (&rest states)
  (dolist (state states)
    (or (memq (if (and (listp state) (eq (car state) 'next) (= (length state) 2))
		  (cadr state) state)
	      '(active-cycle data-cycle))
	(retch "~S illegal memory timing state: use ACTIVE-CYCLE or DATA-CYCLE" state)))
  `(microinstruction declare-memory-timing ,states))

(defmicro declare-speed (speed)
  (or (memq speed '(slow slow-first-half slow-second-half very-slow))
      (retch "~S not a legal speed name" speed))
  `(microinstruction speed ,speed))

;Allowed transport types are:
;  DATA		all invisibles, error if null or header
;  WRITE	all invisibles, no transport, error if header
;  CDR		only header/body forward invisible, no transport, error if header
;  BIND		evcp not invisible, error if header
;  BIND-WRITE	evcp not invisible, no transport, error if header
;  HEADER	header-forward invisible, transport, other tuoes error
;  HEADER-OR-DATA same as HEADER but no error if non-header type
;		does not actually transport any normal-data word it sees
;  NO-TRAP 	? - the A machine uses this in one place, I don't think we need it
;  SCAV		no invisible pointers, no errors. transport
;
;For transport, the type map is:
;  Regular pointer => COND		(enables oldspace check)
;  Invisible-pointer => COND, TRAP-2	(oldspace overrides invisible)
;  Bad type => TRAP-0			(e.g. unbound-variable error)

(defmicro transport (&optional (transport-type 'data))
  (or (memq transport-type '(data write cdr bind bind-write header header-or-data scav))
      (retch "~S illegal transport-type" transport-type))
  (paralyze (get-to-abus 'memory-data)
	    `(microinstruction type-map ,(type-map-for-transport transport-type)
			       trap-enables (transport)
			       error-table (bad-data-type))))

(defconst transporter-type-map-alist nil)

;Note that this function has to be modified if *data-types* is changed!
;--- dtp-monitor-forward not put in yet
(defun type-map-for-transport (transport-type
		#Q &aux #Q (default-cons-area working-storage-area)) ;Sigh....
  (or (cdr (assq transport-type transporter-type-map-alist))
      (let ((invisible-pointer-types
	     (selectq transport-type
	       ((data write) '(dtp-external-value-cell-pointer dtp-one-q-forward
			       dtp-header-forward dtp-body-forward))
	       ((bind bind-write) '(dtp-one-q-forward dtp-header-forward dtp-body-forward))
	       ((cdr) '(dtp-header-forward dtp-body-forward))
	       ((header header-or-data) '(dtp-header-forward))
	       ((scav) nil)))
	    (error-types
	     (selectq transport-type
	       ((data) '(dtp-null dtp-11 dtp-13 dtp-14 dtp-15 dtp-16 dtp-1
			 dtp-header-p dtp-header-i dtp-monitor-forward
			 dtp-72 dtp-73 dtp-74 dtp-75 dtp-76 dtp-77))
4,887,235
	237	238
	       ((cdr) '(dtp-11 dtp-13 dtp-14 dtp-15 dtp-16 dtp-17
			dtp-header-p dtp-header-i dtp-monitor-forward
			dtp-72 dtp-73 dtp-74 dtp-75 dtp-76 dtp-77))
	       ((write bind bind-write)
		'(dtp-header-p dtp-header-i dtp-11 dtp-13 dtp-14 dtp-1S dtp-16 dtp-17
		  dtp-monitor-forward dtp-72 dtp-73 dtp-74 dtp-75 dtp-75 dtp-77))
	       ((header) (types-other-than '(dtp-header-forward dtp-header-p dtp-header-i)))
	       ((header-or-data scav) '(dtp-11 dtp-13 dtp-14 dtp-15 dtp-16 dtp-17
					dtp-72 dtp-73 dtp-74 dtp-75 dtp-76 dtp-77))))
	    (regular-pointer-types
	     (selectq transport-type
	       ((write bind-write cdr header header-or-data) nil)
	       ((data) '(dtp-nil dtp-symbol dtp-extended-number dtp-locative
			 dtp-list dtp-compiled-function dtp-array dtp-closure
			 dtp-instance dtp-even-pc dtp-odd-pc))
	       ((bind) '(dtp-null dtp-nil dtp-symbol dtp-extended-number dtp-locative
			 dtp-external-value-cell-pointer
			 dtp-list dtp-compiled-function dtp-array dtp-closure
			 dtp-instance dtp-even-pc dtp-odd-pc))
	       ((scav) '(dtp-null dtp-nil dtp-symbol dtp-extended-number dtp-locative
			 dtp-external-value-cell-pointer dtp-one-q-forward dtp-header-forward
			 dtp-list dtp-compiled-function dtp-array dtp-closure
			 dtp-instance dtp-header-p
			 dtp-even-pc dtp-odd-pc)))))
	(iet ((map (nconc (and invisible-pointer-types
			       `((,invisible-pointer-types pointer trap-2)))
			  (and regular-pointer-types
			       `((,regular-pointer-types pointer)))
			  (and error-types
			       `((,error-types trap-0))))))
	     (push (cons transport-type map) transporter-type-map-alist)
	     map))))


F:>lmach>ucode>uu.lisp.429


;;; Jumping all over the place

;Note that the condition field is also relevant to next-microinstruction
;selection. The skip-true-sequence and skir-false-sequence fields get boiled
;down to the next-microaddress field, with placing of microinstructions at
;suitable addresses and duplication of microinstructions in some cases.

;Note that IF and DISPATCH may be used at the same time, and in this case the
;IF's skip modifies the NPC rather than the next-microaddress field. The
;microassembler has to be aware of this and put instructions in the appropriate
;places.

(defmicro call (ucode)
  `(microinstruction sequencer pushj jump-sequence ,ucode))

(defmicro jump (ucode)
  `(microinstruction next-sequence ,ucode))

(defmicro return ()
  `(microinstruction sequencer popj))

(defmicro return-skip (pred)
  (let* ((test (microexpand pred))
	 (skip (cond ((neq (car test) 'microcondition)
		      (retch "~S expanded into ~S, not a valid microcondition"
			     pred test))
		     ((memq (cadr test) valid-skip-conditions) (cadr test))
		     (t (retch "~S invalid skip condition in ~S"
			       (cadr test) pred)))))
    (or (eq (caddr test) 'true)
	(retch "~S is a reversed-sense skip condition, illegal in RETURN-SKIP" pred))
    (paralyze (cadddr test)
	      `(microinstruction condition ,skip sequencer popj return-skip t))))

;This makes the return address of a call be the pending dispatch.
;This is just for the simulator. The rec~ hardware can't avoid doing this.
(defmicro call-and-dispatch-upon-return (ucode)
  `(microinstruction sequencer pushj-return-dispatch jump-sequence ,ucode))

(defmicro call-and-return-to (ucode return-to)
  `(microinstruction sequencer pushj jump-sequence ,ucode next-sequence ,return-to))

(defmicro call-and-return-skip (ucode normal-return skip-return)
  `(microinstruction sequencer pushj jump-sequence ,ucode
		     return-true-sequence ,skip-return return-false-sequence ,normal-return))

;Call in combination with a skip
(defmicro call-select (condition true-subroutine false-subroutine)
  `(parallel (microinstruction sequencer pushj)
	     (if ,condition
		 ,(if (atom true-subroutine) `(goto ,true-subroutine) true-subroutine)
	         ,(if (atom false-subroutine) `(goto ,false-subroutine) false-subroutine))))
4,887,235
	239	240
;Combination of that and call-and-return-to
(defmicro call-select-and-return-to (condition true-subroutine false-subroutine return-to)
  `(parallel (microinstruction sequencer pushj next-sequence ,return-to)
	     (if ,condition
		 ,(if (atom true-subroutine) `(goto ,true-subroutine) true-subroutine)
	         ,(if (atom false-subroutine) `(goto ,false-subroutine) false-subroutine))))

;Really ifu & no popj. Hardware makes the distinction when stack is empty.
(defmicro next-instruction ()
  '(microinstruction sequencer next-instruction))

(defmicro increment-pc ()
  (selectq *machine-version*
    ((tmc) '(microinstruction spec ifu-control magic 1 magic-mask 1))
    ((tmc5) '(microinstruction spec ifu-control magic 3 magic-mask 3))
    (otherwise (retch "I don't know how to do this except on TMC machine"))))

;:; Temporary until real IFU
;;; Takes 2 cycles and can't be done in parallel with other things
;:; Use a subroutine to save microcode space
(defmicro increment-fake-pc ()
  '(call-select (odd-pc? pc)
		(parallel (assign pc (set-type (1+ po) dtp-even-pc))
			  (return))
		(parallel (assign pc (set-type pc dtp-odd-pc))
			  (return))))

;;; Add an offset to the PC. using the special format of offset used in branch instructions
(defmicro pc-add (base-pc magic-offset)
  `(parallel (+ ,base-pc (rotate ,magic-offset 37))
	     (microinstruction force-obus<33-32> 3))) ;dtp-even-pc/dtp-odd-pc

;;; Add an offset to the PC, using an ordinary number as the offset
;;; offset can be one argument, or two arguments (the second being 1)
;;; Uses b-temp-3 (but either argument being b-temp-3 is okay)
(defmicro pc-plus-number (base-pc &rest offset)
  `(sequential (assign b-temp-3 (+ (halfword-pc ,base-pc) . ,offset))
	       (word-pc b-temp-3)))


;This micro assigns to the PC and does whatever else is necessary to make the
;IFU happy, For now, just next-instruction. For the TMC IFU, will start a
;2-word read and wait for the appropriate length of time, then NEXT-INSTRUCTIDN,
;Other code to be done in parallel with the memory access may be supplied.
(defmicro set-pc (new-pc &optional other-code)
  (selectq *machine-version*
    ((sim proto)
     (if other-code
	 `(sequential (assign pc ,new-pc)
		      (parallel ,other-code
				(next-instruction)))
         `(parallel (assign pc ,new-pc)
		    (next-instruction))))
    ((tmc)
     (if (null other-code)	;This instruction is completed, PC may advance
	 `(parallel
	   (assign pc ,new-pc)
	   (clear-stack-adjustment)
	   (jump ifu-empty-trap-1))
         `(sequential
	   (assign vma ,new-pc)		;Check for page fault first because the TMC
	   (start-memory read)		;does not have a senarate EPC
	   (assign pc ,new-pc)		;Now set PC (and VMA again) for real
	   (parallel ,other-code
		     (start-memory read block instruction-fetch))
	   (start-memory read block instruction-fetch) ;Active(1)
	   (nop)				;Data(1) Active(2)
	   (next-instruction))))		;Decode(l),Data(2)
    ((tmc5)
     `(sequential
       (assign pc ,new-pc)			;Assign to DPC and VMA (leave EPC alone)
       (parallel ,other-code
		 (start-memory read block instruction-fetch))
       (start-memory read block instruction-fetch)	;Active(1)
       (nop)					;Data(1),Active(2)
       (next-instruction)))			;Decode(1),Data(2)
    (otherwise (retch "~S machine version not handled yet" *machine-version*))))

;Set the PC at which execution will restart if this instruction is pclsred
;No instruction fetch is done since that PC will normally not be used
;The PC must be at an even halfword (usually it is an escape function)
;ACCEPT-RESTART-PC must be done in the next cycle (or some later cycle before it's needed)
(defmicro restart-pc (new-pc)
  (selectq *machine-version*
    ((sim proto tmc)			;PC will get backed up if pclsr, so advance it
     `(assign pc (odd-pc ,new-pc)))
    ((tmc5 ifu)
     `(assign pc (even-pc-except-30-through-28 ,new-pc)))
    (otherwise (retch "~S machine version not handled yet" *machine-version*))))
4,887,235
	241	242
;Accept the restart PC into the EPC from the DPC/IPC, and increment the DPC/IPC past it.
(defmicro accept-restart-pc ()
  (selectq *machine-version*
    ((sim proto tmc) nil)
    ((tmc5 ifu) '(increment-pc))
    (otherwise (retch "~S machine version not handled yet" *machine-version*))))

(defmicro lisp (form)
  `(microinstruction escape-to-lisp ,form))

(defmicro signal-error (&rest code)
  `(error-if true . ,code))

;(trap-if <cond> (signal-error <err>)) but saves an instruction
(defmicro error-if (condition &rest error-code)
  `(parallel (trap-if ,condition (goto error-trap))
	     (microinstruction error-table ,(copylist error-code))))

(defmicro signal-error-no-restore-stack (&rest code)
  `(error-no-restore-stack-if true . ,code))

(defmicro error-no-restore-stack-if (condition &rest error-code)
  `(parallel (trap-if ,condition (goto error-trap-no-restore-stack))
	     (microinstruction error-table ,(copylist error-code))))

;'field' somehow selects a field
;It can either be a microdata on the alub, using normal field selection, or
;it can be a microdata on the alub which selects one of several special abus
;fields, or it can me one of the following special forms:
;	(cdr-code <a-opnd>)
;	..more in the future?..
;The value of the dispatch field in tho resulting code is the symbol alub or
; one of several special symbols for the special dispatches.
;'clauses' are something like selectq clauses, car of each one is a
;  list of symbolic or numeric values, cdr of each one is a microcode
;  sequence or a defucode tag, as with IF.
(defmicro dispatch-after-next (field &rest clauses)
  (multiple-value-bind (ufield magic code symbolic-cues-alist)
		       (expand-dispatch-field field)
    `(parallel
      ,code
      (microinstruction
       dispatch ,ufield
       magic ,magic magic-mask 7
       dispatch-table (,ufield .
			       ,(expand-dispatch-clauses clauses symbolic-cues-alist))))))

(defmicro dispatch-after-this (operand this &body clauses)
  `(sequential
    (dispatch-after-next ,operand
			 ,@clauses)
    (parallel
     ,this
     (take-dispatch))))

(defun expand-dispatch-field (field &aux efield code tem table alist)
  ;returns dispatch field, magic number field, other microcode, symbolic-cues-alist
  (setq alist (get (or (get (if (symbolp field) field (car field)) 'enumerated-type-name)
		       (and (listp field) (eq (car field) 'ldp-field)
			    (get (caddr field) 'enumerated-type-name)))
		   'enumerated-type-codes))
  (setq efield (microexpand field))
  (setq table '((3404 .	abus<31-28>)	;2 array registers
		(2604 . abus<25-22>)	;3 array-dispatch
		(2204 . abus<21-18>)	;4 array-type
		(0003 .	abus<2-0>)))	;5 function calling
  (cond ((atom efield) (retch "Garbage dispatch field: ~S == ~S" field efield))
	;;Special forms
	((eq (car efield) 'cdr-code)
	 (values 'cdr-code 1 (net-to-abus (cadr efield)) alist))
	((not (and (eq (car efield) 'microdata) (eq (cadr efield) 'alub)))
	 (retch "Garbage dispatch field: ~S == ~S" field efield))
	;;Special abus fields
	((and (fieldp (setq code (caddr efield)) 'ybus 'abus)
	      (setq tem (assoc (dpb (- 40 (second (get code 'byte-func)))
				    0605
				    (third (get code 'byte-func)))
			       table)))
	 (values (cdr tem)
		 (+ (find-position-in-list tem table) 2)
		 (modify-code code '((ybus nil) (byte-func nil)))
		 alist))
	;;Normal field extraction through alub
	(t (values 'alub 0 code alist))))

(associate-dispatch-cues cdr-code *cdr-codes*)

;Car of clause is list of selectors
;Cdr of clause is body of a sequence, or goto special form like if
(defun expand-dispatch-clauses (clauses symbolic-cues-alist)
  (mapcar #'(lambda (clause)
4,887,235
	243	244
	      (list (expand-dispatch-cues (car clause) symbolic-cues-alist)
		    (cond ((and (= (length clause) 2)
				(not (atom (cadr clause)))
				(eq (caadr clause) 'goto))
			   (cadadr clause))
			  (t (microexpand `(sequential . ,(cdr clause)))))))
	  clauses))

(defun expand-dispatch-cues (cues symbolic-cues-alist)
  (if (eq cues 'otherwise) cues
    (loop for cue in cues
	  collect (cond ((numberp cue) cue)
			((cdr (assq cue symbolic-cues-alist)))
			(t (retch "~S unrecognized dispatch cue" cue))))))

;Dispatch only takes effect if this is executed in the following cycle.
(defmicro take-dispatch ()
  '(microinstruction sequencer take-dispatch)) ;i.e. CPC from NPC

;;; Definition of closed microroutines

(defprop defucode "Microcode routine" si:definition-type-name)
(defprop defucode-at-loc defucode zwei:definition-function-spec-type)
(defprop definst defucode zwei:definition-function-spec-type)
(defprop definst1 defucode zwei:definition-function-spec-type)

(declare (*expr microcode-to-lisp-function	;Suppress compiler warning
		check-microcode))

;;; defucode defines a microroutine which can either be jumped to,
;;; called, or trapped to. 'name' is aiwaus a symbol.
;;; The body has an implicit 'sequential'.
(defmacro defucode (name &body body)
  (defucode-1 'defucode name body))

;;; loc is a number which is either a single location or a list of
;;; locations; the first microinstruction will be replicated through
;;; those locations.
(defmacro defucode-at-loc (name loc &body body)
  (defucode-1 'defucode-at-loc name body loc))

;;; definst defines the microcode to execute a particular macroinstruction
;;; It is very much like defucode but stores the microcode in a different table
;;; Put in the (next-instruction) yourself if you need it, or use definst1
(defmacro definst (name format-and-attributes &body body)
  (validate-definst name format-and-attributes)
  (defucode-1 'definst name body (if (atom format-and-attributes) format-and-attributes
				     (car format-and-attributes))))

;;; Like definst but defines a 1-cycle instruction. All clauses of the body
;;; are done in parallel, and the (next-instruction) is put in automatically.
(defmacro definst1 (name format-and-attributes &body body)
  `(definst ,name ,format-and-attributes
     (parallel ,@body
	       (next-instruction))))

(defun defucode-1 (flavor name body &optional data)
  (let* ((*backtrace* `((,flavor ,name)))
	 (microcode (microexpand `(sequential . ,body))))
    (setq *top-level-code* microcode)
    (check-microcode microcode name)
    `(progn 'compile
	     ,@(if (eq data '10-bit-immediate-operand)
		   (loop for i from 0 below 4
			 nconc (defucode-2 flavor name microcode data i))
		 (defucode-2 flavor name microcode data))
	     ',name)))

(defun defucode-2 (flavor name microcode data &optional (offset 0) &aux (iname name))
  (and (plusp offset) (setq iname (fintern "~A-~D" name offset)))
  (let ((lisp-name (fintern '|~A-LISPMICROCODE| iname)))
    `(,@(cond ((eq *machine-version* 'sim)
	       (nconc (if (eq flavor 'definst)
			  (ncons `(defprop ,iname ,lisp-name micro-executor)))
		      (ncons (microcode-to-lisp-function lisp-name microcode #Q iname)))))
      ,(let ((address-constraint (selectq flavor
				   (definst (let ((loc (instruction-dispatch-loc name)))
					      (+ loc (* offset 4))))
				   (defucode-at-loc data)
				   (otherwise nil))))
	 `(put-ucode ',iname
		     ',microcode
		     ',(if (eq *machine-version* 'sim) lisp-name
			   (assemble-microinstruction-plist iname microcode
							    address-constraint offset))
		     ',*machine-version*)))))

(defun put-ucode (tag microcode micrel machine-version)
  (or (si:record-source-file-name tag 'defucode)
      (ferror nil "Sorry, I already did most of it"))
4,887,235
	245	246
	(let ((ucode (assq machine-version *ucode-alist-alist*)) tem)
	  (or ucode (push (setq ucode (cons machine-version nil)) *ucode-alist-alist*))
	  (cond ((setq tem (assq tag (cdr ucode)))
		 (setf (cadr tem) microcode)
		 (setf (caddr tem) micrel))
		(t (push (list tag microcode micrel) (cdr ucode)))))
	(setq *need-to-link* t)
	tag)

;Due to universal opcodes, this works for both normal and format-3 instructions
(defun instruction-dispatch-loc (name)
  (lsh (car (get name instruction-data)) 2))

;;; Reading in of the opcode definitions file
;XXXbrad - line missing $%#%$#
(defmacro defopcode (name opcode format &rest attributes)
  `(defopcode1 ',name ',opcode ',format ',attributes))

(defun defopcode1 (name opcode format attributes)
  (or (<= 0 opcode 377)		;Temporary 8-bit opcodes
      (<= 1000 opcode 1377)	;But do have 8 bits of format-3 also
      (ferror nil "Opcode ~O for instruction ~S out of range" opcode name))
  (or (memq format '(unsigned-immediate-operand signed-immediate-operand
		     address-operand no-operand quick-external-call constant-operand
		     indirect-operand lexical-operand instance-operand
		     microcode-operand unsigned-pc-relative signed-pc-relative
		     constant-pc-relative 10-bit-immediate-operand)) 
      (ferror nil "Format ~S for instruction ~S not recognized" format name))
  (and (bit-test 1000 opcode)
       (neq format 'no-operand)
       (ferror nil "Instruction ~S with opcode ~O must be NO-OPERAND, not ~S"
	       name opcode format))
  (loop for attr in attributes do
	(or (memq attr '(needs-stack smashes-stack branch-predict stop-ifu))
	    (and (listp attr) (eq (car attr) 'function) (<= 3 (length attr) 4))
	    (and (listp attr) (eq (car attr) 'operand) (= (length attr) 2))
	    (ferror nil "Attribute ~S for instruction ~S not recognized" attr name)))
  (putprop name (list* opcode format attributes) 'instruction-data)
  (if (eq format '10-bit-immediate-operand)
      (loop for i from 1 to 3
	    do (aset name *opcode-table* (+ opcode i))))
  (aset name *opcode-table* opcode))

(defun validate-definst (name format-and-attributes)
  (let ((format (if (atom format-and-attributes) format-and-attributes
		    (car format-and-attributes)))
	(attributes (if (atom format-and-attributes) nil (cdr format-and-attributes)))
	(data (get name 'instruction-data)))
    (cond ((null data)
	   (ferror nil "~S not defined in OPDEFS file" name))
	  ((neq format (cadr data))
	   (ferror nil "~S in format ~S disagrees with OPDEFS file, which says ~S"
		   name format (cadr data)))
	  ;Check attributes that affect the microcode. I think IFU ones don't.
	  ((loop for attrib in '(needs-stack smashes-stack)
		 thereis (neq (not (memq attrib attributes))
			      (not (memq attrib (cddr data)))))
	  (ferror nil "Attributes for ~S disagrees with OPDEFS file" name)))))

;;; Reading in of the system definitions files

(defun sysconstant-eval-fun (type value)
  (selectq type
    (nil (or (get value 'sysconstant)
	     (car (qet value 'byte-field))	;PPSS
	     (ferror nil "~S has no DEFSYSCONSTANT nor DEFSYSBYTE value" value)))
    (dcfsysbyte-limit-value
     (1+ (byte-field-ones value)))
    (defsysbyte-ones
      (byte-field-ones value))
    (defstorage-size
      (get value 'defstorage-size))
    (otherwise
     (ferror nil "Do not understand ~S for ~S" type value))))

(defun byte-field-ones (ref)
  (dpb -1
       (ldb 0006 (car (or (get ref 'byte-field)
			  (ferror nil "~S has no DEFSYSBYTE value" ref))))
       0))

(defmacro defsysconstant (name form)
  (setq form (llc:defsysconstant-eval form #'sysconstant-eval-fun))
  `(putprop ',name ',form 'sysconstant))

(defmacro defsysbyte (name n-bits bits-over)
  (setq n-bits (llc:defsysconstant-eval n-bits #'sysconstant-eval-fun))
  (setq bits-over (llc:defsysconstant-eval bits-over #'sysconstant-eval-fun))
  `(eval-when (compile load eval)
     (putprop ',name `(,(byte-numbers-to-ppss n-bits bits-over)) 'byte-field)))
4,887,235
	247	248
;;; (defenumerated list-name (names...) [starting-value] [increment] [endingvalue])
;;;	starting-value defaults 0, increment to 1
;;;	If endingvalue is supplied, it is error-checked
(defmacro defenumerated (list-name code-list &optional (start 0) (increment 1) end)
;XXXbrad not convinced '=' below is right, maybe 'approx equal'?
  (and end (= (length code-list) (// (- end start) increment))
       (ferror nil "~S has ~S codes where ~S are required"
	       list-name (length code-list) (// (- end start) increment)))
 `(progn 'compile
	  (defconst ,list-name ',code-list)
	  (defprop ,list-name
	    ,(loop for code in code-list and prev = 0 then code
		   as value from start by increment
		   unless (eq code prev)	;kludge for data-types
		     collect `(,code . ,value))
	    enumerated-type-codes)
	  ;; sysconstant properties ore expected by some embedded expressions
	  ,@(loop for code in code-list and prev = 0 then code
		  as value from start by increment
		  unless (eq code prev)		;kludge for data-types
		  collect `(putprop ',code ',value sysconstant))))

;;; (defstorage (structure-name options...)
;;;	     fields...)      
;;;	field = (name n-bits right-hand-bit-number) or a list of subfields.
;;:	Omitting the bit specification gets you a word-filling Lisp object.
;;;	The top-level fields are really words, the rest are packed bytes.
;:; Options:
;;;	BACKWARDS (word offsets count down from 0 instead of up from 0)
;;;
;;; For the microassembler, this defines def-byte-field type accessors
;;; for the defined bytes, and assumes that the microprogrammer takes
;;; care of the word offsets. That will do for the simple structures like arrays.
;;; The offsets do get saved on a word-offset property for possible future use.
(local-declare ((special *defstorage-fields*))
(defmacro defstorage ((structure-name . options) . fields)
  (let ((increment 1)
	(*defstorage-fields* nil))
    (dolist (opt options)
      (selectq opt
	(backwards (setq increment -1))
	(otherwise (ferror nil "DEFSTORAGE ~S - unrecognized option ~S" structure-name opt))))
;XXXbrad backquote before progn?
    `(progn 'compile
	    ,@(loop for field in fields as word from 0 by increment
		    nconc (defstorage-fields field word structure-name))
	    (defprop ,structure-name ,(length fields) defstorage-size)
	    (defprop ,structure-name ,*defstorage-fields* defstorage-fields))))

(defun defstorage-fields (field word structure-name)
  (cond ((or (listp field) (null field))	;until listp is fixed...
	 (if (listp (car field))
	     (loop for subfield in field
		   nconc (defstorage-fields subfield word structure-name))
	   (defstorage-field field word structure-name)))
	(t (defstorage-field (list field) word structure-name))))

(defun defstorage-field (field word structure-name)
  structure-name ;not used
  (push (car field) *defstorage-fields*)
  (list `(defprop ,(car field) ,word word-offset)
	(and (cdr field)
	     `(def-byte-field ,(car field) ,(cdr field) place))))
); local-declare

;Extract word offset for a field; use this inside an a-constant or b-constant form
(defun field-word-offset (name)
  (or (get name 'word-offset)
      (terror nil "~S has no word-offset; probably not defined with DEFSTORAGE" name)))

(defvar *escape-function-next-pc-location*)

;Define a-memory locations that are uscd microcode/Lisp communication
;If the microcode wants to initialize these, it can defareg them itself;
;that defareg will get put in the same address.
(defmacro define-magic-locations ((block-name . options) &body slots &aux tem)
  (cond ((setq tem (get (locf options) 'a-memory-address)) 	;Interesting to microcode?
	 (if (eq block-name 'microcode-escape-routines)
	     (setq *escape-function-next-pc-location* tem))
	 `(progn 'compile
	    (defprop ,block-name ,tem a-memory-block-address)
	    . ,(loop for slot in slots as loc upfrom tem
		collect `(defareg-at-loc ,(if (symbolp slot) slot
					    (intern (format nil "~A-~A"
							    (car slot) (cadr slot))))
			  ,loc))))
	((setq tem (get (locf options) 'virtual-address))
	 `(progn 'compile
		 . ,(loop for slot in slots as loc upfrom tem
		      collect `(defprop ,slot ,loc virtual-address))))))
4,887,235
	249	250
;Define a-memory locations that hold PC's of escape functions
;--- Someone needs to store an initial value for the simulator ---
(defmacro define-escape-function (name &body ignore)
  (let ((a-mem-p t))
    (cond ((listp name)
	   (dolist (opt (cdr name))
	     (selectq opt
	       (no-a-memory (setq a-mem-p nil))
	       (wired )
	       (otherwise (ferror nil "Unknown keyword ~S" opt))))
	   (setq name (car name))))
    (and a-mem-p
	 (prog1 `(defareg-at-loc ,(intern (string-append name "ESCAPE-PC"))
				 ,*escape-function-next-pc-location*)
		(incf *escape-function-next-pc-location*)))))


F:>lmach>ucode>UL.LISP.167

;;; -*- Mode:Lisp; Package:Micro; Base:8; Lowercase:yes -*-
;;; (c) Copyright 1982, Symbolics, Inc.

; Microcode to Lisp translator (makes Lisp that will run with SIM)





;The order of the defconsts is the order of execution in the Lisp.
(defconst read-phase-fields
	'(abus amem-read-addr bbus bmem-read-addr xbus ybus))

(defconst data-path-fields
	'(alu byte-func))

(defconst force-obus-fields
	'(force-obus<35-34> force-obus<33-32> force-obus<31-28>))

(defconst trap-phase-fields
	'(type-map trap-enables trap-sequence arith-trap-dispatch-table))

(defconst operate-phase-fields
	'(dispatch dispatch-table escape-to-lisp error-table))

(defconst register-write-fields
	'(write-amem amem-write-addr write-bmem bmem-write-addr
	  write-lbus lbus-dev-addr mem stack-pointer))

(defconst jump-phase-fields
	'(sequencer jump-sequence next-sequence condition
	  skip-true-sequence skip-false-sequence))

(defconst all-over-the-place-fields
	'(spec magic magic-mask declare-memory-timing unique speed))

(defvar *microlisp-function-name*)
(declare (special *backtrace*)) ;in UU
(defvar *microinstruction*)

(defun bletch (format-string &rest args)
  (declare (special args))	;For accessibility from breakpoint
  (let #M ((^w nil) (^r nil) (^q nil))
       #Q ((msgfiles error-output))
    (format msgfiles "~&>>Error: ")
    (lexpr-funcall #'format msgfiles format-string args)
    (format msgfiles "~& While compiling microcode to lisp for ~S"
	    	     *microlisp-function-name*)
    (format msgfiles "~& Microinstruction: ~S" *microinstruction*)
    (format msgfiles "~& Microexpand backtrace: ~{~<~%    ~2:;~A~>~^, ~}~%"
	    *backtrace*)
    (break bletch t)))

;selectq with appropriate error processing
(defmacro eselectq (valname val &rest clauses)
  (let ((nil-present (loop for (key) in clauses
			   thereis (or (eq key nil) (and (listp key) (memq nil key))))))
    `(selectq ,val
       ,@clauses
       ,@(and (not nil-present) '(((nil) nil)))
       (otherwise (bletch "~S invalid value for ~S" ,val ',valname)))))

(defun mksetq (var val)
  (and val (ncons `(setq ,var ,val))))

(defun mksetq2 (var1 var2 val)
  (and val (ncons `(setq ,var1 (setq ,var2 ,val)))))
4,887,235
	251	252
(defvar *dispatch-destination* nil)

#M
(declare-special squid)
#M
(defun eval-at-load-time (form)
  (cond ((status feature conplr)
	 (list squid form))
	(t (eval form))))
#Q
(defun eval-at-load-time (form)
  `',(if (and compiler:qc-file-in-progress (not compiler:qc-file-load-flag))
	 (cons compiler:eval-at-load-time-marker form)
       (eval form)))

(declare (*expr fieldp)) ;in UU
;Simulation routines for shifter

#M
(declare (fixnum (rot32 fixnum fixnum)
		 (ash32 fixnum fixnum)
		 (merge32 fixnum fixnum fixnum)
		 (mask32 fixnum))
	 (special *pc*))	;in SIM

(eval-when (eval compile load)
(defun ash32 (value amount)
  (ash (logand value #.(1- 1_32.)) amount))
); eval-when

(defun rot32 (value amount)
  (setq amount (logand 37 amount))
  #M (dpb value (+ (lsh amount 6) (- 40 amount))
	  (ldb (+ (lsh (- 40 amount) 6) amount) value))
  #Q (logior (logand (ash32 value amount) #.(1-	1 32.))
	     (logand (ash32 value (- amount 40)) (1- (ash 1 amount)))))

(defun mask32 (nbits)
  (1- (ash 1 nbits)))

(defun merge32 (shifted mask unshifted)
  (logior (logand mask shifted)
	  (logand (lognot mask) unshifted)))

;More simulation routines. These are used instead of open-codinq
;things so that ncomplr doesn't expand my code by a factor of 100
#M
(declare (muzzled t)		;Don't give me a hard time about haulong
	 (load 'sim)		;Get certain macros needed below
	 (fixnus (address-add-fp fixnum)
		 (address-add-sp fixnum)
		 (address-add-macrocode)
		 (aref-amem fixnum)
		 (aref-bmem fixnum)
		 (aref bmem-360)
		 (16-bit-sign-extend fixnum))
	 (notype (aset-amem fixnum fixnum)
		 (aset-bmem fixnum fixnum)
		 (aset-bmem-360 fixnum)
		 (setq-vma fixnum)
		 (setq-fp fixnum)
		 (setq-sp fixnum)
		 (carry28 fixnum fixnum fixnum)
		 (carry32 fixnum fixnum fixnum)))
(declare (special *frame-pointer* *stack-pointer* *xbas* *pc* *vma* *pma* *instruction*
		  *a-memory* *b-memory* *byte-r* *byte-s* *type-map*
		  *multiply-x* *multiply-y* *last-error-table-entry-seen*))

#M
(declare (*lexpr address-add)
	 (*expr even-instruction odd-instruction instruction-opcode
		instruction-unsigned-immediate instruction-signed-immediate
		pc-add instruction-baseno instruction-offset stack-address
		set-pma-from-vma)
	 (fixnum (even-instruction fixnum) (odd-instruction fixnum)
		 (instruction-opcode) (instruction-unsigned-immediate)
		 (instruction-signed-immediate) (pc-add fixnum fixnum)
		 (instruction-baseno) (instruction-offset)
		 (stack-address fixnum) (address-add notype fixnum)))

(defun address-add-fp (offset)
  (address-add '*frame-pointer* offset))

(defun address-add-sp (offset)
  (address-add '*stack-pointer* offset))

(defun address-add-xb (offset)
  (address-add '*xbas* offset))
