4,887,235
253 254
(defun address-add-macrocode ()
(address-add (instruction-baseno) (instruction-offset) t))
(defun aref-amem (loc)
(aref *a-memory* loc))
(defun aref-bmem (loc)
(aref *b-memory* loc))
(defun aref-bmem-360 ()
(aref *b-memory* 360))
(defun aset-amem (val loc)
(aset val *a-memory* loc)
nil)
(defun aset-bmem (val loc)
(aset val *b-memory* loc)
nil)
(defun aset-bmem-360 (val)
(aset val *b-memory* 360)
nil)
(defun setq-vma (obus)
(setq *vma* (pointer-field obus))
;Mapping, which really happens in the next cycle
;Map miss trap is not simulated, happens when memory-data read or written
(set-pma-from-vma))
(defun setq-sp (obus)
(setq *stack-pointer* (pointer-field obus)))
(defun setq-fp (obus)
(setq *frame-pointer* (pointer-field obus)))
(defun inc-sp ()
(setq *stack-pointer* (1+ *stack-pointer*)))
(defun dec-sp ()
(setq *stack-pointer* (1- *stack-pointer*)))
(defun inc-macro ()
(setq *instruction* (1+ *instruction*)))
;Simulate ALU carry function
(defun carry28 (x y z)
(bit-test 1_28. (+ (logand #.(1- 1_28.) x) (logand #.(1- 1_28.) y) z)))
(defun carry32 (x y z)
(bit-test 1_32. (+ (logand #.(1- 1_32.) x) (logand #.(1- 1_32.) y) z)))
;One simulation routine to help with multiplier
(defun 16-bit-sign-extend (n)
(if (bit-test 1_15. n) (+ 177777+16. n) n))
;Returns a (defun name () --translated-microcode--)
(defun microcode-to-lisp-function (name microcode #Q definition-name)
(let ((*microlisp-function-name* name))
'(defun ,name ()
#Q (declare (sys:function-parent ,definition-name))
(prog (abus bbus xbus ybus alub obus dispatch alu-output type-map)
#M (declare (fixnum abus bbus xbus ybus alub obus dispatch alu-output type-map))
;XXXbrad backquote?
(progn abus bbus xbus ybus alub obus dispatch alu-output type-map) ;inhibit warning
(setq type-map 0) ;Idiot compiler warning in Maclisp, code bug in Lisp Machine
. ,(microcode-to-lisp microcode)))))
(defun microcode-to-lisp (microcode)
(cone ((eq (car microcode) 'microsequence)
(loop for x in (cdr microcode)
nconc (microcode-to-lisp x)))
((eq (car microcode) 'microinstruction)
(let ((*microinstruction* microcode))
(microlisp-syntax-check microcode)
(nconc (microlisp-read-phase microcode)
(microlisp-data-path-phase microcode)
(microlisp-force-obus-phase microcode)
(microlisp-trap-phase microcode)
(microlisp-operate-phase microcode)
(microlisp-register-write-phase microcode)
(microlisp-jump-phase microcode))))
(t (bletch "Unrecognizable microcode: ~S" microcode))))
(defun microlisp-syntax-check (code)
(loop for (prop val) on (cdr code) by 'cddr
unless (or (memq prop read-phase-fields)
(memq prop data-path-fields)
(memq prop force-obus-fields)
(memq prop trap-phase-fields)
(memp prop operate-phase-fields)
(memq prop register-write-fields)
4,887,235
255 256
(memq prop jump-phase-fields)
(memq prop all-over-the-place-fields))
do (bletch "Unrecognized microcode field: ~S" prop)))
;Generate setqs of the varianles abus, bbus, xbus, ybus
(defun microlisp-read-phase (code)
(nconc
(mksetq 'abus
(eselectq abus (get code 'abus)
(amem
(let ((addr (get code 'amem-read-addr)))
(if (and (not (atom addr)) (eq (car addr) 'constant)) (cadr addr)
'(aref-amem ,(amemaddr addr)))))
(memory-data '(pma-mem-read))
(frame-pointer '*frame-pointer*)
(stack-pointer '*stack-pointer*)
(vma '*vma*)
(pc '*pc*)))
(mksetq 'bbus
(eselectq bbus (get code 'bbus)
(bmem
(let ((addr (get code bmem-read-addr)))
(cond ((and (not (atom addr)) (eq (car addr) 'constant))
(cadr addr))
((= addr 360)
'(aref-bmem-360))
(t '(aref-bmem ,addr)))))
(macro-signed-immediate (instruction-signed-immediate))
(macro-unsigned-immediate '(instruction-unsigned-immediate))))
(mksetq 'xbus
(eselectq xbus (get code 'xbus)
(abus 'abus)
(bbus 'bbus)
(product '(* *multiply-x* *multiply-y*))))
(mksetq 'ybus
(eselectq ybus (get code 'ybus)
(abus 'abus)
(bbus 'bbus)
;--- This is really not right, but will do for now I guess
(ybus-crocks-1 '(ash32 abus -20.))))))
;Generate setqs of the variables alub, alu-outout, and obus
(defun microlisp-data-path-phase (code &aux tem)
(nconc
(if (setq tem (get code 'byte-func)) ;Using the shifter
(mksetq 'alub
(if (eq tem 'ybus) 'ybus
(make-alub-sign-hack
(make-merge
(make-rot 'ybus (fix-byte-r (second tem)))
(if (eq (first tem) 'dpb) ;rotate-mask
(make-rot (make-mask (fix-byte-s (third tem)))
(fix-byte-r (second tem)))
(make-mask (fix-byte-s (third tem))))
(if (eq (fourth tem) 'merge) 'xbus 0))
(fieldp code 'spec 'alub-sign-hack)))))
(mksetq2 'obus 'alu-output
(eselectq alu (setq tem (get code 'alu))
(xbus 'xbus)
(alub 'alub)
((X+1 X+1-overflow) '(1+ xbus))
((X-1 X-1-overflow) '(1- xbus))
((X+Y X+Y-overflow) '(+ xbus alub))
((X-Y X-Y-overflow) '(- xbus alub))
(X+Y+1 '(+ xbus alub 1))
(X-Y-1 '(- xbus alub 1))
(X-Y-signed '(- (logxor xbus 1_31.) (logxor alub 1_31.)))
(X-Y-1-signed '(- (logxor xbus 1_31.) (logxor alub 1_31.) 1))
(and '(logand xbus alub))
(nand '(lognot (logand xbus alub)))
(ior '(logior xbus alub))
(xor '(logxor xbus alub))
(andcy '(logand xbus (lognot alub)))))))
;Generate calls to merge32, rot32, and mask32 but try to do them at
;compile time if possible
(defun make-mask (n-bits)
(if (numberp n-bits) (mask32 n-bits) '(mask32 ,n-bits)))
(defun make-rot (value n-bits)
(cond ((equal n-bits 0)
value)
((and (numberp value) (numberp n-bits))
(rot32 value n-bits))
(t '(rot32 ,value ,n-bits))))
4,887,235
257 258
(defun make-merge (foreground mask background)
(prog (tem)
;;Try to use lsh (ash) right instead of rot left, and open-code
;;when doing a simple byte extraction
(and (numberp mask) (equal background 0)
(cond ((and (not (atom foreground)) (eq (car foreground) 'rot32))
(and (numberp (setq tem (caddr foreground)))
(or (zerop tem) (<= (haulong mask) tem))
(return '(logand ,(if (zerop tem) (cadr foreground)
'(ash32 ,(cadr foreground)
,(- tem 32.)))
,mask))))
(t (return '(logand ,foreground ,mask)))))
;Unoptimizable
(return '(merge32 ,foreground ,mask ,background))))
(defun make-alub-sign-hack (code hack)
(if (not hack) code
'(logxor 1 ,code)))
;Valid forms for addr are:
; (frame-pointer fixnum)
; (stack-pointer fixnum)
; (xbas fixnum)
; (macrocode)
; fixnum ;between 0 and 7777 I guess
; (constant value)
(defun amemaddr (addr)
(cond ((numberp addr) addr)
((atom addr) (bletch "Garbage amem address: ~S" addr))
((eq (car addr) 'frame-pointer)
'(address-add-fp ,(cadr addr)))
((eq (car addr) 'stack-pointer)
'(address-add-sp ,(cadr addr)))
((eq (car addr) 'xbas)
'(address-add-xb . (cadr addr)))
((eq (car addr) 'macrocode)
(if (cdr addr) (bletch "Obsolete amem address: ~S" addr))
'(address-add-macrocode))
(t (bletch "Garbage amem address: ~S" addr))))
(defun fix-byte-r (r)
(cond ((and (fixp r) (>= r 0) (<= r 37)) r)
((eq r 'byte-r) '*byte-r*)
((eq r 'macro) '(logand 37 (instruction-unsigned-immediate)))
(t (bletch "Illegal byte rotation: !S" r))))
(defun fix-byte-s (s)
(cond ((and (fixp s) (> s 0) (<= s 40)) s)
((eq s 'byte-s) '(1+ *byte-s*))
((eq s 'micro) '(+ (lsh (logand (instruction-opcode) 3) 3)
(logand 7 (lsh (instruction-unsigned-immediate)
-5))
1))
(t (bletch "Illegal byte size: ~S" s))))
;XXXbrad - the following makes no sense - something is missing
(let ((mask (dpb -1 field 0))
(pos (lsh field -6))
(size (logand field 77)))
(cond ((numberb val)
(cond ((zerop val) '(logand ,(lognot mask) ,background))
((= val (1- (ash 1 size))) '(logior ,mask ,background))
(t '(logior ,(ash32 val pos)
(logand ,(lognot mask) ,background)))))
((memq val '(abus bbus))
'(logior (logand ,mask ,val) (logand ,(lognot mask) ,background)))
((eq val 'memory-data)
'(logior (logand ,mask (pma-mem-read))
(logand ,(lognot mask) ,background)))
((eq val (car hair))
'(logior (logand ,(lognot mask) mbackground)
(ash32 (logand ,(cadr hair) ,(caddr hair)) ,(cadddr hair))))
(t (bletch "~S illegal forcing value--gendpb" val)))))
(defun microlisp-force-obus-phase (code &aux tem)
(nconc (and (setq tem (get code 'force-obus<31-28>))
(ncons '(setq obus ,(gendpb tem 3404 'obus nil))))
(and (setq tem (get code 'force-obus<33-32>))
(ncons '(setq obus ,(gendpb tem 4002 'obus
'(bbus<5-4> bbus 60 28.)))))
(and (setq tem (get code 'force-obus<35-34>))
(ncons '(setq obus ,(gendpb tem 4202 'obus
'(bbus<7-6> bbus 300 28.)))))))
4,887,235
259 260
(defun microlisp-trap-phase (code &aux tem traps handler)
(setq traps (get code 'trap-enables)
handler (cond ((setq handler (get code trap-sequence))
(if (atom handler)
'(return (,(microcode-lisp-function-name
handler)))
`(progn . ,(microcode-to-lisp handler))))
((setq handler (get code 'arith-trap-dispatch-table))
'(caseq-that-works (+ (logand (ash abus -30.) 14) ;ash considered
(logand (ash bbus -32.) 3)) ;harmful...
. ,(microlisp-dispatch-clauses handler)))))
(nconc
;; Lower-level traps
(and (setq tem (get code 'type-map))
(ncons '(if (zerop (logand
(setq type-map
(arraycall fixnum *type-map*
(+ ,(eval-at-load-time
'(lsh (assign-type-map ',tem) 6))
(logand (ash abus -28.) 77))))
4))
(data-type-trap)))) ;---Don't simulate trap yet
;; Higher-level trap!
(and handler
(ncons '(and (or ,(and (memq 'condition-true traps)
(lispify-condition code))
,(and (memq 'condition-false traps)
'(not ,(lispify-condition code)))
,(and (memq type-condition traps)
'(bit-test 1 type-map))
,(and (memq 'bbus-non-fixnum traps)
'(not (data-type? bbus dtp-fix)))
,(and (memq 'overflow traps)
'(overflow-p alu-output)))
,handler)))
;; --- traps not done at all:
;; transports any-stack, other-stack, map-miss
(defun data-type-trap ()
(cerror T () ':data-type-trap "Data type trap"))
(defvar *type-map* (*array nil 'fixnum 4096.)) ;3 bits per element, cond*4+trap
(defvar *type-maps* nil)
#M (declare (*expr type-map-lookup)) ;in UU
;Note that the Trap bit is complemented
(defconst type-map-encodings
'((() . 4) ((cond) . 5) ((pointer) . 6) ((cond pointer) . 7)
((pointer cond) . 7) ((trap-0) . 8) ((trap-1) . 1)
((trap-2 pointer) . 2) ((pointer trap-2) . 2)
((trap-3 pointer) . 3) ((pointer trap-3) . 3)))
(defun assign-type-map (map)
(loop as number = 0 then (1+ number)
for map1 in *type-maps*
when (equal-type-maps map map1)
return number
finally (or (< number 100) (ferror nil "Gleep! Out of type maps"))
(setq *type-maps* (nconc *type-maps* (ncons map)))
(loop for type in *data-types*
as index upfrom (lsh number 6)
as outputs = (type-map-lookup type map)
do (store (arraycall fixnum *type-map* index)
(or (cdr (assoc outputs type-map-encodings))
(ferror nil "~S garbage in type map"
outputs))))
(return number)))
(defun equal-type-maps (map1 map2)
(loop for type in *data-types*
always (equal (typo-map-lookup type map1) (type-map-lookup type map2))))
(defun microlisp-operate-phase (code &aux tern)
(nconc (cond ((setq tem (get code 'dispatch))
(setq *dispatch-destination* (get code 'dispatch-table))
(ncons '(setq dispatch ,(dispatch-ldb tem)))))
(and (setq tem (qet code 'escape-to-lisp))
(ncons tem))
(and (setq tem (get code 'error-table))
(ncons '(setq *last-error-table-entry-seen* ',tem)))))
(defun dispatch-ldb (field)
(eselectp dispatch Held
(cdr-code '(ldb 4202 abus))
(abus<31-28> '(ldb 3404 abus))
(abus<25-22> '(ldb 2684 abus))
(abus<21-18> '(ldb 2204 abus))
(abus<2-0> '(ldb 0033 abus))
(alub 'alub)))
4,887,235
261 262
(defun microlisp-register-write-phase (code &aux tem tem1)
;First write the memories, then the registers (they might address the memory)
(nconc (and (get code 'write-amem)
(ncons '(aset-amem obus
,(amemaddr (get code 'amem-write-addr)))))
(and (setq tem (get code 'write-bmem))
(ncons (if (= (setq tem1 (get code 'bmem-write-addr)) 360)
'(aset-bmem-360 ,tem)
'(aset-bmem ,tem ,tem1))))
(and (get code 'write-lbus)
(symbolp (get code 'lbus-dev-addr)) ;ignore non-simulatable hair....
(eselectq (get code 'lbus-dev-addr) (get code 'lbus-dev-addr)
(write-memory (ncons '(pma-mem-write obus)))
(write-pc (ncons '(setq *pc* obus)))
(increment-macro-immediate (ncons '(inc-macro)))))
(and (fieldp code 'mem 'write-vma)
(ncons '(setq-vma obus)))
(and (fieldp code 'spec 'increment-pc)
(ncons '(inc-pc)))
(and (fieldp code 'spec 'load-frmp)
(ncons '(setq-fp obus)))
(and (fieldp code 'spec 'load-stkp)
(ncons '(setq-sp obus)))
(and (setq tem (get code 'stack-pointer))
(ncons (if (eq tem 'increment) '(inc-sp) '(dec-sp))))
(and (fieldp code 'spec 'load-byte-r)
(ncons (cond ((zerop (logand 10 (or (get code 'magic) 0)))
'(setq *byte-r* (locand 37 obus)))
((get code 'dispatch)
'(setq *byte-r* (array-index-shift-prom dispatch)))
(t (bletch "bute-r-from-array-disp without dispatch")))))
(and (fieldp code 'spec 'load-byte-s)
(ncons '(setq *byte-s* (logand 37 obus))))
(and (fieldp code 'spec 'load-xbas)
(ncons '(setq *xbas* (logand 1777 obus))))
(and (fieldp code 'spec 'load-inst) ;temporary memory control
(ncons '(setq *instruction* obus)))
(and (or (fieldp code 'spec 'multiply)
(fieldp code 'spec 'multiply-and-type-check))
(bit-test 2 (get code 'magic))
(ncons '(setq *multiply-x*
,(if (bit-test 4 (get code 'magic))
'(16-bit-sign-extend (logand 177777 xbus))
'(logand 177777 xbus)))))
(and (or (fieldp code 'spec 'multiply)
(fieldp code 'spec 'multiply-and-type-check))
(bit-test 1 (get code 'magic))
(ncons '(setq *multiply-y*
,(if (bit-test 10 (get code 'magic))
'(16-bit-sign-extend
(logand 177777 (ash32 ybus -16.)))
'(logand 177777 (ash32 ybus -16.))))))))
;If sequencer is take-dispatch then we are supposed to take a dispatch
;deferred from the previous instruction. The compile-time variable
;*dispatch-destination* and the runtime variable dispatch control this.
;Note that these have to be preserved appropriately through skips.
;If there is a skip on the condition field then we do that.
;Otherwise the sequencer, jump-sequence, and next-sequencs fields control
;call/jump/return/next-instruction which turns into Lisp function calling.
;We don't support simultaneous skipping and jumping (yet), except a little for call-select.
;At this level we don't worry about the CPC and NPC registers
(defun microlisp-jump-phase (code &aux jump next)
(setq jump (get code 'jump-sequence)
next (get code 'next-sequence))
(nconc
(eselectq (get code 'sequencer) (get code 'sequencer)
((popj next-instruction) (ncons '(return nil))) ;next-instruction or return
(nil (and next (ncons '(return (,(microcode-lisp-function-name next))))))
((pushj pushj-return-dispatch)
(and jump ;could be call-select
(ncons (if next `(progn (,(microcode-lisp-function-name jump))
(,(microcode-lisp-function-name next)))
'(,(microcode-lisp-function-name jump))))))
(take-dispatch
(ncons '(caseq dispatch ;caseq because of numbers
. ,(microlisp-dispatch-clauses *dispatch-destination*)))))
(and (fieldp code 'sequencer 'pushj-return-dispatch)
(ncons '(caseq dispatch ;caseq because of numbers
. ,(microlisp-dispatch-clauses *dispatch-destination*))))
(and (getl code (skip-true-sequence skip-false-sequence))
:;pred gets predicate which is t if we should skip
(let ((pred (lispify-condition code))
(pending-disp *dispatch-destination*))
(let ((skip-code '(cond (,pred
4,887,235
263 264
. ,(microlisp-if-branch
(get code 'skip-true-sequence)))
(t . ,(let ((*dispatch-destination* pending-disp))
(microlisp-if-branch
(get code 'skip-false-sequence)))))))
(and (not jump) (fieldp code 'sequencer 'pushj)
(setq skip-code '(prog () ,skip-code)))
(ncons skip-code))))))
(defun dispatch-cues (cues)
(cond ((eq cues 'otherwise) t) ;CASEQ wants T, not OTHERWISE
((atom cues)
(bletch "dispatch cue ~S: must be list or OTHERWISE" cues))
(t (mapcar #'dispatch-cue cues))))
(defun dispatch-cue (item)
(cond ((numberp item) item)
(t (bletch "~S illegal as dispatch cue" item))))
(defun microlisp-dispatch-clauses (table)
(loop for clause in (cdr table)
collect (cons (dispatch-cues (car clause))
(cond ((atom (cadr clause)) ;goto
'((return
(,(microcode-lisp-function-name
(cadr clause))))))
(t (microcode-to-lisp (cadr clause)))))))
(defmacro caseq-that-works (value . clauses)
(if (and (= (length clauses) 1)
(eq (caar clauses) t))
`(progn . ,(cdar clauses))
'(caseq ,value . ,clauses)))
(defun lispify-condition (code &aux tem)
(selectq (setq tem (get code 'condition))
(type-condition
'(bit-test 1 type-map))
((not-cdr-0 not-cdr-1 not-cdr-2 not-cdr-3)
'(not (cdr-code? abus ,(find-position-in-list tem
'(not-cdr-0 not-cdr-1 not-cdr-2 not-cdr-3)))))
(ybus-31
'(not (zerop (logand 1_31. ybus))))
(alu-31
'(not (zerop (logand 1_31. alu-output))))
(alub-0
'(not (zerop (logand 1 alub))))
(otherwise
(lispify-alu-condition
tem (get code 'alu)))))
(defun lispify-alu-condition (cond alu)
(selectq cond
(equal-pointer
'(= (logand #.(1- 1_28.) alu-output) #.(1- 1_28.)))
(not-equal-fixnum
'(not (= (logand #.(1- 1_32.) alu-output) #.(1- 1_32.))))
(not-equal-typed-pointer
'(not (= (logand #.(1- 1_34.) alu-output) #.(1- 1._34.))))
((not-greater-pointer not-greater-fixnum-unsigned)
(let ((op1 'xbus) op2 (op3 0)
(func (if (eq cond 'not-greater-pointer) 'carry28 'carry32)))
(setq op2 (selectq alu
(X+Y 'alub)
(X+Y+1 (setq cp3 1) 'alub)
((X-Y-1 X-Y-1-signed) '(lognot alub))
((X-Y X-Y-signed (setq op3 1) '(lognot alub))
(X 0)
(X+1 1)
(X-1) -1)
(otherwise
(bletch "~S - bad alu op - lispify-alu-condition" alu))))
'(not (,func ,opl ,op2 ,op3))))
(otherwise (bletch "~S - bad skip cond - lispify-alu-condition" cond))))
(defun microlisp-if-branch (code)
(cond ((null code) nil) ;drop through
((atom code) ;goto
(ncons '(return (,(microcode-lisp-function-name code)))))
(t (microcode-to-lisp code)))) ;immediate code
(defun microcode-lisp-function-name (utag)
(or (symbolp utag) (bletch "~S - not a tag -- microcode-lisp-function-name"
utag))
(intern (format nil '|~A-LISPMICROCODE| utag)))
4,887,235
265 266
F:>lmach>ucode>trap.lisp.8
;;; -*- Mode:Lisp; Package:Micro; Base:8; Lowercase:yes -*-
;;; (c) Copyright 1982, Symbolics, Inc.
; Microcode for Trap Handling on "real" machine
;Get defmicro and all his hosts
#M
(declare (cond ((not (status feature lmucode))
(load 'udcls))))
;Invisible-pointer traps
;If transporting was needed, it has happened already
;Time* 2 cycles trapping + 3 cycles here
(defucode-at-loc inviz-trap 10006 ;trap-2 handler
(parallel
(trap-save)
(declare-memory-timing data-cycle) ;defeat error checking, only used in emulator task
(assign vma memory-data)
(if (data-type? memory-data dtp-body-forward)
;; Body forward points to header forward
(sequential
(start-memory read)
(assign b-vma (- b-vma vma)) ;Offset into structure
(mach inc-version-case
((tmc tmc5)
(sequential
(assign b-vma (+ memory-data b-vma)) ;Address word in target structure
(assign vma b-vma)))
(otherwise
(assign vma (+ memory-data b-vma))))) ;Address word in target structure
(drop-through)))
(trap-restore
(start-memory read)
(assign b-vma vma)))
;Invisible pointer following when VMA advanced one or two words in block read.
;evcp and one-q-forward leave the orioinal seouence intact, the others change
;to a new sequence.
(defucode-at-loc error-trap 10004 ;trap-0 handler
(parallel (trap-save)
(lisp (enter-error-handler))
(if (not (zero-fixnum (sg-nontrappability %current-stack-group-status-bits)))
(parallel (halt error-in-error-handler) (jump error-trap))
;; Fixup the stack first, since we need to push some stuff
(call-and-return-to restore-stack-pointer error-trap-1))))
(defucode error-trap-no-restore-stack
(parallel (trap-save)
(lisp (enter-error-handler))
(if (not (zero-fixnum (sg-nontrappability %current-stack-group-status-bits)))
(parallel (halt error-in-error-handler) (jump error-trap))
(goto error-trap-1))))
;Error trap from block read. VMA advanced one or two words
(defucode-at-loc error-trap-vma-up-1 10014
(parallel (trap-save)
(assign vma (- vma (b-constant 2))))
(parallel (lisp (enter-error-handler))
(if (not (zero-fixnum (sg-nontrappability %current-stack-group-status-bits)))
(parallel (halt error-in-error-handler) (jump error-trap))
;; Fixup the stack first, since we need to push some stuff
(call-and-return-to restore-stack-pointer error-trap-1))))
(defucode-at-loc error-trap-vma-up-2 10024
(parallel (trap-save)
(assign vma (- vma (b-constant 2))))
(parallel (lisp (enter-error-handler))
(if (not (zero-fixnum (sg-nontrappability %current-stack-group-status-bits)))
(parallel (halt error-in-error-handler) (jump error-trap))
;; Fixup the stack first, since we need to push some stuff
(call-and-return-to restore-stack-pointer error-trap-1))))
(defucode error-trap-1
;; If an error occurs, halt
(assign (sg-halt-on-error %current-stack-group-status-bits) (b-constant 1))
;; Push the address of the microinstruction that signalled the error
(assign b-temp (logand (pop-control-stack) (b-constant 37777)))
(pushval (set-type b-temp dtp-fix))
(pushval (set-type vma dtp-locative))
;; Make the pc point such as to retry the failed instruction. The error handler is
;; likely as not going to mess with our state anyway.
;; The stack was already restored above.
(take-pre-trap signal-error preserve-stack))
4,887,235
267 268
;Here if IFU needs help fetching instructions
(defucode-at-loc ifu-empty-trap 14000
(set-pc pc))
;This lctel is known by PACE-FAULT. A fault here prevents backing up the PC.
(machine-version-case ((tmc)
(defucode ifu-empty-trap-1
(start-memory read block instruction-fetch)
(start-memory read block instruction-fetch) ;Active(1)
(nop) ;Data(1),Active(2)
(next-instruction))) ;Decode(1),Data(2)
(otherwise nil))
F:>lmach>ucode>SYM.LISP.7
;;; -*- Mode:LISP; Package:Micro; Base: 8; Lowercase: T -*-
;;; (c) Copyright 1982, Symbolics. Inc.
; Microcode for operations on symbols
#M
(declare (cond ((not (status feature lmucode))
(load 'udcls))))
(definst symeval no-operand
(parallel (check-data-type top-of-stack-a dtp-symbol dtp-nil)
(assign vma (+ top-of-stack-a (b-constant 1)))
(jump reference-symbol-offset)))
(definst fsymeval no-operand
(parallel (check-data-type top-of-stack-a dtp-symbol dtp-nil)
(assign vma (+ top-of-stack-a (b-constant 2)))
(jump reference-symbol-offset)))
(defucode reference-symbol-offset
(start-memory read)
(nop) ;time for the memory
(parallel (transport data)
(newtop memory-data)
(next-instruction)))
(definst value-cell-location no-operand
(parallel (check-data-type top-of-stack-a dtp-symbol)
(newtop (set-type (+ top-of-stack-a (b-constant 1))
dtp-locative))
(next-instruction)))
(definst function-cell-location no-operand
(parallel (check-data-type top-of-stack-a dtp-symbol)
(newtop (set-type (+ top-of-stack-a (b-constant 2))
dtp-locative))
(next-instruction)))
(definst property-cell-location no-operand
(parallel (check-data-type top-of-stack-a dtp-symbol dtp-nil)
(newtop (set-type (+ top-of-stack-a (b-constant 3))
dtp-locative))
(next-instruction)))
(definst package-cell-location no-operand
(parallel (check-data-type top-of-stack-a dtp-symbol dtp-nil)
(newtop (set-type (+ top-of-stack-a (b-constant 4))
dtp-locative))
(next-instruction)))
(definst boundp no-operand
(parallel (check-data-type top-of-stack-a dtp-symbol dtp-nil)
(assign vma (+ top-of-stack-a (b-constant 1)))
(jump check-boundp)))
(definst fboundp no-operand
(parallel (check-data-type top-of-stack-a dtp-symbol dtp-nil)
(assign vma (+ top-of-stack-a (b-constant 2)))
(jump check-boundp)))
(defucode check-boundp
(start-memory read)
(nop) ;wait for memory cycle
(parallel (transport write) ;This might not be the right kind of transport
(if (data-type? memory-data dtp-null)
(parallel (newtop quote-nil)
(next-instruction))
(parallel (newtop quote-t)
(next-instruction)))))
4,887,235
269 270
(definst get-pname no-operand
(parallel (check-data-type top-of-stack-a dtp-symbol dtp-nil)
(assign vma top-of-stack))
(start-memory read)
(nop) ;wait for memory cycle
(parallel (transport header)
(newtop (set-type meecry-data dtp-array))
(next-instruction)))
(definst set no-operand
(parallel (check-data-type next-on-stack dtp-symbol)
(assign vma (1+ next-on-stack)))
(parallel (start-memory read) ;read the value cdl pointer
(assign b-temp top-of-stack)
(decrement-stack-pointer)) ;pop 0ff the value
(for-effect (popval)) ;and the symbol pointer
(parallel (transport write) ;Follow any forwarding pointer
(assign a-temp ;merge new data with old cdr code
(merge-cdr b-temp memory-data)))
(parallel (store-contents a-temp) ;Now write back the new car
(next-instruction)))
;;; -*- Mode:Lisp; Package:Micro; Base:8; Lowercase:yes -*-
;;; (c) Copyright 1982, Symbolics, Inc.
;Subprimitives
;Get defmicro and all his hosts
#M
(declare (cond ((not (status feature lmucode))
(load 'udcls)))
(*expr get-to-abus get-to-bbus)) ;in UU
;Hardware definitions (these might belong in UU. however they
; are not used by any files othcr than this one.)
(defmicro cdr-field (opnd &optional background)
(parallel ,(get-to-abus opnd)
(ldb ybus-crocks-1 ,2 ,14. ,background)))
(defmicro high-type-field (opnd &optional background)
'(parallel m(get-to-abus opnd)
(ldb ybus-crocks-1 ,2 ,12. ,background)))
;This gets the high 4 bits of the tag. The low 4 have to be LDBed separately
(defmicro high-tag-field (opnd &optional background)
'(parallel ,(get-to-abus opnd)
(ldb ybus-crocks-1 .4 .12. .background)))
(defmicro low-tag-field (opnd &optional background)
'(ldb ,opnd 4 28. ,background))
(defmicro pointer-field (opnd &optional background)
'(ldb ,opnd 28. 0 ,background))
(defmicro set-low-tag-field (opnd background)
(make-microdata 'obus
(paralyze (get-to-obus32 opnd)
(microinstruction force-obus<31-28> ,background
magic ,background))))
(defmicro dpb-tag-field (tag opnd)
'(parallel ,(get-to-bbus tag)
(dpb ,tag 4 28. ,opnd)
(microinstruction force-obus<35-34> bbus<7-6>
force-obus<33-32> bbus<5-4>)))
(defmicro dpb-tag-field-high-only (tag opnd)
'(parallel ,(get-to-bbus tag)
,opnd
(microinstruction force-obus<35-34> bbus<7-6>
force-obus<33-32> bbu5<5-4>)))
(defmicro dpb-cdr-field (cdr opnd)
(if (and (not (atom cdr))
(eq (car cdr) 'ldb)
(equal (cddr cdr) '(2 6)))
(setq cdr (cadr cdr))
(retch "~S not aligned for dpbing into cdr field, kludge. kludge" cdr))
'(parallel ,(get-to-bbus cdr)
,cpnd
(microinstruction force-obus<35-34> bbus<7-6>)))
(defmicro dpb-type-field (type opnd)
'(parallel ,(get-to-bbus type)
(dpb ,type 4 28. ,opnd)
(microinstruction force-obus<33-32> bbus<5-4>)))
4,887,235
271 272
;Field extraction subprimitives
;XXXbrad something missing here?
(parallel
;Get 6-bit type field, rotated right 4 bits in a 32-bit word
(assign b-temp (high-type-field top-of-stack-a top-of-stack-a))
(if (data-type? top-of-stack-a dtp-fix dtp-float)
(parallel (newtop (set-type (dpb b-temp 2 4 0) dtp-fix))
(next-instruction))
;This bizarre LDB rotates left 4 then masks to 6 low bits
(parallel (newtop (set-type (strange-ldb b-temp 6 34) dtp-fix))
(next-instruction)))))
(definst1 %pointer (no-operand needs-stack)
(newtop (set-type (pointer-field top-of-stack) dtp-fix)))
(definst1 %fixnum (no-operand needs-stack)
(check-data-type top-of-stack-a dtp-float)
(newtop (set-type top-of-stack dtp-fix)))
(definst1 %flonum (no-operand needs-stack)
(check-data-type top-of-stack-a dtp-fix)
(newtop (set-type top-of-stack dtp-float)))
;"Pointer" construction
(definst1 %make-pointer-immed unsigned-immediate-operand
(newtop (dpb-type-field macro-unsigned-immediate top-of-stack-a)))
(definst %make-pointer-immed-offset unsigned-immediate-operand
(pop2push (set-type (+ next-on-stack top-of-stack) dtp-fix))
(parallel (newtop (dpb-type-field macro-unsigned-immediate top-of-stack-a))
(next-instruction)))
;2 cycles because it takes its damned arguments in the wrong order
;Bits <33:32> can only be DPB'ed from the B side (perhaps they could
;come from the Y bus instead, but that would probably break other things).
(definst %make-pointer no-operand
(parallel
(check-data-type next-on-stack dtp-fix)
(assign b-temp next-on-stack)
(assign next-on-stack to top-of-stack)
(decrement-stack-pointer)) ;Can't use pop2push in next
(parallel
(newtop (dpb-type-field b-temp top-of-stack-a))
(next-instruction)))
;2 cycles in order to get a fixnum result of the correct sign
(definst %pointer-difference (no-operand needs-stack)
(parallel
(assign b-temp (- next-on-stack top-of-stack))
(if (lesser-pointer next-on-stack top-of-stack)
(parallel
(pop2push (set-type (set-low-tag-field b-temp 17) dtp-fix))
(next-instruction))
(parallel
(pop2push (set-type (set-low-tag-field b-temp 0) dtp-fix))
(next-instruction)))))
F:>lmach>ucode>subprim.lisp.321
;Accessing memory cells indirect through pointers
(defucode memread ;Call with pointer in VMA
(start-memory read) ;Return with data in memory-data
(return))
(defucode memread-write
(start-memory read write)
(return))
(definst %p-ldb-immed (10-bit-immediate-operand needs-stack)
(memread top-of-stack)
(parallel (newtop (set-type (ldb memory-data macro macro) dtp-fix))
(next-instruction)))
;This is 5 cycles whereas %p-cdr-code could be done in 4. Saves opcodes...
(definst %p-tag-ldb-immed (unsigned-immediate-operand needs-stack)
(memread top-of-stack)
;Get 6-bit type field, rotated right 4 bits in a 32-bit word
(assign b-temp (high-tag-field memory-data memory-data))
;Here we assume that the mask generator does the right thing
;so that we can LDB Out of this byte which straddles a word boundary
;the macroinstruction's R in the immediate operand is hacked appropriately.
(parallel (newtop (set-type (ldb b-temp macro macro) dtp-fix))
(next-instruction)))