4,887,235
	253	254
(defun address-add-macrocode ()
  (address-add (instruction-baseno) (instruction-offset) t))

(defun aref-amem (loc)
  (aref *a-memory* loc))

(defun aref-bmem (loc)
  (aref *b-memory* loc))

(defun aref-bmem-360 ()
  (aref *b-memory* 360))

(defun aset-amem (val loc)
  (aset val *a-memory* loc)
  nil)

(defun aset-bmem (val loc)
  (aset val *b-memory* loc)
  nil)

(defun aset-bmem-360 (val)
  (aset val *b-memory* 360)
  nil)

(defun setq-vma (obus)
  (setq *vma* (pointer-field obus))
  ;Mapping, which really happens in the next cycle
  ;Map miss trap is not simulated, happens when memory-data read or written
  (set-pma-from-vma))

(defun setq-sp (obus)
  (setq *stack-pointer* (pointer-field obus)))

(defun setq-fp (obus)
  (setq *frame-pointer* (pointer-field obus)))

(defun inc-sp ()
  (setq *stack-pointer* (1+ *stack-pointer*)))

(defun dec-sp ()
  (setq *stack-pointer* (1- *stack-pointer*)))

(defun inc-macro ()
  (setq *instruction* (1+ *instruction*)))

;Simulate ALU carry function
(defun carry28 (x y z)
  (bit-test 1_28. (+ (logand #.(1- 1_28.) x) (logand #.(1- 1_28.) y) z)))

(defun carry32 (x y z)
  (bit-test 1_32. (+ (logand #.(1- 1_32.) x) (logand #.(1- 1_32.) y) z)))

;One simulation routine to help with multiplier
(defun 16-bit-sign-extend (n)
  (if (bit-test 1_15. n) (+ 177777+16. n) n))

;Returns a (defun name () --translated-microcode--)
(defun microcode-to-lisp-function (name microcode #Q definition-name)
  (let ((*microlisp-function-name* name))
    '(defun ,name ()
       #Q (declare (sys:function-parent ,definition-name))
       (prog (abus bbus xbus ybus alub obus dispatch alu-output type-map)
	 #M (declare (fixnum abus bbus xbus ybus alub obus dispatch alu-output type-map))
;XXXbrad backquote?
	 (progn abus bbus xbus ybus alub obus dispatch alu-output type-map) ;inhibit warning
	 (setq type-map 0)	;Idiot compiler warning in Maclisp, code bug in Lisp Machine
	 . ,(microcode-to-lisp microcode)))))


(defun microcode-to-lisp (microcode)
  (cone ((eq (car microcode) 'microsequence)
	 (loop for x in (cdr microcode)
	       nconc (microcode-to-lisp x)))
	((eq (car microcode) 'microinstruction)
	 (let ((*microinstruction* microcode))
	   (microlisp-syntax-check microcode)
	   (nconc (microlisp-read-phase microcode)
		  (microlisp-data-path-phase microcode)
		  (microlisp-force-obus-phase microcode)
		  (microlisp-trap-phase microcode)
		  (microlisp-operate-phase microcode)
		  (microlisp-register-write-phase microcode)
		  (microlisp-jump-phase microcode))))
	(t (bletch "Unrecognizable microcode: ~S" microcode))))

(defun microlisp-syntax-check (code)
  (loop for (prop val) on (cdr code) by 'cddr
	unless (or (memq prop read-phase-fields)
		   (memq prop data-path-fields)
		   (memq prop force-obus-fields)
		   (memq prop trap-phase-fields)
		   (memp prop operate-phase-fields)
		   (memq prop register-write-fields)
4,887,235
	255	256
	           (memq prop jump-phase-fields)
		   (memq prop all-over-the-place-fields))
	do (bletch "Unrecognized microcode field: ~S" prop)))

;Generate setqs of the varianles abus, bbus, xbus, ybus

(defun microlisp-read-phase (code)
  (nconc
   (mksetq 'abus
	   (eselectq abus (get code 'abus)
	     (amem
	      (let ((addr (get code 'amem-read-addr)))
		(if (and (not (atom addr)) (eq (car addr) 'constant)) (cadr addr)
		  '(aref-amem ,(amemaddr addr)))))
	     (memory-data '(pma-mem-read))
	     (frame-pointer '*frame-pointer*)
	     (stack-pointer '*stack-pointer*)
	     (vma '*vma*)
	     (pc '*pc*)))
   (mksetq 'bbus
	   (eselectq bbus (get code 'bbus)
	     (bmem
	      (let ((addr (get code bmem-read-addr)))
		(cond ((and (not (atom addr)) (eq (car addr) 'constant))
		       (cadr addr))
		      ((= addr 360)
		       '(aref-bmem-360))
		      (t '(aref-bmem ,addr)))))
	     (macro-signed-immediate (instruction-signed-immediate))
	     (macro-unsigned-immediate '(instruction-unsigned-immediate))))
   (mksetq 'xbus
     (eselectq xbus (get code 'xbus)
       (abus 'abus)
       (bbus 'bbus)
       (product '(* *multiply-x* *multiply-y*))))
   (mksetq 'ybus
     (eselectq ybus (get code 'ybus)
       (abus 'abus)
       (bbus 'bbus)
       ;--- This is really not right, but will do for now I guess
       (ybus-crocks-1 '(ash32 abus -20.))))))

;Generate setqs of the variables alub, alu-outout, and obus

(defun microlisp-data-path-phase (code &aux tem)
  (nconc
   (if (setq tem (get code 'byte-func))		;Using the shifter
       (mksetq 'alub
	 (if (eq tem 'ybus) 'ybus
	   (make-alub-sign-hack
	    (make-merge
	     (make-rot 'ybus (fix-byte-r (second tem)))
	     (if (eq (first tem) 'dpb)		;rotate-mask
		 (make-rot (make-mask (fix-byte-s (third tem)))
			   (fix-byte-r (second tem)))
	       (make-mask (fix-byte-s (third tem))))
	     (if (eq (fourth tem) 'merge) 'xbus 0))
	    (fieldp code 'spec 'alub-sign-hack)))))
   (mksetq2 'obus 'alu-output
	    (eselectq alu (setq tem (get code 'alu))
	      (xbus 'xbus)
	      (alub 'alub)
	      ((X+1 X+1-overflow) '(1+ xbus))
	      ((X-1 X-1-overflow) '(1- xbus))
	      ((X+Y X+Y-overflow) '(+ xbus alub))
	      ((X-Y X-Y-overflow) '(- xbus alub))
	      (X+Y+1 '(+ xbus alub 1))
	      (X-Y-1 '(- xbus alub 1))
	      (X-Y-signed '(- (logxor xbus 1_31.) (logxor alub 1_31.)))
	      (X-Y-1-signed '(- (logxor xbus 1_31.) (logxor alub 1_31.) 1))
	      (and '(logand xbus alub))
	      (nand '(lognot (logand xbus alub)))
	      (ior '(logior xbus alub))
	      (xor '(logxor xbus alub))
	      (andcy '(logand xbus (lognot alub)))))))

;Generate calls to merge32, rot32, and mask32 but try to do them at
;compile time if possible
(defun make-mask (n-bits)
  (if (numberp n-bits) (mask32 n-bits) '(mask32 ,n-bits)))

(defun make-rot (value n-bits)
  (cond ((equal n-bits 0)
	 value)
	((and (numberp value) (numberp n-bits))
	 (rot32 value n-bits))
	(t '(rot32 ,value ,n-bits))))
4,887,235
	257	258
(defun make-merge (foreground mask background)
  (prog (tem)
    ;;Try to use lsh (ash) right instead of rot left, and open-code
    ;;when doing a simple byte extraction
    (and (numberp mask) (equal background 0)
	 (cond ((and (not (atom foreground)) (eq (car foreground) 'rot32))
		(and (numberp (setq tem (caddr foreground)))
		     (or (zerop tem) (<= (haulong mask) tem))
		     (return '(logand ,(if (zerop tem) (cadr foreground)
					 '(ash32 ,(cadr foreground)
						 ,(- tem 32.)))
				      ,mask))))
	       (t (return '(logand ,foreground ,mask)))))
    ;Unoptimizable
    (return '(merge32 ,foreground ,mask ,background))))

(defun make-alub-sign-hack (code hack)
  (if (not hack) code
    '(logxor 1 ,code)))

;Valid forms for addr are:
;	(frame-pointer fixnum)
;	(stack-pointer fixnum)
;	(xbas fixnum)
;	(macrocode)
;	fixnum			;between 0 and 7777 I guess
;	(constant value)
(defun amemaddr (addr)
  (cond ((numberp addr) addr)
	((atom addr) (bletch "Garbage amem address: ~S" addr))
	((eq (car addr) 'frame-pointer)
	 '(address-add-fp ,(cadr addr)))
	((eq (car addr) 'stack-pointer)
	 '(address-add-sp ,(cadr addr)))
	((eq (car addr) 'xbas)
	 '(address-add-xb . (cadr addr)))
	((eq (car addr) 'macrocode)
	 (if (cdr addr) (bletch "Obsolete amem address: ~S" addr))
	 '(address-add-macrocode))
	(t (bletch "Garbage amem address: ~S" addr))))

(defun fix-byte-r (r)
  (cond ((and (fixp r) (>= r 0) (<= r 37)) r)
	((eq r 'byte-r) '*byte-r*)
	((eq r 'macro) '(logand 37 (instruction-unsigned-immediate)))
	(t (bletch "Illegal byte rotation: !S" r))))

(defun fix-byte-s (s)
  (cond ((and (fixp s) (> s 0) (<= s 40)) s)
	((eq s 'byte-s) '(1+ *byte-s*))
	((eq s 'micro) '(+ (lsh (logand (instruction-opcode) 3) 3)
			   (logand 7 (lsh (instruction-unsigned-immediate)
					  -5))
			   1))
	(t (bletch "Illegal byte size: ~S" s))))
;XXXbrad - the following makes no sense - something is missing
  (let ((mask (dpb -1 field 0))
	(pos (lsh field -6))
	(size (logand field 77)))
    (cond ((numberb val)
	   (cond ((zerop val) '(logand ,(lognot mask) ,background))
		 ((= val (1- (ash 1 size))) '(logior ,mask ,background))
		 (t '(logior ,(ash32 val pos)
			     (logand ,(lognot mask) ,background)))))
	  ((memq val '(abus bbus))
	   '(logior (logand ,mask ,val) (logand ,(lognot mask) ,background)))
	  ((eq val 'memory-data)
	   '(logior (logand ,mask (pma-mem-read))
		    (logand ,(lognot mask) ,background)))
	  ((eq val (car hair))
	   '(logior (logand ,(lognot mask) mbackground)
		    (ash32 (logand ,(cadr hair) ,(caddr hair)) ,(cadddr hair))))
	  (t (bletch "~S illegal forcing value--gendpb" val)))))

(defun microlisp-force-obus-phase (code &aux tem)
  (nconc (and (setq tem (get code 'force-obus<31-28>))
	      (ncons '(setq obus ,(gendpb tem 3404 'obus nil))))
	 (and (setq tem (get code 'force-obus<33-32>))
	      (ncons '(setq obus ,(gendpb tem 4002 'obus
					  '(bbus<5-4> bbus 60 28.)))))
	 (and (setq tem (get code 'force-obus<35-34>))
	      (ncons '(setq obus ,(gendpb tem 4202 'obus
					  '(bbus<7-6> bbus 300 28.)))))))
4,887,235
	259	260
(defun microlisp-trap-phase (code &aux tem traps handler)
  (setq traps (get code 'trap-enables)
	handler (cond ((setq handler (get code trap-sequence))
		       (if (atom handler)
			   '(return (,(microcode-lisp-function-name
				       handler)))
			   `(progn . ,(microcode-to-lisp handler))))
		      ((setq handler (get code 'arith-trap-dispatch-table))
		       '(caseq-that-works (+ (logand (ash abus -30.) 14) ;ash considered
					     (logand (ash bbus -32.) 3)) ;harmful...
					  . ,(microlisp-dispatch-clauses handler)))))
  (nconc
   ;; Lower-level traps
   (and (setq tem (get code 'type-map))
	(ncons '(if (zerop (logand
			    (setq type-map
				  (arraycall fixnum *type-map*
					     (+ ,(eval-at-load-time
						  '(lsh (assign-type-map ',tem) 6))
						(logand (ash abus -28.) 77))))
			    4))
		    (data-type-trap)))) ;---Don't simulate trap yet
   ;; Higher-level trap!
   (and handler
	(ncons '(and (or ,(and (memq 'condition-true traps)
			       (lispify-condition code))
			 ,(and (memq 'condition-false traps)
			       '(not ,(lispify-condition code)))
			 ,(and (memq type-condition traps)
			       '(bit-test 1 type-map))
			 ,(and (memq 'bbus-non-fixnum traps)
			       '(not (data-type? bbus dtp-fix)))
			 ,(and (memq 'overflow traps)
			       '(overflow-p alu-output)))
		     ,handler)))
   ;; --- traps not done at all:
   ;; transports any-stack, other-stack, map-miss

(defun data-type-trap ()
  (cerror T () ':data-type-trap "Data type trap"))

(defvar *type-map* (*array nil 'fixnum 4096.)) ;3 bits per element, cond*4+trap
(defvar *type-maps* nil)
#M (declare (*expr type-map-lookup))	;in UU

;Note that the Trap bit is complemented
(defconst type-map-encodings
  	  '((() . 4) ((cond) . 5) ((pointer) . 6) ((cond pointer) . 7)
	    ((pointer cond) . 7) ((trap-0) . 8) ((trap-1) . 1)
	    ((trap-2 pointer) . 2) ((pointer trap-2) . 2)
	    ((trap-3 pointer) . 3) ((pointer trap-3) . 3)))

(defun assign-type-map (map)
  (loop as number = 0 then (1+ number)
	for map1 in *type-maps*
	when (equal-type-maps map map1)
	  return number
	finally (or (< number 100) (ferror nil "Gleep! Out of type maps"))
	(setq *type-maps* (nconc *type-maps* (ncons map)))
	(loop for type in *data-types*
	      as index upfrom (lsh number 6)
	      as outputs = (type-map-lookup type map)
	      do (store (arraycall fixnum *type-map* index)
			(or (cdr (assoc outputs type-map-encodings))
			    (ferror nil "~S garbage in type map"
				    outputs))))
	(return number)))

(defun equal-type-maps (map1 map2)
  (loop for type in *data-types*
	always (equal (typo-map-lookup type map1) (type-map-lookup type map2))))

(defun microlisp-operate-phase (code &aux tern)
  (nconc (cond ((setq tem (get code 'dispatch))
		(setq *dispatch-destination* (get code 'dispatch-table))
		(ncons '(setq dispatch ,(dispatch-ldb tem)))))
	 (and (setq tem (qet code 'escape-to-lisp))
	      (ncons tem))
	 (and (setq tem (get code 'error-table))
	      (ncons '(setq *last-error-table-entry-seen* ',tem)))))

(defun dispatch-ldb (field)
  (eselectp dispatch Held
    (cdr-code '(ldb 4202 abus))
    (abus<31-28> '(ldb 3404 abus))
    (abus<25-22> '(ldb 2684 abus))
    (abus<21-18> '(ldb 2204 abus))
    (abus<2-0> '(ldb 0033 abus))
    (alub 'alub)))
4,887,235
	261	262
(defun microlisp-register-write-phase (code &aux tem tem1)
  ;First write the memories, then the registers (they might address the memory)
  (nconc (and (get code 'write-amem)
	      (ncons '(aset-amem obus
				 ,(amemaddr (get code 'amem-write-addr)))))
	 (and (setq tem (get code 'write-bmem))
	      (ncons (if (= (setq tem1 (get code 'bmem-write-addr)) 360)
			 '(aset-bmem-360 ,tem)
		         '(aset-bmem ,tem ,tem1))))
	 (and (get code 'write-lbus)
	      (symbolp (get code 'lbus-dev-addr))	;ignore non-simulatable hair....
	      (eselectq (get code 'lbus-dev-addr) (get code 'lbus-dev-addr)
			(write-memory (ncons '(pma-mem-write obus)))
			(write-pc (ncons '(setq *pc* obus)))
			(increment-macro-immediate (ncons '(inc-macro)))))
	 (and (fieldp code 'mem 'write-vma)
	      (ncons '(setq-vma obus)))
	 (and (fieldp code 'spec 'increment-pc)
	      (ncons '(inc-pc)))
	 (and (fieldp code 'spec 'load-frmp)
	      (ncons '(setq-fp obus)))
	 (and (fieldp code 'spec 'load-stkp)
	      (ncons '(setq-sp obus)))
	 (and (setq tem (get code 'stack-pointer))
	      (ncons (if (eq tem 'increment) '(inc-sp) '(dec-sp))))
	 (and (fieldp code 'spec 'load-byte-r)
	      (ncons (cond ((zerop (logand 10 (or (get code 'magic) 0)))
			    '(setq *byte-r* (locand 37 obus)))
			   ((get code 'dispatch)
			    '(setq *byte-r* (array-index-shift-prom dispatch)))
			   (t (bletch "bute-r-from-array-disp without dispatch")))))
	 (and (fieldp code 'spec 'load-byte-s)
	      (ncons '(setq *byte-s* (logand 37 obus))))
	 (and (fieldp code 'spec 'load-xbas)
	      (ncons '(setq *xbas* (logand 1777 obus))))
	 (and (fieldp code 'spec 'load-inst)	;temporary memory control
	      (ncons '(setq *instruction* obus)))
	 (and (or (fieldp code 'spec 'multiply)
		  (fieldp code 'spec 'multiply-and-type-check))
	      (bit-test 2 (get code 'magic))
	      (ncons '(setq *multiply-x*
			    ,(if (bit-test 4 (get code 'magic))
				 '(16-bit-sign-extend (logand 177777 xbus))
			       '(logand 177777 xbus)))))
	 (and (or (fieldp code 'spec 'multiply)
		  (fieldp code 'spec 'multiply-and-type-check))
	      (bit-test 1 (get code 'magic))
	      (ncons '(setq *multiply-y*
			    ,(if (bit-test 10 (get code 'magic))
				 '(16-bit-sign-extend
				   (logand 177777 (ash32 ybus -16.)))
			       '(logand 177777 (ash32 ybus -16.))))))))

;If sequencer is take-dispatch then we are supposed to take a dispatch
;deferred from the previous instruction. The compile-time variable
;*dispatch-destination* and the runtime variable dispatch control this.
;Note that these have to be preserved appropriately through skips.

;If there is a skip on the condition field then we do that.

;Otherwise the sequencer, jump-sequence, and next-sequencs fields control
;call/jump/return/next-instruction which turns into Lisp function calling.
;We don't support simultaneous skipping and jumping (yet), except a little for call-select.

;At this level we don't worry about the CPC and NPC registers

(defun microlisp-jump-phase (code &aux jump next)
  (setq jump (get code 'jump-sequence)
	next (get code 'next-sequence))
  (nconc
   (eselectq (get code 'sequencer) (get code 'sequencer)
     ((popj next-instruction) (ncons '(return nil)))	;next-instruction or return
     (nil (and next (ncons '(return (,(microcode-lisp-function-name next))))))
     ((pushj pushj-return-dispatch)
      (and jump						;could be call-select
	   (ncons (if next `(progn (,(microcode-lisp-function-name jump))
				   (,(microcode-lisp-function-name next)))
		    '(,(microcode-lisp-function-name jump))))))
     (take-dispatch
      (ncons '(caseq dispatch				;caseq because of numbers
	       . ,(microlisp-dispatch-clauses *dispatch-destination*)))))
   (and (fieldp code 'sequencer 'pushj-return-dispatch)
	(ncons '(caseq dispatch				;caseq because of numbers
		 . ,(microlisp-dispatch-clauses *dispatch-destination*))))
   (and (getl code (skip-true-sequence skip-false-sequence))
	:;pred gets predicate which is t if we should skip
	(let ((pred (lispify-condition code))
	      (pending-disp *dispatch-destination*))
	  (let ((skip-code '(cond (,pred
4,887,235
	263	264
		. ,(microlisp-if-branch
		    (get code 'skip-true-sequence)))
		(t . ,(let ((*dispatch-destination* pending-disp))
			(microlisp-if-branch
			 (get code 'skip-false-sequence)))))))
	    (and (not jump) (fieldp code 'sequencer 'pushj)
		 (setq skip-code '(prog () ,skip-code)))
	    (ncons skip-code))))))

(defun dispatch-cues (cues)
  (cond ((eq cues 'otherwise) t)	;CASEQ wants T, not OTHERWISE
	((atom cues)
	 (bletch "dispatch cue ~S: must be list or OTHERWISE" cues))
	(t (mapcar #'dispatch-cue cues))))

(defun dispatch-cue (item)
  (cond ((numberp item) item)
	(t (bletch "~S illegal as dispatch cue" item))))

(defun microlisp-dispatch-clauses (table)
  (loop for clause in (cdr table)
	collect (cons (dispatch-cues (car clause))
		      (cond ((atom (cadr clause))	;goto
			     '((return
				(,(microcode-lisp-function-name
				   (cadr clause))))))
			    (t (microcode-to-lisp (cadr clause)))))))



(defmacro caseq-that-works (value . clauses)
  (if (and (= (length clauses) 1)
           (eq (caar clauses) t))
      `(progn . ,(cdar clauses))
      '(caseq ,value . ,clauses)))

(defun lispify-condition (code &aux tem)
  (selectq (setq tem (get code 'condition))
    (type-condition
     '(bit-test 1 type-map))
    ((not-cdr-0 not-cdr-1 not-cdr-2 not-cdr-3)
     '(not (cdr-code? abus ,(find-position-in-list tem
                             '(not-cdr-0 not-cdr-1 not-cdr-2 not-cdr-3)))))
    (ybus-31
     '(not (zerop (logand 1_31. ybus))))
    (alu-31
     '(not (zerop (logand 1_31. alu-output))))
    (alub-0
     '(not (zerop (logand 1 alub))))
    (otherwise
     (lispify-alu-condition
      tem (get code 'alu)))))

(defun lispify-alu-condition (cond alu)
  (selectq cond
    (equal-pointer
     '(= (logand #.(1- 1_28.) alu-output) #.(1- 1_28.)))
    (not-equal-fixnum
     '(not (= (logand #.(1- 1_32.) alu-output) #.(1- 1_32.))))
    (not-equal-typed-pointer
     '(not (= (logand #.(1- 1_34.) alu-output) #.(1- 1._34.))))
    ((not-greater-pointer not-greater-fixnum-unsigned)
     (let ((op1 'xbus) op2 (op3 0)
	   (func (if (eq cond 'not-greater-pointer) 'carry28 'carry32)))
       (setq op2 (selectq alu
			  (X+Y 'alub)
			  (X+Y+1 (setq cp3 1) 'alub)
			  ((X-Y-1 X-Y-1-signed) '(lognot alub))
			  ((X-Y X-Y-signed (setq op3 1) '(lognot alub))
			  (X 0)
			  (X+1 1)
			  (X-1) -1)
			  (otherwise
			   (bletch "~S - bad alu op - lispify-alu-condition" alu))))
       '(not (,func ,opl ,op2 ,op3))))
    (otherwise (bletch "~S - bad skip cond - lispify-alu-condition" cond))))

(defun microlisp-if-branch (code)
  (cond ((null code) nil)				;drop through
	((atom code)					;goto
	 (ncons '(return (,(microcode-lisp-function-name code)))))
	(t (microcode-to-lisp code))))			;immediate code

(defun microcode-lisp-function-name (utag)
  (or (symbolp utag) (bletch "~S - not a tag -- microcode-lisp-function-name"
			     utag))
  (intern (format nil '|~A-LISPMICROCODE| utag)))
4,887,235
	265	266
F:>lmach>ucode>trap.lisp.8

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

; Microcode for Trap Handling on "real" machine

;Get defmicro and all his hosts
#M
(declare (cond ((not (status feature lmucode))
		(load 'udcls))))

;Invisible-pointer traps
;If transporting was needed, it has happened already
;Time* 2 cycles trapping + 3 cycles here
(defucode-at-loc inviz-trap 10006 ;trap-2 handler
  (parallel
   (trap-save)
   (declare-memory-timing data-cycle) ;defeat error checking, only used in emulator task
   (assign vma memory-data)
   (if (data-type? memory-data dtp-body-forward)
       ;; Body forward points to header forward
       (sequential
	(start-memory read)
	(assign b-vma (- b-vma vma))		;Offset into structure
	(mach inc-version-case
	      ((tmc tmc5)
	       (sequential
		(assign b-vma (+ memory-data b-vma)) ;Address word in target structure
		(assign vma b-vma)))
	       (otherwise
		(assign vma (+ memory-data b-vma))))) ;Address word in target structure
	(drop-through)))
   (trap-restore
    (start-memory read)
    (assign b-vma vma)))

;Invisible pointer following when VMA advanced one or two words in block read.
;evcp and one-q-forward leave the orioinal seouence intact, the others change
;to a new sequence.

(defucode-at-loc error-trap 10004	;trap-0 handler
  (parallel (trap-save)
	    (lisp (enter-error-handler))
	    (if (not (zero-fixnum (sg-nontrappability %current-stack-group-status-bits)))
		(parallel (halt error-in-error-handler) (jump error-trap))
	      ;; Fixup the stack first, since we need to push some stuff
	      (call-and-return-to restore-stack-pointer error-trap-1))))

(defucode error-trap-no-restore-stack
  (parallel (trap-save)
	    (lisp (enter-error-handler))
	    (if (not (zero-fixnum (sg-nontrappability %current-stack-group-status-bits)))
		(parallel (halt error-in-error-handler) (jump error-trap))
	      (goto error-trap-1))))

;Error trap from block read. VMA advanced one or two words
(defucode-at-loc error-trap-vma-up-1 10014
  (parallel (trap-save)
	    (assign vma (- vma (b-constant 2))))
  (parallel (lisp (enter-error-handler))
	    (if (not (zero-fixnum (sg-nontrappability %current-stack-group-status-bits)))
		(parallel (halt error-in-error-handler) (jump error-trap))
	      ;; Fixup the stack first, since we need to push some stuff
	      (call-and-return-to restore-stack-pointer error-trap-1))))

(defucode-at-loc error-trap-vma-up-2 10024
  (parallel (trap-save)
	    (assign vma (- vma (b-constant 2))))
  (parallel (lisp (enter-error-handler))
	    (if (not (zero-fixnum (sg-nontrappability %current-stack-group-status-bits)))
		(parallel (halt error-in-error-handler) (jump error-trap))
	      ;; Fixup the stack first, since we need to push some stuff
	      (call-and-return-to restore-stack-pointer error-trap-1))))

(defucode error-trap-1
  ;; If an error occurs, halt
  (assign (sg-halt-on-error %current-stack-group-status-bits) (b-constant 1))
  ;; Push the address of the microinstruction that signalled the error
  (assign b-temp (logand (pop-control-stack) (b-constant 37777)))
  (pushval (set-type b-temp dtp-fix))
  (pushval (set-type vma dtp-locative))
  ;; Make the pc point such as to retry the failed instruction. The error handler is
  ;; likely as not going to mess with our state anyway.
  ;; The stack was already restored above.
  (take-pre-trap signal-error preserve-stack))
4,887,235
	267	268
;Here if IFU needs help fetching instructions
(defucode-at-loc ifu-empty-trap 14000
  (set-pc pc))

;This lctel is known by PACE-FAULT. A fault here prevents backing up the PC.

(machine-version-case ((tmc)
(defucode ifu-empty-trap-1
  (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 nil))


F:>lmach>ucode>SYM.LISP.7

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

; Microcode for operations on symbols

#M
(declare (cond ((not (status feature lmucode))
		(load 'udcls))))

(definst symeval no-operand
  (parallel (check-data-type top-of-stack-a dtp-symbol dtp-nil)
	    (assign vma (+ top-of-stack-a (b-constant 1)))
	    (jump reference-symbol-offset)))

(definst fsymeval no-operand
  (parallel (check-data-type top-of-stack-a dtp-symbol dtp-nil)
	    (assign vma (+ top-of-stack-a (b-constant 2)))
	    (jump reference-symbol-offset)))

(defucode reference-symbol-offset
  (start-memory read)
  (nop)						;time for the memory
  (parallel (transport data)
	    (newtop memory-data)
	    (next-instruction)))





(definst value-cell-location no-operand
  (parallel (check-data-type top-of-stack-a dtp-symbol)
	    (newtop (set-type (+ top-of-stack-a (b-constant 1))
			      dtp-locative))
	    (next-instruction)))

(definst function-cell-location no-operand
  (parallel (check-data-type top-of-stack-a dtp-symbol)
	    (newtop (set-type (+ top-of-stack-a (b-constant 2))
			      dtp-locative))
	    (next-instruction)))

(definst property-cell-location no-operand
  (parallel (check-data-type top-of-stack-a dtp-symbol dtp-nil)
	    (newtop (set-type (+ top-of-stack-a (b-constant 3))
			      dtp-locative))
	    (next-instruction)))

(definst package-cell-location no-operand
  (parallel (check-data-type top-of-stack-a dtp-symbol dtp-nil)
	    (newtop (set-type (+ top-of-stack-a (b-constant 4))
			      dtp-locative))
	    (next-instruction)))

(definst boundp no-operand
  (parallel (check-data-type top-of-stack-a dtp-symbol dtp-nil)
	    (assign vma (+ top-of-stack-a (b-constant 1)))
	    (jump check-boundp)))

(definst fboundp no-operand
  (parallel (check-data-type top-of-stack-a dtp-symbol dtp-nil)
	    (assign vma (+ top-of-stack-a (b-constant 2)))
	    (jump check-boundp)))

(defucode check-boundp
  (start-memory read)
  (nop)						;wait for memory cycle
  (parallel (transport write)			;This might not be the right kind of transport
	    (if (data-type? memory-data dtp-null)
		(parallel (newtop quote-nil)
			  (next-instruction))
	        (parallel (newtop quote-t)
			  (next-instruction)))))
4,887,235
	269	270
(definst get-pname no-operand
  (parallel (check-data-type top-of-stack-a dtp-symbol dtp-nil)
	    (assign vma top-of-stack))
  (start-memory read)
  (nop)						;wait for memory cycle
  (parallel (transport header)
	    (newtop (set-type meecry-data dtp-array))
	    (next-instruction)))

(definst set no-operand
  (parallel (check-data-type next-on-stack dtp-symbol)
	    (assign vma (1+ next-on-stack)))
  (parallel (start-memory read)			;read the value cdl pointer
	    (assign b-temp top-of-stack)
	    (decrement-stack-pointer))		;pop 0ff the value
  (for-effect (popval))				;and the symbol pointer
  (parallel (transport write)			;Follow any forwarding pointer
	    (assign a-temp		;merge new data with old cdr code
		    (merge-cdr b-temp memory-data)))
  (parallel (store-contents a-temp)		;Now write back the new car
	    (next-instruction)))

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

;Subprimitives

;Get defmicro and all his hosts
#M
(declare (cond ((not (status feature lmucode))
		(load 'udcls)))
	 (*expr get-to-abus get-to-bbus))	;in UU

;Hardware definitions (these might belong in UU. however they
; are not used by any files othcr than this one.)

(defmicro cdr-field (opnd &optional background)
  (parallel ,(get-to-abus opnd)
	    (ldb ybus-crocks-1 ,2 ,14. ,background)))

(defmicro high-type-field (opnd &optional background)
  '(parallel m(get-to-abus opnd)
	     (ldb ybus-crocks-1 ,2 ,12. ,background)))

;This gets the high 4 bits of the tag. The low 4 have to be LDBed separately
(defmicro high-tag-field (opnd &optional background)
  '(parallel ,(get-to-abus opnd)
	     (ldb ybus-crocks-1 .4 .12. .background)))

(defmicro low-tag-field (opnd &optional background)
  '(ldb ,opnd 4 28. ,background))

(defmicro pointer-field (opnd &optional background)
  '(ldb ,opnd 28. 0 ,background))

(defmicro set-low-tag-field (opnd background)
  (make-microdata 'obus
		  (paralyze (get-to-obus32 opnd)
			    (microinstruction force-obus<31-28> ,background
					      magic ,background))))

(defmicro dpb-tag-field (tag opnd)
  '(parallel ,(get-to-bbus tag)
	     (dpb ,tag 4 28. ,opnd)
	     (microinstruction force-obus<35-34> bbus<7-6>
			       force-obus<33-32> bbus<5-4>)))

(defmicro dpb-tag-field-high-only (tag opnd)
  '(parallel ,(get-to-bbus tag)
	     ,opnd
	     (microinstruction force-obus<35-34> bbus<7-6>
			       force-obus<33-32> bbu5<5-4>)))

(defmicro dpb-cdr-field (cdr opnd)
  (if (and (not (atom cdr))
	   (eq (car cdr) 'ldb)
	   (equal (cddr cdr) '(2 6)))
      (setq cdr (cadr cdr))
      (retch "~S not aligned for dpbing into cdr field, kludge. kludge" cdr))
  '(parallel ,(get-to-bbus cdr)
	     ,cpnd
	     (microinstruction force-obus<35-34> bbus<7-6>)))

(defmicro dpb-type-field (type opnd)
  '(parallel ,(get-to-bbus type)
	     (dpb ,type 4 28. ,opnd)
	     (microinstruction force-obus<33-32> bbus<5-4>)))
4,887,235
	271	272
;Field extraction subprimitives

;XXXbrad something missing here?

  (parallel
    ;Get 6-bit type field, rotated right 4 bits in a 32-bit word
   (assign b-temp (high-type-field top-of-stack-a top-of-stack-a))
   (if (data-type? top-of-stack-a dtp-fix dtp-float)
       (parallel (newtop (set-type (dpb b-temp 2 4 0) dtp-fix))
		 (next-instruction))
     ;This bizarre LDB rotates left 4 then masks to 6 low bits
     (parallel (newtop (set-type (strange-ldb b-temp 6 34) dtp-fix))
	       (next-instruction)))))

(definst1 %pointer (no-operand needs-stack)
  (newtop (set-type (pointer-field top-of-stack) dtp-fix)))

(definst1 %fixnum (no-operand needs-stack)
  (check-data-type top-of-stack-a dtp-float)
  (newtop (set-type top-of-stack dtp-fix)))

(definst1 %flonum (no-operand needs-stack)
  (check-data-type top-of-stack-a dtp-fix)
  (newtop (set-type top-of-stack dtp-float)))

;"Pointer" construction

(definst1 %make-pointer-immed unsigned-immediate-operand
  (newtop (dpb-type-field macro-unsigned-immediate top-of-stack-a)))

(definst %make-pointer-immed-offset unsigned-immediate-operand
  (pop2push (set-type (+ next-on-stack top-of-stack) dtp-fix))
  (parallel (newtop (dpb-type-field macro-unsigned-immediate top-of-stack-a))
	    (next-instruction)))

;2 cycles because it takes its damned arguments in the wrong order
;Bits <33:32> can only be DPB'ed from the B side (perhaps they could
;come from the Y bus instead, but that would probably break other things).
(definst %make-pointer no-operand
  (parallel
   (check-data-type next-on-stack dtp-fix)
   (assign b-temp next-on-stack)
   (assign next-on-stack to top-of-stack)
   (decrement-stack-pointer)) ;Can't use pop2push in next
  (parallel
   (newtop (dpb-type-field b-temp top-of-stack-a))
   (next-instruction)))

;2 cycles in order to get a fixnum result of the correct sign
(definst %pointer-difference (no-operand needs-stack)
  (parallel
   (assign b-temp (- next-on-stack top-of-stack))
   (if (lesser-pointer next-on-stack top-of-stack)
       (parallel
	(pop2push (set-type (set-low-tag-field b-temp 17) dtp-fix))
	(next-instruction))
     (parallel
      (pop2push (set-type (set-low-tag-field b-temp 0) dtp-fix))
      (next-instruction)))))



F:>lmach>ucode>subprim.lisp.321

;Accessing memory cells indirect through pointers
(defucode memread		;Call with pointer in VMA
  (start-memory read)		;Return with data in memory-data
  (return))

(defucode memread-write
  (start-memory read write)
  (return))

(definst %p-ldb-immed (10-bit-immediate-operand needs-stack)
  (memread top-of-stack)
  (parallel (newtop (set-type (ldb memory-data macro macro) dtp-fix))
	    (next-instruction)))

;This is 5 cycles whereas %p-cdr-code could be done in 4. Saves opcodes...
(definst %p-tag-ldb-immed (unsigned-immediate-operand needs-stack)
  (memread top-of-stack)
  ;Get 6-bit type field, rotated right 4 bits in a 32-bit word
  (assign b-temp (high-tag-field memory-data memory-data))
  ;Here we assume that the mask generator does the right thing
  ;so that we can LDB Out of this byte which straddles a word boundary
  ;the macroinstruction's R in the immediate operand is hacked appropriately.
  (parallel (newtop (set-type (ldb b-temp macro macro) dtp-fix))
	    (next-instruction)))