4,887,235
	133	134
(defu u-xybus-sel 1 14. t)

(defu u-stkp-count 1 15. if-set 0 stack-pointer store-stack-pointer)

(defu u-amwa 12. 16. t)
(defu u-amwa-byte 10. 16.)
(defu u-lbus-dev-addr 10. 16. nil 1777 lbus-dev-addr store-lbus-dev-addr)
(defu u-w-base 2 25.)
(defu u-w-offset 9 16.)
(defu u-amwa-18 1 26.)
(defu u-amwa-11 1 27.)
(defu u-amwa-sel 2 28. t 3) ;Default is not to write Amem (u-w-base<1> = 0)

(defu u-seq 2 30. if-set 0)
(defu u-bmra 8 32. t nil bmem-read-addr store-bmem-addr)
(defu u-bmwa 4 40. t 17 bmem-write-addr store-number)
(defu u-bmem-from-xbus 1 44. t nil write-bmem store-choice obus xbus)
(defu u-mem 3 45. if-set 0 mem store-mem-field)

(defu u-spec 5 48. if-set 20 spec store-choice
				load-byte-r load-byte-s load-stkp load-frmp
				load-xbas load-control load-special-maps
				clear-stack-adjustment ;load-inst on rev-2 dp
				arithmetic-trap-enb trap-if-types-cond
				trap-if-type-cond-or-bbus-not-fixnum multiply-and-type-check
				crocks alub-sign-hack crocks-to-ybus multiply
				20 addr-from-abus inhibit-page-tags dma
				 address-phtc check-write-access increment-inst ifu-control
				arithmetic-trap-with-dispatch halt npc-magic awaken-task
				write-task disable-tasking 36 37)
(defu u-magic 4 53. t nil magic store-number)
(defu u-cond-sel 5 57. t nil condition store-choice
				not-cdr-0 not-cdr-1 not-cdr-2 not-cdr-3
				type-condition bbus-not-fixnum alub-0 ybus-31
				not-gc-condemned-temp not-gc-this-stack not-gc-other-stack
				equal-pointer
				not-equal-fixnum not-equal-typed-pointer
				not-greater-pointer not-greater-fixnum-unsigned
				alu-31 sequence-break trace-flag-1 trace-flag-2
				not-lbus-dev-cond mc-cond 26 27
				38 31 not-ctos-came-from-ifu 33
				34 35 36 37)
(defu u-cond-func 2 62. if-set 0)

(defu u-alu 4 64. t nil alu store-alu-func)
(defu u-byte-func 2 68. if-set 0)
(defu u-obus-cdr 3 78. t nil forcs-obus<35-34> store-choice
				abus bbus bbus<7-6> nil 0 1 2 3)
						;bbus doesnt work on rev-2 DP
(defu u-obus-htype 3 73. t nil force-obus<33-32> store-choice
				abus bbus bbus<5-4> nil 0 1 2 3)
(defu u-obus-ltype-sel 1 76. t 1 force-obus<31-28> store-bit 0)

(defu u-cpc-sel 2 77. t)
(defu u-npc-sel 1 79. if-set 1)
(defu u-naf 14. 80. t)
(defu u-speed 2 94. t 0 speed store-speed)	;default is fastest, just to maximize lossaget
(defu u-type-map-sel 6 96. if-set 0 type-map store-type-map)
(defu u-au-func 8 102. if-set 0)
;(defu u-spare 1 110. if-set 0)
;(defu u-parity 1 111. if-set 0)

;NOTE: No knowledge of byte fields in the microinstruction after this point!
;;;; Back end of compiler

(defvar *opcode-offset*)	;for 10-bit-immediate-operand expansion

;Given a name and a microinstruction plist, return the corresponding micrel
(defun assemble-microinstruction-plist (name code
					&optional address-constraint *opcode-offset*)
  (let ((default-cons-area working-storage-area))	;Called inside macro expansion
    (let ((micrel (assemble-microinstruction-plist1 code (list name) 0)))
      (and address-constraint
	   (not (symbolp (mic-address-constraints micrel))) ;NIL or UNIQUE
	   (setq address-constraint
		 (append (if (atom address-constraint)
			     (list address-constraint)
			   address-constraint)
			 (if (atom (sic-address-constraints micrel))
			     (list (sic-address-constraints micrel))
			   (sic-address-constraints micrel)))))
      (setf (mic-address-constraints micrel) address-constraint)
      micrel)))

