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 µinstruction-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