4,887,235
	153	154
				and pos upfrom (\ pos skip-step) by skip-step
				do (store-into-block succ1 succ pos)))))))

;Second pass -- find blocks with npc-predecessor mics that are not in blocks
; and consequently weren't seen in the first pass. Also find blocks with
; component mics with npc-predecessor mics. In either case we create a new
; block and make it the pedecessor of the found block. In the first case
; this completes the data structure that tells us what size and shape hole
; we need to find in control memory; in the second case it avoids unnecessarily
; making two copies of a mic.
; However, if the alternative to making two copies of a mic is to create a chain
; of 5 skip blocks in a row, which cannot be located when we have 8K control
; memory, then we would rather duplicatc the mic.
(defun determine-other-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 lst) until (eq 1st already-done)
	      as block = (car lst)
	      as chain-length = (loop as b = block then (address-block-successor b)
				      while b
				        while (eq (address-block-kind b) 'skip)
				          count t)
	      as block-predecessors =
	           (loop for mic in (address-block-mic-predecessors block)
			 when (and (null (micabs-blocks mic))
				   (symbolp (mic-address-constraints mic))) ;NIL or UNIQUE
			   unless (memq mic res)
			     collect mic into res
			 finally (return res))
	      as other-predecessors = 
	           (loop for mic being the array-elements of block
			 unless (null mic)
			   nconc (loop for mic in (micabs-predecessors mic)
				       when (symbolp (mic-address-constraints mic))
				         when (< (+ (max-predecessor-chain-length mic)
						    chain-length)
						 5)
					 unless (memq mic res)
					   collect mic)
			         into res
			   finally (return res))
	       as predb = (address-block-predecessor block)
	       with slot do
	   ;;--- I'm fairly sure that I don't need to worry about aliases here
	   ;; What we want to do is first store all the block-predecessors then
	   ;; fill in the available gaps with other-predecessors. However the
	   ;; other-predecessors have stronger address requirements. So we will
	   ;; first do the block-predecessors, which may leave one location left
	   ;; over for other-predecessors. After that, fill in any available holes
	   ;; with other-predecessors, or create a new predecessor block.
	   (loop for mic in block-predecessors do
	     ;; Find a place to put this predecessor, by force if necessary
	     (loop doing (multiple-value (predb block)
			   (make-address-block-predecessor block predb))
		   until (loop for pos from 0 below (array-length predb)
			       when (null (aref predb pos))
			         return (setq slot pos))
		   do (setq predb nil)) ;This predb used up, make new one
	     (store-into-block mic predb slot))
	   ;; If a predecessor exists, and free slots fortuitously exist in the right
	   ;; places, fill them with the other-predecessors. If no predecessor exists,
	   ;; and there are other-predecessors, it can't hurt (much!) [sic] to make one.
	   (cond (other-predecessors
		  (multiple-value (predb block)
		    (make-address-block-predecessor block predb))
		  (loop for mic in other-predecessors
			as target = (mic-npc-successor mic)
			when (loop for succ being the array-elements of block using (index pos)
				   thereis (and (eq succ target)
						(null (aref predb (setq slot pos)))))
			do (store-into-block mic predb slot)))))))

;Make a block to preceed the given block, if necessary.
;If the second argument is non-NIL (we already have a predecessor available),
;then don't make a new one, except if this block is already located, in which
;case we make a copy of it and a predecessor of the copy. This is necessary
;when the block's predecessor is a mic at a fixed address.
;lf the second argument is NIL, then make a predecessor. If the block already
;has a predecessor, make a copy of the block so that a second predecessor can exist.
;Two values: the preceding and succeeding blocks
(defun make-address-block-predecessor (block predb)
  (prog ()
    (if (if (null predb)
	    (address-block-predecessor block)
	  (or (address-block-locations block)
	      (return predb block)))
	(setq block (copy-address-block block)))
    (let ((predb (make-address-block (address-block-kind block))))
      (setf (address-block-successor predb) block)
4,887,235
	155	156
	(setf (address-block-predecessor block) predb)
	(return (values predb block)))))

;Copy a block (and its successors) when space preceding the block is overcrowded
(defun copy-address-block (block &aux new)
  (setq new (make-address-block (address-block-kind block)))
  (push (list new 0) (address-block-aliases block))
  (loop for mic being the array-elements of block using (index pool)
	do (store-into-block mic new pos))
  (cond ((address-block-successor block)
	 (setq block (copy-address-block (address-block-successor block)))
	 (setf (address-block-predecessor block) new)
	 (setf (address-block-successor new) block)))
  new)

(defun max-predecessor-chain-length (mic)
  (let ((preds (micabs-predecessors mic)))
    (if (null preds) 1	;This test is unnecessary in the old loop by coincidence
      (1+ (loop for mic in preds	;and superfluous in the new
		maximize (max-predecessor-chain-length mic))))))
;;;; Microinstruction linker -- address assignment