;Subroutine called recursively on successors. Path and index are for generated tags.
(defun assemble-microinstruction-plist1 (code path index &optional eventual-successor)
  (selectq (car code)
    (microinstruction
      (let ((micrel (make-micrel tag (cond ((plusp index) (append path (list index)))
					   ((cdr path) path)
					   (t (car path)))
				 error-table (get code 'error-table)))
4,887,235
	135	136
	(amwa-in-use nil)
	(amwa-11-in-use nil))

	;; Store the easy fields first so other things can clobber over individual bits
	(loop for (indicator value) on (cdr code) by 'cddr
	      do (store-field micrel indicator value t))
	(if (get code 'unique)
	    (setf (mic-address-constraints micrel) 'unique))
	;; Now store the byte-function
	(multiple-value-bind (byte-func magic magic-mask cond amwa)
	    (choose-byte-func-encoding code)
	  (store-number micrel byte-func u-byte-func)
	  (and magic (setf (ldb u-magic (mic-code micrel))
			   (logior (logand (ldb u-magic (mic-code micrel))
					   (lognot magic-mask))
				   magic)))
	  (and cond
	       (store-number micrel
			     (if (eq cond 'macro)
				 (lsh *opcode-offset* 3)
			         cond)
			     u-cond-sel))
	  (when amwa
	    (setq amwa-in-use t)
	    (store-number micrel amwa u-amwa-byte)))
	;; Store the extended 2-memory write address
	(let ((bmwa (get code 'bmem-write-addr)))
	  (when (and bmwa (< bmwa 360))
	    (setq amwa-in-use t)
	    (store-number micrel bmwa u-amwa)))
			;Bit 10 is 0, so Amem won't get written
	;; Other things that use AMWA
	(if (get code 'lbus-dev-addr)
	    (setq amwa-in-use t))
	(selectq (get code 'stack-pointer)
	  ((decrement) (setq amwa-11-in-use 0))
	  ((increment) (setq amwa-11-in-use 1)))
	(selectq (get code 'ybus)
	  ((ybus-crocks-1) (setq amwa-11-in-use 0))
	  ((ybus-crocks-2) (setq amwa-11-in-use 1)))
	;; Store the a-memory write address wherever it belong,
	;; Put it in the a-memory read address if necessary
	;; This code had damned well better agree with check-spec-and-magic-fields
	(let ((amwa (and (get code 'write-amem) (get code 'amem-write-addr)))
	      (amra (get code 'amem-read-addr)))
	  (cond ((null amwa)
		;; Not writing, -except- if memory mapped into Amem
		(if (fieldp code 'amem-write-addr '(bus-address))
		    (store-amem-write-addr micrel '(bus-address))))
	       ((or (not (memq (get code 'abus) '(nil amem)))	;Must use AMWA
		    (and amra (not (equal amwa amra)))		;Ditto
		    (and (not amwa-in-use)			;May use AMWA
			 (or (not (atom amwa))			;And no bit-11 conflict
			     (not amwa-11-in-use)
			     (= (lsh amwa -11.) amwa-11-in-use))))
		(store-amem-write-addr micrel amwa))
	       (t
		(store-amem-read-addr micrel amwa)	;Must use AMRA
		(store-number micrel 2 u-amwa-sel)
		(and (listp amwa)			;Must crank up the speed
		     (not (memq (get code 'speed) '(slow-first-half very-slow)))
		     (store-speed micrel 'slow-first-half u-speed)))))
	  ;; If we're supposed to be writing the Lbus, set the bit to tell
	  ;; the temporary memory control to do It
	  (and (get code 'write-lbus)
	       (eq *machine-version* 'proto)
	       (store-number micrel 1 u-amwa-10))
	  ;; Store bus select fields
	  (if (or (fieldp code 'xbus 'bbus) (fieldp code 'ybus 'abus))
	      (store-number micrel 1 u-xybus-sel))
	  (let ((abus (get code 'abus)))
	    (selectq abus
	      ((stack-pointer frame-pointer)
	       (store-number micrel 3 u-amra-sel)
	       (store-number micrel (if (eq abus 'stack-pointer) 0 1) u-r-base))
	      ((memory-data)
	       (store-number micrel 1 u-amra-sel)
	       (store-number micrel 2 u-r-base)
	       (store-number micrel 000 u-r-offset))
	      ((memory-data-force lbus vma map pc)
	       (store-number micrel 3 u-amra-sel)
	       (store-number micrel 2 u-r-base)
	       (store-number micrel (cdr (assq abus '((memory-data-force . 000)
						      (lbus . 100)
						      (vma . 200)
						      (map . 300)
						      (pc . 400))))
			     u-r-offset))))
	  (selectq (get code 'bbus)
	    (macro-unsigned-immediate (store-number micrel 0 u-bmra))
	    (macro-signed-immediate (store-number micrel 4 u-bmra)))
	  (selectq (qet code 'ybus)
4,887,235
	137	138
	    (ybus-crocks-1 (store-number micrel 0 u-amwa-11))
	    (ybus-crocks-2 (store-number micrel 1 u-amwa-11)))
	  ;; Set up cond func
	  (store-number micrel
	       (cond ((getl code '(skip-true-sequence skip-false-sequence return-skip)) 1)
		     ((mesq 'condition-true (get code trap-enables)) 2)
		     ((memq 'condition-false (get code 'trap-enables)) 3)
		     (t 0))
	       u-cond-func)
	  ;; Sequencer controls
	  (let ((cpc-sel 0) (npc-sel 1) (seq 0) (cpc-not-next nil))
	    (selectq (get code 'sequencer)
	      ((popj next-instruction) (setq cpc-sel 1 seq 3 cpc-not-next t))
	      ((pushj pushj-return-dispatch) (setq seq 1 cpc-not-next t))
	      (pop (setq seq 3))
	      (pop-npc (setq seq 3 npc-sel 1))	;spec-func assumed
	      (pop-npc-and-cpc-from-npc (setq seq 3 npc-sel 1 cpc-sel 2 cpc-not-next t))
	      (push-npc (setq seq 1))
	      (dismiss (setq seq 2))
	      (take-dispatch (setq cpc-sel 2 cpc-not-next t)))
	    ;; NPC comes from NEXT CPC+1 always, except when dispatching or popping into it
	    (if (get code 'dispatch) (setq npc-sel 0))
	    ;; Now, the good part--the successor instructions
	    (let* ((next (successor-instr (or (get code 'next-sequence) eventual-successor)
					  path index nil))
		   (must-be-naf-successor
		     (or (successor-instr (get code 'trap-sequence) path index 'trap)
			 (successor-dispatch (get code 'dispatch-table) path index)
			 (successor-dispatch (get code 'arith-trap-dispatch-table) path index)
			 (and (or (fieldp code 'sequencer 'pushj)
				  (fieldp code 'sequencer 'pushj-return-dispatch))
			      (get code jump-sequence))))
		   (skips (let ((true (get code 'skip-true-sequence))
				(false (get code 'skip-false-sequence)))
			    (and (or true false)
				 (list 'SKIP
				       (if true (successor-instr true path index 'true next)
					 next)
				       (if false (successor-instr false path index 'false next)
					 next)))))
		   (return-skips (let ((true (get code 'return-true-sequence))
				       (false (get code 'return-false-sequence)))
				 (and (or true false)
				      (list 'SKIP
					    (if true
						(successor-instr true path index 'true next)
					      next)
					    (if false
						(successor-instr false path index 'false next)
					      next))))))
	    ;; Decide whether to put the skips in the NAF or the NPC
	    (if skips
		(cond (must-be-naf-successor
		       (setf (mic-npc-successor micrel) skips)
		       (setq cpc-sel 2))
		      (t (setf (mic-naf-successor micrel) skips))))
	    (if must-be-naf-successor
	      (setf (mic-naf-successor micrel) must-be-naf-successor))
	    ;; Store the normal succescor (drop-through or jump or subroutine return)
	    ;; in NPC if it has to go there, or NAP if free to choose, or nowhere if
	    ;; not going to be used because next instruction reached via skip.
	    ;; Prefer the NAF over the NPC if neither is used to avoid introducing
	    ;; unnecessary address constraints.
	    (and (cond (return-skips		    ;Return address is a pair
			(setf (mic-npc-successor micrel) return-skips)
			nil)
		       ((fieldp code 'sequencer 'pushj) ;Need a return address always
			(setf (uic-npc-successor micrel) next)
			t)
		       (skips nil)			    ;Skip substitutes for next
		       (cpc-not-next nil)		    ;No successor required
		       (must-be-naf-successor	    ;NAF in use for something else
			(setf (sic-npc-successor micrel) next)
			(setq cpc-sel 2)
			t)
		       (t				    ;Normal next address
			(setf (mic-naf-successor micrel) next)
			t))
		 ;; Barf if drop through into nothing
		 (null next)
		 (not (fieldp code 'spec 'halt))	    ;sigh....
		 (not (get code 'error-table))	    ;a pushj that never popj's
		 (ferror nil "Drop into hyperspacs at ~S" (mic-tag micrel))))
	  (store-number micrel cpc-sel u-cpc-sel)
	  (store-number micrel npc-sel u-npc-sel)
	  (store-number micrel seq u-seq))
	micrel))
    (microsequence
     (assemble-microinstruction-plist1
      (link-microsequence-together (cdr code) eventual-successor) path index))
    (otherwise (ferror nil "Where did this alleged microcode come from?"))))

4,887,235
	139	140
(defun link-microsequence-together (l eventual-successor)
  (cond	((and (null (cdr l)) (null eventual-successor)) (car l))
	((get (car l) 'next-sequence)
	 (if (cdr l) (ferror nil "Something is wrong, next-sequence inside a sequence"))
	 (car l))				;jump instead of drop-through
	(t (list* 'microinstruction 'next-sequence
		  (if (cdr l) (link-microsequence-together (cdr l) eventual-successor)
		    eventual-successor)
		  (cdar l)))))		;Can't use putprop--it's destructive

(defun successor-instr (instr path index term &optional eventual-successor)
  (cond ((atom instr) instr) 		;NIL or a tag or a mic
	((null term)
	 (assemble-microinstruction-plist1 instr path (1+ index) eventual-successor))
	((zerop index)
	 (assemble-microinstruction-plist1 instr (append path (list term)) 0
					   eventual-successor))
	(t (assemble-microinstruction-plist1 instr (append path (list index term)) 0
					     eventual-successor))))

;NOTE: For arith. the Abus can't be 3 because that would cause a type trap
;      however, the Bbus can be 3 since it isn't fully type-checked.
(defconst *dispatch-cue-bit-masks*
	  (loop for (type cues) in '((arith (0 1 2 3 4 5 6 7 10 11 12 13))
				     (abus<2-0> (0 1 2 3 4 5 6 7))
				     (cdr-code (0 1 2 3)))
		collect (cons type (loop for c in cues
					 summing (lsh 1 c)))))

(defun successor-dispatch (table path index)
  (and table
       (let ((valid-cues (or (cdr (assq (car table) *dispatch-cue-bit-masks*)) 177777))
	     (cues-seen (dispatch-table-cues-used (cdr table))))
	 (cons 'dispatch
	       (loop for clause in (cdr table)
		     collect (list (convert-dispatch-cues (car clause) valid-cues cues-seen)
				   (successor-instr (cadr clause) path index (car clause))
				   ))))))

(defun dispatch-table-cues-used (clauses)
  (loop for clause in clauses with res = 0
	unless (eq (car clause) 'otherwise)
	do (loop for cue in (car clause)
		 do (setq res (logior (lsh 1 cue) res)))
	finally (return res)))

(defun convert-dispatch-cues (cues valid-cues cues-used)
  (if (eq cues 'otherwise)
      (loop for i from 0 to 17
	    unless (bit-test (lsh 1 i) cues-used)
	    when (bit-test (lsh 1 i) valid-cues)
	    collect i)
    (loop for cue in cues
	  unless (bit-test (lsh 1 cue) valid-cues)
	  do (ferror nil "~S invalid dispatch cue" cue))
    cues))

;Display a microinstruction (a mic code)
(defun disassemble-microinstruction (inst)
  (loop for (name ppss default) in *microinstruction-display-fields*
	as val = (ldb ppss inst)
	unless (and default (= val default))
	do (format t "~&  ~A = ~O" name val)))
(defun store-field (mic indicator value &optional no-error &aux entry)
  (cond ((setq entry (assq indicator *plist-to-mic-table*))
	 (lexpr-funcall (cadr entry) mic value (cddr entry)))
	((not no-error)
	 (ferror nil "I dont know how to store the ~S field" indicator))))

;Storing routines for particular fields/values

(defun store-number (mic value ppss)
  (setf (ldb ppss (mic-code mic)) value))

(defun store-choice (mic value ppss &rest choices)
  (setf (ldb ppss (mic-code mic)
	     (find-position-in-list value choices)))

(defun store-bit (mic ignore ppss bit)
  (setf (ldb ppss (mic-code mic)) bit))

(defun store-alu-func (mic value ppss)
  (store-number mic (or (find-position-in-list value normal-alu-functions)
			(find-position-in-list value weird-alu-functions))
		ppss))

(defun store-type-map (micrel map ignore)
  (setf (micrel-type-map micrel) map))

(defun store-stack-pointer (mic op enable-ppss)
  (setf (ldb enable-ppss (mic-code mic)) 1)
4,887,235
	141	142
(store-choice mic op u-amwa-11 'decrement 'increment))

(defun store-amem-read-addr (micrel addr &optional ignore)
  (cond ((atom addr)
	 (store-number micrel addr u-amra)
	 (store-number micrel 0 u-amra-sel))
	((eq (car addr) 'constant)
	 (setf (micrel-a-constant micrel) (cadr addr))
	 (store-number micrel 0 u-amra-sel))
	((eq (car addr) 'macrocode)
	 (store-number micrel 2 u-amra-sel)
	 (store-number micrel 3 u-r-base)
	 (store-number micrel 400 u-r-offset))
	((eq (car addr) 'bus-address)
	 (store-number micrel 1 u-amra-sel))
	(t (store-number micrel 2 u-amra-sel)
	   (store-number micrel (find-position-in-list (car addr)
				  '(stack-pointer frame-pointer xbas))
			 u-r-base)
	   (store-number micrel (logand (cadr addr) 377) u-r-offset))))

;This must not Clobber the bits that are don't cares for this particular address
;and also may be used for something else
(defun store-amem-write-addr (micrel addr &optional ignore)
  (cond ((atom addr)
	 (store-number micrel addr u-amwa)
	 (store-number micrel 0 u-amwa-sel))
	((eq (car addr) 'macrocode)
	 (store-number micrel 1 u-amwa-sel)
	 (store-number micrel 3 u-w-base)
	 (store-number micrel 400 u-w-offset))
	((eq (car addr) 'bus-address)
	 (store-number micrel 3 u-amwa-sel)
	 (store-number micrel 1 u-amwa-10))
	(t (store-number micrel 1 u-amwa-sel)
	   (store-number micrel (find-position-in-list (car addr)
				  '(stack-pointer frame-pointer xbas))
			 u-w-base)
	   (store-number micrel (logand (cadr addr) 377) u-w-offset))))

(defun store-bmem-addr (micrel addr ppss)
  (cond ((atom addr)
	 (store-number micrel addr ppss))
	((eq (car addr) 'constant)
	 (setf (micrel-b-constant micrel) (cadr addr)))))

(defun store-lbus-dev-addr (micrel addr ppss)
  (cond ((listp addr)
	 (push `(symbolic-lbus-slot ,(car addr)) (mic-load-time-patches micrel))
	 (setq addr (cadr addr))))
  (store-number micrel
		(if (numberp addr) addr
		  (+ (cdr (assq addr '((write-memory . 0)	;proto only
				       (write-phta-and-asn . 1)
				       (write-vma-and-pc .2)	;tmc only
				       (write-lru-map . 4)
				       (write-map-a . 5)
				       (write-map-b . 6)
				       (write-both-maps	. 7))))
		     37_5))
		ppss))

(defun store-mem-field (micrel mem ppss)
  (store-number micrel
		(or (find-position-in-list mem
		      (selectq *machine-version*
			       (proto '(nil continue write-vma start-cycle))
			       ((tmc tmc5) '(nil microdevice start-read start-write
					     nil write-vma block-read block-write))))
		    (ferror nil "~S illegal value for mem field" mem))
		ppss))

(defun store-speed (micrel speed ppss)
  (store-number micrel
		(cdr (assq speed '((slow-first-half .  2)
				   (slow-second-half . 1)
				   (slow . 1)
				   (very-slow . 3))))
		ppss))

;;;; Microinstruction linker -- outer module

(defun flush-microcode (*machine-version*)
  (setq *ucode-alist-alist* (delq (assq *machine-version* *ucode-alist-alist*)
				  *ucode-alist-alist*))
  t)

(defun link-the-microcode (*machine-version*)
  (clear-mic-tables)
  (format t "~&INTERN-LOADED-MICROCODE...")
  (loop for (name plist micrel)
4,887,235
	143	144
	   in (or (cdr (assq *machine-version* *ucode-alist-alist*))
		  (ferror nil "~S is not a loaded microcode program; ~{~S~^, ~} exist"
			  *machine-version*
			  (or (mapcar 'car *ucode-alist-alist*) '("none"))))
       do (intern-micrel micrel))
  do list (phase '(resolve-symbolic-references determine-address-constraints
		   assign-fixed-addresses
		   determine-block-successors determine-other-successors
		   assign-floating-addresses resolve-constants plug-in-successors))
    (format t "~&~S..." phase)
    (funcall phase))
;Report unimplemented instructions
  (loop for opcode from 0 to 1777
      as mic = (aref *microinstruction-memory* (* opcode 4))
      as name = (aref *opcode-table* opcode)
      when (and name (eq mic *undefined-opcode-standin*))
        collect name into undef
      finally (cond (undef
		     (format t "~&Defined but unimplemented instructions:~%   ")
		     (format:print-list t "~S" undef))))
  ;Check for overlapping scratchpad memory assignments (because it's so kludgey)
  (setq *a-memory-symbols* (sort *a-memory-symbols* #'(lambda (x y) (< (cdr x) (cdr y)))))
  (setq *b-memory-symbols* (sort *b-memory-symbols* #'(lambda (x y) (< (cdr x) (cdr y)))))
  (loop for (sym . loc) in *a-memory-symbols* and prev = -1 then loc and psym = nil then sym
  ;;XXXbrad <= below looked like one symbol in tiff
      when (<= *a-constant-starting-address* loc)
        when (< loc *a-constant-address*)
	  do (format t "~&The symbol ~S overlaps the constants area of A-memory" sym)
      when (= loc prev)
	do (format t "~&Symbols ~S and ~S are both defined at ~OeA" sym psym loc))
  (loop for (sym . loc) in *b-memory-symbols* and prev = -1 than loc and psym = nil then sym
      when (<= *b-constant-starting-address* loc)
	when (< loc *b-constant-address*)
	  do (format t "~&The symbol ~S overlaps the constants area of B-memory" sym)
	when (= loc prev)
	  unless (and (memq sym *b-temp-symbols*) (memq psym *b-temp-symbols*))
	    do (format t "~&Symbols ~S and ~S are both defined at ~OeB" sym psym loc))
  (setq *need-to-link* nil))

(defun file-linker-report (pathname)
  (with-open-file (standard-output pathname ':direction ':output)
    (linker-summary-report)
    (funcall standard-output ':tyo #\page)
    (linker-detailed-report)))

(defun linker-summary-report ()
  (memory-usage-report)
  (loop with n-micabs -
	(loop for bucket being the array-elements of *microinstruction-hash-table*
	      sum (length bucket))
	for mic being the array-elements of *microinstruction-memory*
	when (null mic) sum 1 into n-free-locs
	else when (eq mic *undefined-tag-standin*) sum 1 into n-undef-tags
	else when (eq mic *undefined-opcode-standin*) sum 1 into n-undef-ops
	else sum (micabs-multiplicity mic) into n-micrels
	 and sum 1 into n-micabs-locs
	finally
	 (format t "~D microinstructions interned into ~D instructions stored In ~D locations.
There are ~D free locations. ~D undefined-tag halt instructions, and
~D undefined-opcode halt instructions.~%"
		 n-micrels n-micabs n-micabs-locs n-free-locs n-undef-tags n-undef-ops))
  (loop for loc from 0 below *microinstruction-memory-size*
	when (null (aref *microinstruction-memory* loc))
	  count (and (zerop (logand loc *skip-increment*))
		     (null (aref *microinstruction-memory* (+ loc *skip-increment*))))
	        into n-free-skips
	  and when (zerop (logand (* 17 *dispatch-increment*) loc))
	        count (loop repeat 20 for loc from loc by *dispatch-increment*
			    always (null (aref *microinstruction-memory* loc)))
		into n-free-dispatches
      finally (format t "There are ~D free skip blocks (out of 4096)~e
                         and ~D free dispatch blocks (out of 512).~%"
		      n-free-skips n-free-dispatches))
  (format t "Number of microinstructions with speed")
  (dotimes (i 4)
    (format t "~YT~D" (+ 40. (* i 8)) i))
  (terpri)
  (dotimes (i 4)
    (format t "~YT~D" (+ 40. (* i 8)) (aref *speed-histogram* i)))
  (terpri))

(defun linker-detailed-report ()
  (format t "~%Locations of microcode routines' first microinstructions:~2%")
  (format t "~40A ~A~2%" "Symbol" "Locations")
  (loop for (tag . mic) in (sortcar (copylist *microinstruction-tag-alist*) #'string-lessp)
	do (format t "~40A " tag)
	(format:print-list t "~5,'0D" (micabs-addresses mic) "  " "~41X")
	(terpri))
  (format t "~{~%Sharing of separate but identical microinstructions in source code:~2%")
  (format t "~40A ~A~2%" "Representative tag" "Multiplicity from source")
  (loop for (tag . mult)
	in (sort (loop for bucket being the array-elements
		       of *microinstruction-hash-table*
4,887,235
	145	146
			   nconc (loop for mic in bucket
				       when (> (micabs-multiplicity mic) 1)
					       collect (cons (mic-tag mic)
							     (micabs-multiplicity mic))))
		     #'(lambda (x y)
			 (or (> (cdr x) (cdr y))
			     (and (= (cdr x) (cdr y))
				  (alphalessp (car x) (car y))))))
        do (format t "~40A ~D~%" tag mult))
  (format t "~|~%Microinstructions that had to be stored in more than one cmem. location:~2%")
  (format t "~40A ~A~2%" "Representative tag" "Multiplicity in control memory")
  (loop for (tag . multi)
            in (sort (loop for bucket being the array-elements
			   		    of *micro-instruction-hash-table*
			   nconc (loop for mic in bucket
				       when (cddr (micabs-addresses mic))
					 collect (cons (mic-tag mic)
						       (length (micabs-addresses mic)))))
		     #'(lambda (x y)
			 (or (> (cdr x) (cdr y))
			     (and (= (cdr x) (cdr y))
				  (alphalessp (car x) (car y))))))
        do (format t "~40A ~D~%" tag mult))
  (format t "~|~%Control-memory map:~2%~10A~35A~10A~A~2%"
            "Location" "Representative tag" "Location" "Representative tag")
  (loop for mic being the array-elements of *microinstruction-memory*
		      using (index loc) with phase = nil
        unless (null mic)
	  unless (eq mic *undefined-opcode-standin*) do
	    (format t "~5,'0O  ~A" loc (mic-tag mic))
	    (if phase (terpri)
	      (let* ((curcol (+ 7 (flatc (mic-tag mic))))
		     (destcol (max (+ curcol 1) 45.))
		     (ntabs (// (- (logior destcol 7) curcol) 8)))
		(loop repeat ntabs
		      do (funcall standard-output ':tyo #\tab))
		(loop repeat (\ (if (zerop ntabs) (- destcol curcol) destool) 8)
		      do (funcall standard-output ':tyo #\sp))))
          (setq phase (not phase))
      finally (if phase (terpri))))

(defun memory-usage-report ()
  (send standard-output ':fresh-line)
  (if (boundp *a-constant-address*)	;Linker has been run
      (format t "A-memory locations ~O-~O used for constants (~O end of constants area)~%"
	      *a-constant-starting-address* (1- *a-constant-address*)
	      (1- *a-constant-ending-address*)))
  (format t "A-memory locations")
  (report-a-b-memory-locations *a-memory-symbols*)
  (format t " used for variables~%")
  (if (boundp '*b-constant-address*)	;Linker has been run
      (format t "B-memory locations ~O-~O used for constants (~O end of constants area)~%"
	      *b-constant-starting-address* (1- *b-constant-address*)
	      (1- *b-constant-ending-address*)))
  (format t "B-memory locations")
  (report-a-b-memory-locations *b-memory-symbols*)
  (format t " used for variab1es~%")
  (format t "Type-map locations 0-~O used (77 end of type map)~%"
	  (1- (length *type-maps*))))

(defun report-a-b-memory-locations (l)
  (setq l (sort (mapcar #'cdr l) #'<))
  (loop while l
	as loc = (pop l)
	as oldl = loc
	for n upfrom 1
	do (cond ((= n 6)
		  (setq n 0)
		  (send standard-output ':tyo #\cr)
		  (send standard-output ':tyo #\tab)))
	(format t " ~O" loc)
	(loop while l
	      while (or (= (car l) loc) (= (car l) (1+ loc)))
	      do (setq loc (pop l)))
	(or (= loc oldl)
	    (format t "-~O" loc))))

;;;; Microinstruction linker -- intern, assign constants

(defun clear-mic-tables ()
  (copy-array-portion *microinstruction-hash-table* 0 0		;Fill with NIL
		      *microinstruction-hash-table* 0
		      (array-length *microinstruction-hash-table*))
  (copy-array-portion *microinstruction-memory* 0 0		;Fill with NIL
		      *microinstruction-memory* 0 (array-length *microinstruction-memory*))
  (clrhash-equal *a-constant-hash-table*)
  (setq *a-constant-address* *a-constant-starting-address*)
  (clrhash-equal *b-constant-hash-table*)
  (setq *b-constant-address* *b-constant-starting-address*)
  (dotimes (i 4)
    (aset 0 *speed-histogram* i))
4,887,235
	147	148
  (clrhash-equal *address-block-hash-table*)
  (setq *address-block-list* nil)
  (setq *microinstruction-tag-alist* nil))
		;--- Would also clear type map assignments, but would break simulator

;Given a micrel return a micabs, the canonical representative of all micrels to
;be stored in the same location as it. This also does constant assignment.
(defun intern-micrel (micrel)
  (let ((code (mic-code micrel)))
    (if (micrel-a-constant micrel)
	(setf (ldb u-amra code) (locate-a-constant (micrel-a-constant micrel))))
    (if (micrel-b-constant micrel)
	(setf (ldb u-bmra code) (locate-b-constant (micrel-b-constant micrel))))
    (if (micrel-type-map micrel)
	(setf (ldb u-type-map-sel code) (assign-type-map (micrel-type-map micrel))))
						;defined in UL
    (let ((ans (let ((hash (\ code (array-length *microinstruction-hash-table*))))
		 (loop for candidate in (aref &microinstruction-hash-table* hash)
		       when (and (= (mic-code candidate) code)
				 (compatible-tags (mic-tag candidate) (mic-tag micrel))
				 (equal (mic-load-time-patches candidate)
					(mic-load-time-patches micrel))
				 (compatible-address-constraints
				  (mic-address-constraints candidate)
				  (mic-address-constraints micrel))
				 (equal-successor (micabs-original-npc-successor candidate)
						  (mic-npc-successor micrel))
				 (equal-successor (micabs-original-naf-successor candidate)
						  (mic-naf-successor micrel))
				 (compatible-error-table-entries (mic-error-table candidate)
								 (mic-error-table micrel)))
		       do (incf (micabs-multiplicity candidate)) and
		       return (merge-tags-and-address-constraints candidate micrel)
		     finally
		       (let ((micabs (make-micabs code code tag (mic-tag micrel)
				      error-table (mic-error-table micrel)
				      load-time-patches (mic-load-time-patches micrel)
				      address-constraints (mic-address-constraints micrel)
				      npc-successor
				        (intern-successor (mic-npc-successor micrel))
				      original-npc-successor (mic-npc-successor micrel)
				      naf-successor
				        (intern-successor (mic-naf-successor micrel))
				      original-naf-successor (mic-naf-successor micrel))))
			 (push micabs (aref *microinstruction-hash-table* hash))
			 (incf (aref *speed-histogram* (ldb u-speed code)))
			 (return micabs))))))
      (if (symbolp (mic-tag ans))	;i.e. not a generated tag
	  (push (cons (mic-tag ans) ans) *microinstruction-tag-alist*))
      ans)))

(defun intern-successor (succ)
  (cond ((symbolp succ) succ)			;NIL or a tag
	((atom succ) (intern-micrel succ))	;a micrel
	((eq (car succ) 'skip)
	 (mapcar #'intern-successor succ))
	((eq (car succ) 'dispatch)
	 (cons 'dispatch
	       (loop for (cues mic) in (cdr succ)
		     collect (list cues (intern-successor mic)))))
	 (t (ferror nil "Hey! Who turned Out the lights?"))))

;All generated tags are compatible with each other, user doesn't care
(defun compatible-tags (t1 t2)
  (or (eq t1 t2)
      (listp t1)
      (listp t2)))

(defun compatible-address-constraints (c1 c2)
  (cond ((eq c1 'unique) nil)
	((eq c2 'unique) nil)
	((null c1) t)
	((null c2) t)
	((atom c1) (if (atom c2) (equal c1 c2) (member c1 c2)))
	((atom c2) (member c2 c1))
	((< (length c1) (length c2)) (loop for c in c1 always (member c c2)))
	(t (loop for c in c2 always (member c c1)))))

(defun merge-tags-and-address-constraints (into from)
  (let ((c1 (mic-address-constraints into))
	(c2 (mic-address-constraints from)))
    (cond ((null c2))
	  ((null c1) (setf (mic-address-constraints into) c2))
	  (t (let ((con (if (atom c1) (list c1) c1)))
	       (if (atom c2) (or (member c2 c1) (push c2 c1))
		 (loop for c in c2
		       unless (member c c1)
		       do (push c c1)))
	       (setf (mic-address-constraints into)
		     (if (null (cdr con)) (car con) con))))))
  (and (listp (mic-tag into))
4,887,235
	149	150
       (or (not (lists (mic-tag from)))
	   (better-tag (mic-tag from) (mic-tag into)))
       (setf (mic-tag into) (mic-tag from)))
  (setf (mic-error-table into)
	(merge-error-table-entries (mic-error-table into)
				   (mic-error-table from)))
  into)

(defun better-tag (tag1 tag2)
  (cond ((< (length tag1) (length tag2)) t)
	((> (length tag1) (length tag2)) nil)
	(t (< (string-length (car tag1)) (string-length (car tag2))))))

(defun equal-successor (s1 s2)
  (cond ((atom s1) (eq s1 s2))
	((atom s2) nil)
	((neq (car s1) (car s2)) nil)
	((eq (car s1) 'skip)
	 (and (equal-successor (cadr s1) (cadr s2)) (equal-successor (caddr s1) (caddr s2))))
	((eq (car s1) 'dispatch)
	 (loop for clause1 in (cdr s1) and clause2 in (cdr s2)
	       always (and (equal (car clausel) (car clause2))
			   (equal-successor (cadr clausel) (cadr clause2)))))))

(defun locate-a-constant (value)
  (if (numberp value)
      (setq value (logand (mask 36.) value)))
  (cond ((gethash-equal value *a-constant-hash-table*))
	(t (let ((res *a-constant-address*))
	     (if (= *a-constant-address* *a-constant-ending-address*)
		 (ferror nil "A-memory constants area overflow"))
	     (incf *a-constant-address*)
	     (puthash-equal value res *a-constant-hash-table*)
	     res))))

(defun locate-b-constant (value)
  (if (numberp value)
      (setq value (logand (mask 34.) value)))
  (cond ((gethash-equal value *b-constant-hash-table*))
	(t (let ((res *b-constant-address*))
	     (if (= *b-constant-address* *b-constant-ending-address*)
		 (ferror nil "B-memory constants area overflow"))
	     (inof *b-constant-address*)
	     (puthash-equal value ret *b-constant-hash-table*)
	     res))))

;;; Microinstruction Linker -- fix up after interning everything

;Go through and replace tags and drop with mics
(defun resolve-symbolic-references ()
  (setq *undefined-tag-standin* (make-micabs tag 'undefined-tag-standin))
  (store-field *undefined-tag-standin* spec 'halt)
  (setq *unresolved-symbolic-references* nil)
  (loop for bucket being the array-elements of *microinstruction-hash-table* do
    (loop for mic in bucket do
      (setf (mic-npc-successor mic)
	    (resolve-symbolic-successor mic (mic-npc-successor mic) nil))
      (setf (mic-naf-successor mic)
	    (resolve-symbolic-successor mic (mic-naf-successor mic) (mic-npc-successor mic)))
      ))
  (cond (*unresolved-symbolic-references*
	 (format t "~&The following microcode routines were referenced ~
		      but don't seem defined:")
	 (dolist (x *unresolved-symbolic-references*)
	   (format t "~& ~S referenced by " (car x))
	   (format:print-list t "~S" (cdr x))
	   (format t "~&")))))

(defun resolve-symbolic-successor1 (mic succ drop-through)
  (cond ((null succ)
	 (or drop-through
	     (cerror t nil nil "drop-through successor to ~S, but nothing there!"
		     (mic-tag mic))))
	(t (resolve-symbolic-successor mic succ drop-through))))

(defun resolve-symbolic-successor (mic succ drop-through)
  (cond ((null succ) nil)
	((symbolp succ)
	 (or (cdr (assq succ *microinstruction-tag-alist*))
	     (let ((elem (assq succ *unresolved-symbolic-references*)))
	       (or eleme (push (setq elem (ncons succ)) *unresolved-symbolic-references*))
	       (push (mic-tag mic) (cdr elem))
	       *undefined-tag-standin*)))
  ((atom succ) succ)			;A micabs
  ((eq (car succ) 'skip)
   `(skip ,(resolve-symbolic-successor1 mic (cadr succ) drop-through)
	  ,(resolve-symbolic-successor1 mic (caddr succ) drop-through)))
  ((eq (cab succ) 'dispatch)
   `(dispatch
     . ,(loop for (cues mic2) in (cdr succ)
	      collect `(,cues ,(resolve-symbolic-successor1 mic mic2 nil)))))))
4,887,235
	151	152
;;;; Microinstruction linker -- determine address constraints

(defun make-address-block (kind &aux length mask block)
  (selectq kind
    (skip (setq length 2 mask *skip-incremetal*))
    (dispatch (setq length 20 mask (* 17 *dispatch-increment*)))
    (dispatch-skip (setq length 40 mask (+ (s 17 *dispatch-increment*) *skip-increment*)))
    (otherwise (ferror nil "Huh?")))
  (setq block (make-address-block-internal kind kind :make-array (:length length)))
  (setf (address-block-bit-mask block) mask)
  (push block *address-block-list*)
  block)

(defun intern-address-block (kind alist)
  (setq alist (sortcar alist #'<))	;Canonical ordering
  (or (gethash-equal alist *address-block-hash-tables*)
      (let ((block (make-address-block kind)))
	(puthash-equal alist block *address-block-hash-tables*)
	(loop for (pos . mic) in alist
	      do (store-into-block mic block pos))
	block)))

(defun store-into-block (mic block pos)
  (aset mic block pos)
  (pushnew block (micabs-blocks mic)))

;Convert the successors that are blocks from the list-structure form used
;in micrels to the address-block defetruct. Also create predecessor back-links.
(defun determine-address-constraints ()
  (loop for bucket being the array-elements of *microinstruction-hash-table* do
	(loop for mic in bucket do
	      (setf (mic-npc-successor mic) (convert-successor (mic-npc-successor mic) mic))
	      (setf (mic-naf-successor sic) (convert-successor (mic-naf-successor mic) nil)))))

(defun convert-successor (succ predecessor)
  (cond ((atom succ)			;NIL, a tag, or a micabs
	 (and succ predecessor
	      (pushnew predecessor (micabs-predecessors succ)))
	 succ)
	((eq (car succ) 'skip)
	 (let ((block (intern-address-block 'skip
					    (list (cons 0 (cadr succ))
						  (cons 1 (caddr succ))))))
	   (if predecessor (pushnew predecessor (address-block-mic-predecessors block)))
	   block))
	((eq (car succ) 'dispatch)
	 (if predecessor (ferror nil "read unhappy maknam"))
	 (intern-address-block 'dispatch
			       (loop for (cues mic) in (cdr succ) nconc
				     (loop for cue in cues
					   collect (cons cue mic)))))
	(t (ferror nil "Hey! Who turned out the lights?"))))

;Now that all of the blocks have been made, determine their successor relations.
;This may make new blocks, since unlike mice each block is only stored in one place.

;First passe find all npc (consecutive address) relations between blocks.
; To avoid complications we always make new blocks to act as successors, but
; mark them as aliases of the old blocks so that later we can only instantiate
; one copy, if possible.
(defun determine-block-successors ()
  ;; This loop repeats until no new address blocks are created
  (loop for already-done = nil then previous-address-block-list
	as previous-address-block-list = *address-block-list*
	until (eq *address-block-list* already-done)
	do ;; This loop does each address block that was not done before
	(loop for lst = *address-block-list* then (cdr let) until (eq lst already-done)
	      as block = (car lst)
	      ;; Does any mic in this block have an npc successor?
	      as npc-successors-exist =
	           (loop for mic being the array-elements of block
			 thereis (and mic (typep (mic-npc-successor mic) 'micabs)))
	      as skip-successors-exist =
		   (loop for mic being the array-elements of block
			 thereis (and mic (typep (mic-npc-successor mic) 'address-block)))
	      as kind = (address-block-kind block)
	      when (or npc-successors-exist skip-successors-exist) do
	        (let ((succ (make-address-block
			     (if (and skip-successors-exist (eq kind 'dispatch))
				 'dispatch-skip kind))))
		  (setf (address-block-predecessor succ) block)
		  (setf (address-block-successor block) succ)
		  (loop for mic being the array-elements of block using (index pos)
			with skip-step = (if (eq kind 'skip) 1 20)
			as succ1 = (and sic (mic-npc-successor sic))
			when (typep succ1 'micabs)
			  do (store-into-block succ1 succ pos)
			else when (typep succ1 'address-block)
			  do (push (list succ (\ pos skip-step))
				   (address-block-aliases succ1))
			  (loop for succ1 being the array-elements of succ1
