;;; -*- Mode:LISP; Package:LISP-INTERNALS; Base:10; Readtable:CL -*- ;;; make the control pdl bigger if we need to (defun control-pdl-assure-room (control-pdl) (if (>= (+ (control-pdl-pointer control-pdl) max-call-hardware-dump) ;max size of call hardware (control-pdl-limit control-pdl)) (grow-control-pdl control-pdl) control-pdl)) (defun grow-control-pdl (control-pdl) (let* ((stack-group (control-pdl-stack-group control-pdl)) (new-control-pdl (make-control-pdl stack-group (+ (control-pdl-limit control-pdl) control-pdl-allocation-quantum)))) ;;; this will copy stack-group, pointer and the dumped call hardware state (do ((offset 1 (1+ offset)) (end (control-pdl-limit control-pdl))) ((>= offset end)) (array:%vm-write32 new-control-pdl offset (array:%vm-read32 control-pdl offset))) ;;; change the control pdl in the stack group (setf (sg-control-pdl stack-group) new-control-pdl) (set-control-pdl-stack-group control-pdl nil) ;disassociate the old control pdl from any stack group new-control-pdl)) (defmacro set-rpc-rdest (rpc rdest global-frame) `(let ((rpc-rdest (hw:dpb ,rdest hw:%%ch-rpcd-return-dest ,rpc))) (hw:trap-off) ;;;once Kent fixes the hardware we won't need to do the hack with SPARE-17 any more. (hw:write-processor-control (vinc:dpb-multiple-unboxed ,global-frame hw:%%processor-control-misc 1 hw:%%processor-control-spare-17 (hw:read-processor-control))) (hw:nop) (hw:nop) (hw:nop) (hw:nop) (hw:write-return-pc-return-dest rpc-rdest) (hw:nop) (hw:ch-open-call) (hw:write-processor-control (hw:dpb-unboxed 0 hw:%%processor-control-spare-17 (hw:read-processor-control))) (hw:nop) (hw:nop) (hw:write-memory-control (hw:dpb-unboxed hw:$$trap-enable hw:%%memory-control-master-trap-enable (hw:read-memory-control))))) (defmacro FORGE-CATCHER-FRAME () `(set-rpc-rdest (k2:%compiled-function-code (symbol-function 'call-hardware-underflow-catcher)) (vinc::dpb-multiple-unboxed hw:$$i-reg-base-active hw:%%i-reg-base ; return destination A0 0 hw:%%i-reg-offset (hw:unboxed-constant 0)) 0)) ;;; This is what lives at the bottom of the call hardware stack. It is never called. Things return ;;; to it at PC offset 0. The macro FORGE-CATCHER-FRAME knows how to install it. Be sure the call hardware is ;;; empty when you install it otherwise the frames below it will be lost. (defun CALL-HARDWARE-UNDERFLOW-CATCHER (result) ;;; traps are on. This is guaranteed by some hack somewhere. ;;; Forge an open call frame onto the control pdl. ;;; It should look like this: ;;; RPC: either CALL-HARDWARE-UNDERFLOW-RETURN-MULTIPLE-VALUES or CALL-HARDWARE-UNDERFLOW-RETURN-1-VALUE. ;;; RDEST: ignore, return-frame-0. ;;; type: unprotected open-call. ;;; boxed bits: register zero is same as result, all others unboxed. ;;; global frame: doesn't matter. ;;; registers: saved A0 has value of RESULT, all others are unboxed zero. (if (control-pdl-empty-p gr:*control-pdl*) (trap:illop "Control PDL is empty") ; if the control pdl is empty we should loose in some appropriate way (let ((return-function (if (hw:return-code-mv-p) 'call-hardware-underflow-return-multiple-values 'call-hardware-underflow-return-1-value)) (word-1 (vinc:dpb-multiple-unboxed (hw:accumulate-box-bits (hw:unboxed-constant 0) result) %%cpdl0-box-bits $$cpdl0-type-open-call %%cpdl0-type-code (vinc:dpb-multiple-unboxed hw:$$i-reg-base-return hw:%%i-reg-base 0 hw:%%i-reg-offset (hw:unboxed-constant 0)) %%cpdl0-rdest 0 %%cpdl0-global-frame (hw:unboxed-constant 0)))) (macrolet ((control-pdl-write-word (word) `(progn (hw:write-md-unboxed ,word) (hw:vma-start-write-no-gc-trap-unboxed gr:*control-pdl-pointer*) (setq gr:*control-pdl-pointer* (hw:24+ 1 gr:*control-pdl-pointer*))))) (control-pdl-write-word word-1) (control-pdl-write-word (k2:%compiled-function-code (symbol-function return-function))) (control-pdl-write-word result) (control-pdl-write-word (hw:unboxed-constant 0)) (control-pdl-write-word (hw:unboxed-constant 0)) (control-pdl-write-word (hw:unboxed-constant 0)) (control-pdl-write-word (hw:unboxed-constant 0)) (control-pdl-write-word (hw:unboxed-constant 0)) (control-pdl-write-word (hw:unboxed-constant 0)) (control-pdl-write-word (hw:unboxed-constant 0)) (control-pdl-write-word (hw:unboxed-constant 0)) (control-pdl-write-word (hw:unboxed-constant 0)) (control-pdl-write-word (hw:unboxed-constant 0)) (control-pdl-write-word (hw:unboxed-constant 0)) (control-pdl-write-word (hw:unboxed-constant 0)) (control-pdl-write-word (hw:unboxed-constant 0)) (control-pdl-write-word (hw:unboxed-constant 0)) (control-pdl-write-word (hw:unboxed-constant 0))) (restore-call-headware)))) (defun call-hardware-underflow-return-1-value (value) (hw:return value)) (defun call-hardware-underflow-return-multiple-values (value) (hw:return-mv value)) (defun where-to-restore-from-control-pdl (control-pdl) ;;; find a place to start restoring the call hardware from. Must be an unprotected open-call frame (do* ((control-pdl-index (- (control-pdl-pointer control-pdl) control-pdl-frame-size) (- control-pdl-index control-pdl-frame-size)) (number-of-frames 0 (1+ number-of-frames)) open-call-index (open-call-index-number-of-frames 0)) (nil) (cond ((= control-pdl-index control-pdl-base) ;empty control pdl? (return control-pdl-base)) ((>= open-call-index-number-of-frames (floor 256 3)) ;one third of call headware size? (return open-call-index)) ((< control-pdl-index control-pdl-base) (trap:illop "phase error in control pdl")) ((hw:field= (array::%vm-read32 gr:*control-pdl* control-pdl-index) $$cpdl0-type-open-call %%cpdl0-type-code) (setq open-call-index control-pdl-index open-call-index-number-of-frames number-of-frames))))) ;;; should get called with traps ON! (defun restore-call-hardware (return-value) (dumping-or-restoring-call-hardware t) (macrolet ((saved-return-value () 'gr:*ch-temp-0*) (frame-first-word () 'gr:*ch-temp-1*) (next-rpc-rdest () 'gr:*ch-temp-2*) (global-frame () 'gr:*ch-temp-3*) (control-pdl-top () 'gr:*ch-temp-4*) (restore-register-prep () `(setf (frame-first-word) (hw:ldb (frame-first-word) %%cpdl0-box-bits (hw:unboxed-constant 0)))) (restore-register (register) `(progn (if (hw:32logbitp 0 (frame-first-word)) (hw:vma-start-read-vma-unboxed-md-boxed gr:*ch-control-pdl-index* 0) (hw:vma-start-read-no-transport-vma-unboxed-md-unboxed gr:*ch-control-pdl-index* 0)) (setq gr:*ch-control-pdl-index* (hw:24-1+ gr:*ch-control-pdl-index*)) (setf (frame-first-word) (hw:32logical-shift-down (frame-first-word) 1)) (setf (,register) (hw:read-md)))) ) (setf (saved-return-value) return-value) (forge-catcher-frame) (save-control-pdl-state) (setq gr:*ch-control-pdl-index* (hw:24+ gr:*control-pdl* (where-to-restore-from-control-pdl gr:*control-pdl*))) ;;; we should probably flush our frames so they will return to the heap (tagbody ;;; WARNING: no locals are allowed. Use of OPEN and ACTIVE frames is prohibited (setq gr:*ch-base-csp* (hw:ldb (hw:read-call-sp-hp) hw:%%ch-csphp-call-stack-pointer 0)) (setf (control-pdl-top) gr:*control-pdl-pointer*) (setq gr:*control-pdl-pointer* gr:*ch-control-pdl-index*) loop (when (hw:24= gr:*ch-control-pdl-index* (control-pdl-top)) (go end)) (when (hw:24> gr:*ch-control-pdl-index* (control-pdl-top)) (trap:illop "frame alignment phase error in control pdl")) (hw:vma-start-read-no-transport-vma-unboxed-md-unboxed gr:*ch-control-pdl-index*) (setq gr:*ch-control-pdl-index* (hw:24-1+ gr:*ch-control-pdl-index*)) ;point to second word (setf (frame-first-word) (hw:read-md)) (dispatch %%cpdl0-type-code (frame-first-word) (($$cpdl0-type-open-call $$cpdl0-type-protected-open-call) (progn (hw:trap-off) ;;;once Kent fixes the hardware we won't need to do the hack with SPARE-17 any more. (hw:write-processor-control (vinc:dpb-multiple-unboxed (global-frame) hw:%%processor-control-misc ;global frame number 1 hw:%%processor-control-spare-17 (hw:read-processor-control))) ;read boxed rpc (hw:nop) (hw:nop) (hw:nop) (hw:nop) (hw:write-return-pc-return-dest (next-rpc-rdest)) (hw:nop) (hw:ch-open-call) (hw:write-processor-control (hw:dpb-unboxed 0 hw:%%processor-control-spare-17 (hw:read-processor-control))) ;(trap:trap-on) (hw:nop) (hw:nop) (hw:write-memory-control (hw:dpb-unboxed hw:$$trap-enable hw:%%memory-control-master-trap-enable (hw:read-memory-control)))) ;;; setup RPC, RDEST and global return destination for next time around: (hw:vma-start-read-no-transport-vma-unboxed-md-unboxed gr:*ch-control-pdl-index*) (setq gr:*ch-control-pdl-index* (hw:24-1+ gr:*ch-control-pdl-index*)) (setf (next-rpc-rdest) (hw:ldb (frame-first-word) %%cpdl0-rdest (hw:unboxed-constant 0))) (setf (next-rpc-rdest) (hw:dpb (next-rpc-rdest) hw:%%ch-rpcd-return-dest (hw:read-md))) (setf (global-frame) (hw:ldb (frame-first-word) %%cpdl0-global-frame (hw:unboxed-constant 0))) (go restore-a-frame)) ($$cpdl0-type-open ;;; we need only restore the open frame (setq gr:*ch-control-pdl-index* (hw:24-1+ gr:*ch-control-pdl-index*)) ;skip RPC (hw:open-frame) (go restore-o-frame)) ($$cpdl0-type-topen ;;; we need only restore the active frame (setq gr:*ch-control-pdl-index* (hw:24-1+ gr:*ch-control-pdl-index*)) ;skip RPC (hw:ch-topen) (go restore-o-frame))) restore-o-frame (progn (restore-register-prep) (restore-register hw:o0) (restore-register hw:o1) (restore-register hw:o2) (restore-register hw:o3) (restore-register hw:o4) (restore-register hw:o5) (restore-register hw:o6) (restore-register hw:o7) (restore-register hw:o8) (restore-register hw:o9) (restore-register hw:o10) (restore-register hw:o11) (restore-register hw:o12) (restore-register hw:o13) (restore-register hw:o14) (restore-register hw:o15) (go loop)) restore-a-frame (progn (restore-register-prep) (restore-register hw:a0) (restore-register hw:a1) (restore-register hw:a2) (restore-register hw:a3) (restore-register hw:a4) (restore-register hw:a5) (restore-register hw:a6) (restore-register hw:a7) (restore-register hw:a8) (restore-register hw:a9) (restore-register hw:a10) (restore-register hw:a11) (restore-register hw:a12) (restore-register hw:a13) (restore-register hw:a14) (restore-register hw:a15) (go loop)) end) (save-control-pdl-state) (setq gr:*control-pdl* (control-pdl-assure-room gr:*control-pdl*)) (load-control-pdl-state) (dumping-or-restoring-call-hardware nil) (li:error "call hardware restored") ))