(defun assign-fixed-addresses ()
  (setq *undefined-opcode-standin* (make-micabs tag '*undefined-opcode-standin*))
  (store-field *undefined-opcode-standin* 'spec 'halt)
  ;; Store halts in the dispatch locations for all undefined opcodes
  ;; and all defined but unimplemented cpcodes
  (loop with ucode-alist = (cdr (assp *machine-version* *ucode-alist-alist*))
	for i from 0 to 1777 		;Opcode dispatch
	unless (and (= i 376) (eq *machine-version* 'proto))	;no-operand-subdispatch
	  unless (assq (aref *opcode-table* i) ucode-alist)
	    do (aset *undefined-opcode-standin* *microinstruction-memory* (lsh i 2)))
  ;; Store any microinstructions that have no freedom of location at all
  (loop for bucket being the array-elements of *microinstruction-hash-table* do
    (loop for mic in bucket
	  as con = (mic-address-constraints mic)
	  do (cond ((numberp con) (locate-inst mic con))
		   ((listp con) (dolist (loc con) (locate-inst mic loc))))))
  ;; Now go fill in any unused reserved locations with a halt instruction
  ;; so that no floating instructions will float into them
  (selectq *machine-version*
    (proto
     (store-default-inst 10000 *undefined-opcode-standin*)	;Transport trap
     (loop for i from 10010 to 10015 	;Type trap (4 locs), map miss (2 locs)
	   do (store-default-inst i *undefined-opcode-standin*))
     (loop for i from 10020 to 10022	;IFU exceptions?
	   do (store-default-inst i *undefined-opcode-standin*)))
    ((tmc tmc5)
     (loop for mem-state from 0 to 30 by 10 do
	   (loop for i in '(0 1 4 5 6 7) do
	     (store-default-inst (logior 10000 mem-state 1) *undefined-opcode-standin*)))
     (store-default-inst 14000 *undefined-opcode-standin*)	;IFU traps
     (store-default-inst 16000 *undefined-opcode-standin*))
    (otherwise (ferror nil "What are the trap addresses for ~S?" *machine-version*))))

(defun assign-floating-addresses (&aux (freep 0))
  ;; Now pack the address blocks into available free spaces
  (assign-address-blocks)
  ;; Now pack npc-chains of instructions not involving any blocks
  (assign-npc-chains)
  ;; Now assign any remaining instructions arbitrarily
  (loop for bucket being the array-elements of *microinstruction-hash-table* do
	(loop for mic in bucket
	      do (setq freep (assign-floating-mic mic freep))))
  (if *unresolved-symbolic-references*
      (setq freep (assign-floating-mic *undefined-tag-standin* freep))))

(defun assign-floating-mic (mic freep)
  (or (micabs-addresses mic)
      (locate-inst mic
		   (loop until (null (aref *microinstruction-memory* freep))
			 do (incf freep)
			 (if (>= freep *microinstruction-memory-size*)
			     (ferror nil "Gleep! Microinstruction memory overflows"))
			   finally (return freep))))
      freep)

(defun locate-inst (mic bc &aux tem)
  (cond ((null (setq tem (aref *microinstruction-memory* loc)))
	 (aset mic *microinstruction-memory* loc)
	 (push loc (micams-addresses mic))
	;If this is somebody's predecessor, he is now absolutely constrained.
	 (let ((succ (mic-npc-successor mic)))
	   (cond ((typep succ 'micabs)
		  (locate-inst succ (npc-next-loc loc)))
		 ((typep succ 'address-block)
		  (locate-address-block succ
					(logand (npc-next-loc loc)
						(lognot (address-block-bit-mask succ))))))))
4,887,235
	157	158
	((neq tem mic)
	 (ferror nil "Two different microinstructions trying to go in same location;~e
		     ~S and ~S"
		 (mic-tag mic) (mic-tag tem)))))

;Note that this does not remember the location nor link to successors
;Use this only for "fake" mic's
(defun store-default-inst (loc mic)
  (or (aref *microinstruction-memory* loc)
      (aset mic *microinstruction-memory* loc)))

(defun npc-next-loc (loc)
  (+ (* (//I loc *npc-modulus*) *npc-modulus*)
     (\	(+ loc *npc-increment*) *npc-modulus*)))

;I don't really want to solve the general bin-packing problem, so I guess I will
;just assign the largest blocks first, and assign down from the top of memory,
;and hope for the best. Doesn't fill holes in big blocks with little blocks!
;--- I'm fairly sure this is going to have to done over in a cleverer way
;    Well. it seems to work, doesn't it....
(defun assign-address-blocks ()
  ;; Largest blocks first. But only blocks without predecessors, and not
  ;; unnecessary duplicate aliases, need be located,
  (loop for block in (sort (loop for block in *address-block-list*
				 when (and (null (address-block-predecessor block))
					   (null (address-block-aliases block))
					   (null (address-block-locations block)))
				 collect block)
			   #'(lambda (b1 b2)
			       (> (address-block-size b1) (address-block-size b2))))
	with disp-freep = (- *microinstruction-memory-size* (* 17 *dispatch-increment*))
	with skip-freep = (- *microinstruction-memory-size* *skip-increment*)
	when (eq (address-block-kind block) 'skip)
	  do (setq skip-freep (find-space-for-block block skip-freep))
	  else do (setq disp-freep (find-space-for-block block disp-freep))))

(defun address-block-size (block)
  (if (address-block-successor block)
      (+ (array-length block) (address-block-size (address-block-successor block)))
    (array-length block)))

(defun find-space-for-block (block freep)
  (do ((b block (address-block-successor b))
       (bits 0 (logior (address-block-bit-mask b) bits))
       (width 0 (max (array-length b) width))
       (length 0 (1+ length)))
      ((null b)
       (decf freep length)
       (loop when (minusp freep)
	     do (error 'microinstruction-memory-overflow
		       ':msg (format nil "Cannot locate chain of ~D blocks" length)
		        ':chain-head block)
	     until (loop repeat length for pos upfrom freep
			 always (loop for pos upfrom pos by (logand bits (- bits))
				      repeat width	;skip/dspatch bits are adjacent!
				      always (null (aref *microinstruction-memory* pos))))
	     do (decf freep))
       (locate-address-block block freep)
       freep)))

;Locate all of the instructions in this address block, based on bc
;Note that an address-block can get located twice, if it is an npc-successor
;of two mic's both with fixed address constraints.
(defun locate-address-block (block loc)
  (push loc (address-block-locations block))
  (loop for mic being the array-elements of block
	as pos upfrom loc by (if (eq (address-block-kind block) 'skip)
				 *skip-increment* *dispatch-increment*)
	unless (null mic)
	do (locate-inst mic pos))
  (if (address-block-successor block)
      (locate-address-block (address-block-successor block) (npc-next-loc loc))))

;Find all microinstruction chains that must be in consecutive addresses
;and are not already located (none of them are in blocks and the head of
;the chain is not assigned to a fixed address). Find places in memory
;to stuff them.
(defun assign-npc-chains ()
  :; This loop iterates over all unlocated chain hoads, longest chains first
  (loop for (length . mic)
	in (sortcar (loop for bucket being the array-elements
			  of *microinstruction-hash-table*
			  nconc (loop for mic in bucket
				      when (and (null (micabs-addresses mic))
						(null (micabs-predecessors mic))
						(typep (mic-npc-successor mic) 'micabs))
				        collect (cons (mic-npc-chain-length mic) mic)))
		    #'>)
	with freep = 0
	do (locate-inst mic (setq freep (find-space-for-chain freep length mic)))
	   (incf freep length)))
4,887,235
	159	160
(defun mic-npc-chain-length (mic)
  (loop for mic = mic then (mic-npc-successor mic) until (null mic)
	count t))

(defun find-space-for-chain (freep length mic)
  (loop with block-start = nil
	for freep upfrom freep by 1
	when (>= freep *microinstruction-memory-size*)
	do (error 'microinstruction-memory-overflow
		  ':msg (format nil "Can't locate ~D-entry NPC chain of microinstructions"
				length)
		  ':chain-head mic)
	when (null (aref *microinstruction-memory* freep))
	  do (cond ((null block-start) (setq block-start freep))
		   ((zerop (logand 377 freep)) (setq block-start freep))
		   ((= (- (1++ freep) block-start) length) (return block-start)))
	  else do (setq block-start nil)))

;A debugging function
(defun print-chain (mic-or-block) ;or nil
  (typecase mic-or-block
    (micabs
     (format t "~&MIC: ~A" (mic-tag mic-or-block))
     (print-chain (mic-npc-successor mic-or-block)))
    (address-block
     (format t "~&~A-BLOCK[~O]: "
	     (address-block-kind mic-or-block) (array-length mic-or-block))
     (format:print-list standard-output "~A"
			(loop for mic being the array-elements of mic-or-block
			      collect (if mic (mic-tag mic) "-")))
     (print-chain (address-block-successor mic-or-block)))))

(defflavor microinstruction-memory-overflow (msg chain-head) (error)
  :initable-instance-variables)

(defmethod (microinstruction-memory-overflow :report) (stream)
  (format stream "Gleep! Microinstruction memory overflow~%~A~%The chain is:~%" msg)
  (let ((standard-output stream)
	(prinlength nil))
    (print-chain chain-head)))

(compile-flavor-methods microinstruction-memory-overflow)
;;;; Microinstruction linker -- plug in successor addresses

(defun plug-in-successors ()
  (loop for loc from 0 below *microinstruction-memory-size* with succ
	as mic = (aref *microinstruction-memory* loc)
	unless (null mic)
	do (if (setq succ (mic-naf-successor mic))
	       (store-number mic (get-mic-or-block-address succ) u-naf))
	(if (setq succ (mic-npc-successor mic))
	    (cond ((typep succ 'micabs)
		   (or (eq (aref *microinstruction-memory* (npc-next-loc loc)) succ)
		       (ferror nil "~S's npc-successor isn't there!" (mic-tag mic))))
		  ((typep succ 'address-block)
		   (or (address-block-effectively-at
			succ
			(logand (npc-next-loc loc)
				(lognot (address-block-bit-mask succ))))
		       (ferror nil "~S's npc-successor isn't there!" (mic-tag mic))))))))

(defun get-mic-or-block-address (x)
  (cond ((typep x 'micabs) (car (micabs-addresses x)))
	((typep x 'address-block)
	 (or (car (address-block-locations x))
	     (let ((alias (caar (address-block-aliases x))))
	       (+ (get-mic-or-block-address alias)
		  (* (cadar (address-block-aliases x))
		     (logand (address-block-bit-mask alias)
			     (- (address-block-bit-mask alias))))))))))

(defun address-block-effectively-at (block loc)
  (or (memq loc (address-block-locations block))
      (loop for (b offset) in (address-block-aliases block)
	    thereis (address-block-effectively-at b
		      (+ (* offset (logand (address-block-bit-mask b)
					   (- (address-block-bit-mask b))))
			 lo)))))

(defun resolve-constants ()
  (setq *a-constant-list* (resolve-constants1 *a-constant-hash-table*))
  (setq *b-constant-list* (resolve-constants1 *b-constant-hash-table*)))

(defun resolve-constants1 (hash-table)
  (local-declare ((special constants))
    (let ((constants nil))
      (maphash-equal #'(lambda (val loc)
			 (push (cons loc
4,887,235
	161	162
	(cond ((numberp val) val)
	      ((and (listp val) (eq (car val) 'build-task-state))
	       (resolve-task-state (cdr val)))
	      (t (ferror "~S illegal constant" val))))
			       constants))
		     hash-table)
      constants)))

(defun resolve-task-state (options)
  (let ((cpc nil) (npc nil) (csp 17))
    (loop for (opt val) on options by 'cddr do
	  (selectq opt
		   (cpc (setq cpc (resolve-cues-location val)))
		   (npc (setq npc (resolve-cmem-location val)))
		   (csp (setq cop val))
		   (otherwise (ferror "~S illegal in BUILD-TASK-STATE" opt))))
    (or cpc (ferror "CPC not specified in ~S" (cons 'build-task-state options)))
    (or npc (setq npc (dpb (1+ cpc) 0010 cpc)))
    (dpb csp 3404 (dpb npc 1616 cpc))))

(defun resolve-cmem-location (loc &aux mic)
  (cond ((symbolp loc)
	 (if (setq mic (cdr (assq loc *microinstruction-tag-alist*)))
	     (car (micabs-addresses mic))
	   (format error-output "~&WARNING: ~S not found for build-task-state~%" loc)
	   0))
	((numberp loc) loc)
	((and (listp loc) (eq (car loc) 'npc-successor))
	 (setq loc (resolve-cmem-location (cadr loc)))
	 (dpb (1+ loc) 0010 loc))
	(t (ferror "~S illegal cmem-location for build-task-state" loc))))

;;;; File interface

(defun new-microcode-version ()
  (let ((si::*system-being-made* (si:find-system-named "MICROCODE"))
	(si::silent-p: nil))
    (si:increment-compiled-version-1)
    (si:increment-loaded-version-1)))

;--- Someday these might be a MAKE-SYSTEM transformation

(defun compile-the-microcode (*machine-version*)
  (write-the-microcode *machine-version* t))

(defun write-the-microcode (*machine-version*
			    &optional (link-p nil)
				      (name (string-append *machine-version* "-MIC"))
				      (version (si:get-system-version "MICROCODE")))
  (or (boundp 'lcold:*most-negative-immediate-number*)
      (icold:setup-crucial-variables nil))
  (let ((patnname (fs:make-pathname ':host "SYS" ':directory "L-UCODE"
				    ':name name ':version version)))
    (with-open-file (log (funcall pathname ':new-type "LOG") '(:print))
      (let ((standard-output (make-broadcast-stream log standard-output)))
	(if link-p (link-the-microcode *machine-version*))

	;; Write out various files
	(write-mic-file (funcall pathname ':new-type "MIC") name version)
	(write-sym-file (funcall pathname ':new-type "SYM") name version)
	(write-err-file (funcall pathname ':new-type "ERR") name version)))))

(defun write-mic-file (pathname name version)
  (with-open-file (stream pathname '(:out :fixnum))
    (let* ((length (min (string-length name) 32.))
	   (name16 (make-array (// (1+ length) 2) ':type 'art-16b ':displaced-to name)))
      (funcall stream ':tyo length)
      (funcall stream ':string-out name16))
    (funcall stream ':tyo version)

    ;; Type map
    (let ((ntypes (lsh (length *type-maps*) 6)))
      (format t "~&Type map - ~O locations" ntypes)
      (funcall stream ':tyo 1)
      (funcall stream ':tyo 0)
      (funcall stream ':tyo ntypes)
      (funcall stream ':tyo 1)
      (loop for i from 0 below ntypes
	    do (funcall stream ':tyo (aref *type-maps* i))))

    ;; A and B memories
    (write-a-b-memory stream 2 *a-memory-values* *a-constant-list* "A")
    (write-a-b-memory stream 3 *b-memory-values* *b-constant-list* "B")

    ;; Control memory
    (loop with length = (array-active-length *microinstruction-memory*)
	  with total = 0 with patches
	  for start from 0 below length
	  as mic = (aref *microinstruction-memory* start)
	  do (cond ((null mic))
		   ((null (setq patches (mic-load-time-patches mic)))
4,887,235
	163	164
	(let ((count (loop for address from start below length
			   as mic = (aref *microinstruction-memory* address)
			   while (not (null mic))
			   while (null (mic-load-time-patches mic))
			   sum 1)))
	  (incf total count)
	  (funcall stream ':tyo 4)
	  (funcall stream ':tyo start)
	  (funcall stream ':tyo count)
	  (funcall stream ':tyo 7)
	  (loop repeat count
		for address from start
		as mic = (aref *microinstruction-memory* address)
		when (not (null mic))
		  do (loop with val = (mic-code mic)
			   repeat 7 for ppss from 0020 by 2000
			   do (funcall stream ':tyo (ldb ppss val))))
	  (incf start (1- count))))
		   (t
		    ;; Write cmem location that needs to be patched:
		    ;; 104 <address>, <n-patches> 7 raw-cmem-data patches...
		    ;;   1 6-bytes-of-name -- store slot number of card into U AMWA<9:5>
		    (incf total 1)
		    (funcall stream ':tyo 104)
		    (funcall stream ':tyo start)
		    (funcall stream ':tyo (length patches))
		    (funcall stream ':tyo 7)
		    (loop with val = (mic-code mic)
			  repeat 7 for ppss from 0020 by 2000
			  do (funcall stream ':tyo (ldb ppss val)))
		    (loop for (type arg) in patches do
			  (selectp type
				   (symbolic-lbus-slot
				    (funcall stream ':tyo 1)
				    (let ((name (string-append (string arg) "      ")))
				      (funcall stream ':tyo (dpb (aref name 1) 1010 (aref name 0)))
				      (funcall stream ':tyo (dpb (aref name 3) 1010 (aref name 2)))
				      (funcall stream ':tyo (dpb (aref name 5) 1010 (aref name 4)))))
			  (otherwise (ferror "~S unknown load-time patch type" type))))))
    finally (format t "~&C mem - ~O locations" total))
  (funcall stream ':tyo 0)))	;Mark EOF

(defun write-sym-file (pathname name version)
  (with-open-file (stream pathname '(:out))
    (pkg-bind "MICRO"
      (let ((base 8))
	(format stream ";;; -*-Mode:Lisp:Base:8-*-~%(VERSION ~S ~D.)~%" name version)
	(funcall stream ':string-out "
/(A-MEMORY
")
	(dolist (elem *a-memory-symbols*)
		(funcall stream ':tyo #\sp)
		(prin1 elem stream)
		(funcall stream ':tyo #\cr))
	(funcall stream ':string-out ")
")
	(funcall stream ':string-out "
/(B-MEMORY
")
	(dolist (elem *b-memory-symbols*)
		(funcall stream ':tyo #\sp)
		(prin1 elem stream)
		(funcall stream ':tyo #\cr))
	(funcall stream ':string-out ")
")

	(funcall stream ':string-out "
/(C-MEMORY
")
	(dolist (elem *microinstruction-tag-alist*)
		(funcall stream ':tyo #\sp)
		(prin1 (cons (car elem) (micabs-addresses (cdr elem))) stream)
		(funcall stream ':tyo #\cr))
	(loop for mic being the array-elements of *microinstruction-memory*
	      using (index address)
	      when (not (null mic))
	      do (let ((name (mic-tag mic)))
		   (cond ((and name (not (assq name *microinstruction-tag-alist*)))
			  (funcall stream ':tyo #\sp)
			  (prin1 (list name address) stream)
			  (funcall stream ':tyo #\cr)))))
	(funcall stream ':string-out ")
")))))

(defun write-err-file (pathname name version)
  (with-open-file (stream pathname '(:out))
    (pkg-bind "MICRO"
      (let ((base 8))
4,887,235
	165	166
	(format stream ";;; -*-Mode:Lisp;Base:8-*-~%(VERSION ~S ~O.)~%" name version)
	(funcall stream ':string-out "
/(ERROR-TABLE
")
	(loop for mic being the array-elements of *microinstruction-memory*
	      using (index address)
	      when mic do (let ((err (mic-error-table mic)))
			    (cond (err
				   (funcall stream ':tyo #\sp)
				   (prin1 (cons address err) stream)
				   (funcall stream ':tyo #\cr)))))
	(funcall stream ':string-out ")")))))

(defun write-a-b-memory (stream memory fixed-values constant-list name)
  (let ((mem-data (append fixed-values constant-list nil)))
    (setq mem-data (sortcar mem-data '<))
    (format t "~&~A memory - ~D locations" name (length mem-data))
    (loop while mem-data
	  as start = (caar mem-data)
	  as count = (loop for address from start
			   for (loc . val) in mem-data
			   while (= loc address)
			   sum 1)
	  do (funcall stream ':tyo memory)
	     (funcall stream ':tyo start)
	     (funcall stream ':tyo count)
	     (funcall stream ':tyo 3)		;36-bits worth
	     (loop repeat count
		   as val = (cdar mem-data)
		   do (loop repeat 3 for ppss from 0020 by 2000
			    do (funcall stream ':tyo (ldb ppss val)))
		   (pop mem-data)))))

F:>LMACH>Ucode>SYSDCL.LISP.64
;;; -*- Mode:Lisp; Package:User; Base:8; Lowercase:yes -*-
;;; (c) Copyright 1982, Symbolics, Inc.

; System declaration for L-machine microcode compiler, simulator, and code

(package-declare micro global 4000)

;The microcode system consists of the compiler and the microcode. I'd like
;to be able to say that all transformations on tne microcode depend on having
;the compiler loaded, but there doesn't appear to be a reasonable way to say that.
;(make-system 'microcompiler) can be done manually when necessary.

(defsystem micro
  (:pathname-default "SYS: L-UCODE;")
  ;(:package Micro)
  (:component-systems microcompiler microcode))

(defsystem microcompiler
  (:pathname-default "SYS: L-UCODE;")
  (:module zwei ("ZWEI") :package "Zwei")
  (:module simulator ("SIM"))
  (:module compiler1 ("UU" "CHECK" "UL"))
  (:module compiler2 ("UH"))
  (:module simulator2 ("SIMX"))
  (:module architecture-macros ("UA" "UUX"))
  (:module architecture-defs ("L-SYS; SYSDEF" "L-SYS; SYSDF1")
	   :package "Micro")
  (:module instruction-defs ("L-SYS; OPDEF") :package "Micro")
  (:module sprinter ("BETTER-SPRINTER"))
  (:module make-system ("MAKSYS"))
  (:compile-load make-system)
  (:compile-load zwei)
  (:compile-load simulator)
  (:compile-load compiler1 (:fasload simulator make-system))
  (:compile-load compiler2 (:fasload simulator compiler1 make-system))
  (:readfile instruction-defs (:fasload simulator compiler1))
  (:readfile architecture-defs ((:fasload simulator compiler1) (:readfile instruction-defs)))
  (:compile-load simulator2
     ((:fasload simulator compiler1) (:readfile architecture-defs instruction-defs))
     ((:fasload simulator compiler1) (:readfile architecture-defs instruction-defs)))
  (:compiIe-load architecture-macros ((:fasload simulator compilerl simulator2)
				      (:readfile architecture-defs instruction-defs))
		 ((:fasload simulator compiler1 simulator2)
		  (:readfile architecture-defs instruction-defs)))
  (:compile-load sprinter))
;Transformations for microcode
;MAKE-SYSTEM isn't as general as it might be. so we need different transformations
;for each machine.

;Transforsations for prototype machine (no memory control)
(si:define-simple-transformation :proto-micro-load
	micro:proto-fasload-1 si:file-newer-than-installed-p ("PROTO-MICREL") NIL
	("Load prototype microcode" "Loading prototype microcode"
	 "loaded prototype microcode")
	NIL)
4,887,235
	167	168
(si:def inc-simple-transformation :proto-micro-compile
	micro:proto-compile-file-1 si:file-newer-than-file-p ("LISP") ("PROTO-MICREL")
	("Compile prototype microcode" "Compiling prototype microcode"
	 "compiled prototype microcode")
	t)
(defmacro (:proto-micro-compile-load si:defsystem-macro) (input &optional com-dep load-dep
								com-cond load-cond)
  '(:proto-micro-load (:proto-micro-compile ,input ,com-dep ,com-cond)
		      ,load-dep ,load-cond))
(defmacro (:proto-micro-compile-load-init si:defsystem-macro) (input add-dep
								     &optional com-dep load-dep
								     &aux function)
  (setq function
	(let-closed ((si:*additional-dependent-modules*
		      (si:parse-module-components add-dep si:*system-being-defined*)))
		    'si:compile-load-init-condition))
  '(:proto-micro-load (:proto-micro-compile ,input ,com-dep ,function) ,load-dep))

;Transformations for #2 machine (temporary memory control)
(si:define-simple-transformation :tmc-micro-load
	micno:tmc-fasload-1 si:file-newer-than-installed-p ("TMC-MICREL") NIL
	("Load TMC microcode" "Loading TMC microcode" "loaded TMC microcode")
	NIL)
(si:define-simple-transformation :tmc-micro-compile
	micro:tmc-compile-file-1 si:file-newer-than-file-p ("LISP") ("TMC-MICREL")
	("Compile TMC microcode" "Compiling TMC microcode" "compiled TMC microcode")
	t)
(defmacro (:tmc-micro-compile-load si:defsystem-macro) (input &optional com-dep load-dep
							      com-cond load-cond)
  '(:tmc-micro-load (:tmc-micro-compile input ,com-dep ,com-cond)
		    ,load-dep ,load-cond))
(defmacro (:tmc-micro-compile-load-init si:defsystem-macro) (input add-dep
								   &optional com-dep load-dep
								   &aux function)
(setq function
      (let-closed ((si:*additional-dependent-modules*
		    (si:parse-module-components add-dep si:*system-being-defined*)))
		  'si:compile-load-init-condition))
'(:tmc-micro-load (:tmc-micro-compile ,input ,com-dep ,function) ,load-dep))

;Transformations for rev-5 temporary memory control
(si:define-simple-transformation tmc5-micro-load
	micro:tmc5-fasload-1 si:file-newer-than-installed-p ("TMC5-MICREL") NIL
	("Load TMC5 microcode" "Loading TMC5 microcode" "loaded TMC5 microcode")
	NIL)
(si:define-simple-transformation :tmc5-micro-compile
	micro:tmc5-compile-file-1 si:file-newer-than-file-p ("LISP") ("TMC5-MICREL")
	("Compile TMC5 microcode" "Compiling TMC5 microcode" "compiled TMC5 microcode")
	t)
(defmacro (:tmc5-micro-compile-load si:defsystem-macro) (input &optional com-dep load-dep
							       com-cond load-cond)
  '(:tmc5-micro-load (:tmc5-micro-compile ,input ,com-dep ,com-cond)
		     ,load-dep load-cond))
(defmacro (:tmc5-micro-compile-load-init si:defsystem-macro) (input add-dep
								    &optional com-dep load-dep
								    &aux function)
  (setq function
	(let-closed ((si:*additional-dependent-modules*
		      (si :parse-module-components add-dep si:*system-being-defined*)))
	  'si:compile-load-init-condition))
  '(:tmc5-micro-load (:tmc5-micro-compile ,input ,com-dep ,function) ,load-dep))

;Transfonmations for production machine (memory control with IFU)
(si:define-simple-transformation :ifu-micro-load
	micro:ifu-fasload-1 si:file-is-newer-than-installed-p ("IFU-MICREL") NIL
	("Load IFU microcode" "Loading IFU microcode" "loaded IFU microcode")
	NIL)
(si:define-simple-transformation :ifu-micro-compile
	micno:ifu-compile-file-1 si:file-newer-than-file-p ("LISP") ("IFU-MICREL")
	("Compile IFU microcode" "Compiling IFU microcode" "compiled IFU microcode")
	t)
(defmacro (:ifu-micro-compile-load si:defsystem-macro) (input &optional com-dep load-dep
							      com-cond load-cond)
  '(:ifu-micro-load (:ifu-micro-compile ,input ,com-dep ,com-cond)
		    ,load-dep ,load-cond))
(defmacro (:ifu-micro-compile-load-init si:defsystem-macro) (input add-dep
								   &optional com-dep load-dep
								   &aux function)
  (setq function
	(let-closed ((si:*additional-dependent-modules*
		      (si:parse-module-components add-dep si:*system-being-defined*)))
		    'si:compile-load-init-condition))
  '(:ifu-micro-load (:ifu-micro-compile ,input ,com-dep ,function) ,load-dep))

;Transformations for simulator
(si:define-simple-transformation :sim-micro-load
	micro:sim-fasload-1 si:file-newer-than-installed-p ("SIM-QFASL") NIL
	("Load simulated microcode" "Loading simulated microcode"
	 "loaded Simulated microcode")
	NIL)
4,887,235
	169	170
(si:define-simple-transformation :sim-micro-compile
	micro:sim-compile-file-1 si:file-newer-than-file-p ("LISP") ("SIM-QFASL")
	("Compile simulated microcode" "Compiling simulated microcode"
	 "compiled simulated microcode")
	t)
(defmacro (:sim-micro-compile-load si:defsystem-macro) (input &optional com-dep load-dep
							      com-cond load-cond)
  '(:sim-micro-load (:sim-micro-compile ,input ,com-dep ,com-cond)
		    ,load-dep load-cond))a
(defmacro (:sim-micro-compile-load-init si:defsystem-macro) (input add-dep
								   &optional com-dep load-dep
								   &aux function)
  (setq function
	(let-closed ((si:*additional-dependent-modules*
		      (si:parse-module-components add-dep si:*system-being-defined*)))
		    'si:compile-load-init-condition))
  '(:sim-micro-load (:sim-micro-compile ,input ,com-dep .function) ,load-dep))

(defsystem microcode
  (:pathname-default "SYS: L-UCODE;")
  (:patchable)					;For the sake of %MICROCODE-VERSION
  (:not-in-disk-label)
  (:component-systems tmc-microcode)) ;Load just this version now

(comment ;this doesn't work any more, some of the macros have been diked out
(defsystem proto-microcode
  (:pathname-default "SYS: L-UCODE;")
  (:module cab-defs ("FUNCALL"			;Macro definitions for function calling
		     "FUNCALL2" "CATCH"))	;defareg'e used in FUNC~~LL3
  (:module call ("FUNCALL1"			;Expand the function-call macros
		 "FUNCALL3"))			;Random function-call routines
  (:module arithmetic-defs "ARITh-ESCAPE")	;Definitions needed to compile arithmetic
  (:module arithmetic "ARITH")
  (:module multiply-divide ("MULTIPLY" "DIVISION"))
  (:module array ("ARRAY"))
  (:module control ("CONTROL"))
  (:module other-microcode ("BASIC" "BRANCH" "PREDICATE" "SUBPRIM" "SYM" "BIND"
			    "STACK-BUFFER" "SG" "FLAVOR" "IFU"
			    "AMEM-MAP" "PROTO-TRAP" "BITBLT"))
  (:module floating-point ("FLOAT"))
  (:module microcode (call-defs call array other-microcode floating-point))

  (:proto-micro-compile-load call-defs)
  (:proto-micro-compile-load-init call call-defs (:proto-micro-load call-defs)
				  		 (:proto-micro-load call-defs))
  (:proto-micro-compile-load arithmetic-defs)
  (:proto-micro-compile-load multiply-divide (:proto-micro-load arithmetic-defs))
  (:proto-micro-compile-load arithmetic (:proto-micro-load arithmetic-defs multiply-divide))
  (:proto-micro-compile-load array (:proto-micro-load arithmetic-defs multiply-divide))
  (:proto-micro-compile-load control)
  (:proto-micro-compile-load other-microcode (:proto-micro-load control))
  (:proto-micro-compile-load floating-point
			     (:proto-micro-load arithmetic-defs multiply-divide)))
) ;comment

(defsystem tmc-microcode
  (:pathname-default "SYS: L-UCODE;")
  (:module call-defs ("FUNCALL"			;Macro definitions for function call in
		      "FUNCALL2" "CATCH"))	;defareg's used in FUNCALL3
  (:module call ("FUNCALL1"			;Expand the function-call macros
		 "FUNCALL3"))			;Random function-call routines
  (:module arithmetic-defs "ARITH-ESCAPE")	;Definitions needed to compile arithmetic
  (:module arithmetic "ARITH")
  (:module multiply-divide ("MULTIPLY" "DIVISION"))
  (:module array ("ARRAY"))
  (:module control ("CONTROL"))
  (:module other-microcode ("BASIC" "BRANCH" "PREDICATE" "SUBPRIM" "SYM" "BIND"
			    "STACK-BUFFER" "SG" "FLAVOR" "MAP" "TRAP" "BITBLT"))
  (:module disk "DISK")
  (:module net "NET")
  (:module floating-point ("FLOAT"))
  (:module microcode (call-defs call array other-microcode floating-point))

  (:tmc-micro-compile-load call-defs)
  (:tmc-micro-compile-load-init call call-defs (:tmc-micro-load call-defs)
					       (:tmc-micro-load call-defs))
  (:tmc-micro-compile-load arithmetic-defs)
  (:tmc-micro-compile-load multiply-divide (:tmc-micro-load arithmetic-defs))
  (:tmc-micro-compile-load arithmetic (:tmc-micro-load arithmetic-defs multiply-divide))
  (:tmc-micro-compile-load array (:tmc-micro-load arithmetic-defs multiply-divide))
  (:tmc-micro-compile-load control)
  (:tmc-micro-compile-load other-microcode (:tmc-micro-load control))
  (:tmc-micro-compile-load disk)
  (:tmc-micro-compile-load net (:tmc-micro-load disk))
  (:tmc-micro-compile-load floating-point (:tmc-micro-load arithmetic-defs multiply-divide)))

(defsystem tmc5-microcode
  (:pathname-default "SYS: L-UCODE;")
  (:module call-defs ("FUNCALL"			;Macro definitions for function cabling
		      "FUNCALL2" "CATCH"))	;defareg's used in FUNCALL3
  (:module call ("FUNCALL1"			;Expand the function-cal I macros
		 "FUNCALL3"))			;Random function-call routines
4,887,235
	171	172
(:module arithmetic-defs "ARITH-ESCAPE")	;Definitione needed to compile arithmetic
(:module arithmetic "ARITH")
(:module multiply-divide ("MULTIPLY" "DIVISION"))
(:module array ("ARRAY"))
(:mcdule control ("CONTROL"))
(:module other-microcode ("BASIC" "BRANCH" "PREDICATE" "SUSPRIM" "SYM" "BIND"
			  "STACK-BUFFER" "SG" "FLAVOR" "MAP" "TRAP" "BITBLT"))
(:module disk "DISK")
(:module net "NET")
(:module floating-point ("FLOAT"))
(:module microcode (call-defs call array other-microcode floating-point))

(:tmc5-micro-compile-load call-defs)
(:tmc5-micro-compile-load-init call call-defs (:tmc5-micro-load call-defs)
					      (:tmc5-micro-load call-defs))
(:tmc5-micro-compile-load arithmetic-defs)
(:tmc5-micro-compile-load multiply-divide (:tmc5-micro-load arithmetic-defs))
(:tmc5-micro-compile-load arithmetic (:tmc5-micro-load arithmetic-defs multiply-divide))
(:tmc5-micro-compile-load array (:tmc5-sicro-boad arithmetic-defs multiply-divide))
(:tmc5-micro-compile-load control)
(:tmc5-micro-compile-load other-microcode (:tmc5-micro-boad control))
(:tmc5-micro-compile-load disk)
(:tmc5-micro-compile-load net (:tmc5-micro-load disk))
(:tmc5-micro-compile-load floating-point
			  (:tmc5-micro-compile-load arithmetic-defs multiply-divide)))

(defsystem ifu-microcode
  (:pathname-default "SYS: L-UCODE;")
  (:module call-defs ("FUNCALL"			;Macro definitions for function calling
		      "FUNCALL2" "CATCH"))	;defareg's used in FUNCALL3
  (:module call ("FUNCALL1"			;Expand the function-call macros
		 "FUNCALL3"))			;Random function-call routines
  (:module arithmetic-defs "ARITH-ESCAPE")	;Definitions needed to compile arithmetic
  (:module arithmetic "ARITH")
  (:module multiply-divide ("MULTIPLY" "DIVISION"))
  (:module array ("ARRAY"))
  (:module control ("CONTROL"))
  (:module other-microcode ("BASIC" "BRANCH" "PREDICATE" "SUSPRIM" "SYM" "BIND"
			    "STACK-BUFFER" "SG" "FLAVOR" "MAP" "TRAP" "BITBLT"))
  (:module disk "DISK")
  (:module net "NET")
  (:module floating-point ("FLOAT"))
  (:module microcode (call-defs call array other-microcode floating-point))

  (:ifu-micro-compile-load call-defs)
  (:ifu-micro-compile-load-init call call-defs (:ifu-micro-load call-defs)
					       (:ifu-micro-load call-defs))
  (:ifu-micro-compile-load arithmetic-defs)
  (:ifu-micro-compile-load multiply-divide (:ifu-micro-load arithmetic-defs))
  (:ifu-micro-compile-load arithmetic (:ifu-micro-load arithmetic-defs multiply-divide))
  (:ifu-micro-compile-load array (:ifu-micro-load arithmetic-defs multiply-divide))
  (:ifu-micro-compile-load control)
  (:ifu-micro-compile-load other-microcode (:ifu-micro-load control))
  (:ifu-micro-compile-load disk)
  (:ifu-micro-compile-load net (:ifu-micro-load disk))
  (:ifu-micro-compile-load floating-point (:ifu-micro-load arithmetic-defs multiply-divide)))

(defsystem sim-microcode
  (:pathname-default "SYS: L-UCODE;")
  (:module cal-defs ("FUNCALL"			;Macro definitions for function cabling
		     "FUNCALL2" "CATCH"))	;defarsg's used in FUNCALL3
  (:module call ("FUNCALL1"			;Expand the function-call macroe
		 "FUNCALL3"))			;Random function-call routines
  (:module arithmetic-defs "ARITH-ESCAPE")	;Definitions needed to compile arithmetic
  (:module arithmetic "ARITH")
  (:module multiply-divide ("MULTIPLY" "DIVISION"))
  (:module array ("ARRAY"))
  (:module other-microcode ("BASIC" "BRANCH" "PREDICATE" "SUBPRIM" "SYM" "BIND"
			    "STACK-BUFFER" "SG" "FLAVOR" "IFU" "BITBLT"))
  (:module floating-point ("FLOAT"))
  (:module arithmetic-instructions "ARITH")
  (:module microcode (call-defs call array other-microcode floating-point))
  ;I am apparently not permitted by the tastefulness committee to name my files .SIM
  ;(:module test-cases ("FACT.SIM" "FAKE-ARRAY"))

  (:sim-micro-compile-load call-defs)
  (:sim-micro-compile-load-init call call-defs (:sim-micro-load call-defs)
					       (:sim-micro-load call-defs))
  (:sim-micro-compile-load arithmetic-defs)
  (:sim-micro-compile-load multiply-divide (:sim-micro-load arithmetic-defs))
  (:sim-micro-compile-load arithmetic (:sim-micro-load arithmetic-defs multiply-divide))
  (:sim-micro-compile-load array (:sim-micro-load arithmetic-defs multiply-divide))
  (:sim-micro-compile-load other-microcode)
  (:sim-micro-compile-load floating-point (:sim-micro-load arithmetic-defs multiply-divide))
  ;(:readfile test-cases ;(:fasload microcode)
  ;			 (:fasload call-defs call other-microcode))
)