;;; -*- Mode:LISP; Package:LISP-INTERNALS; Base:10; Readtable:CL -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; OPERATIONS ON CONTROL PDLs

;;; SWAP IN AND WIRE		-not needed-
;;; The control PDL (or at least the part being dumped to) must be wired
;;; since the call hardware dumper isn't allowed to take page faults (or
;;; any call hardware operation).

;;; UNWIRE			-not needed-
;;; only the current control pdl need be wired.

;;; ASSURE SPACE TO DUMP IN
;;; For the current stack group, there must be enough remaining space in the
;;; control pdl (which must be wired) to hold what could potentially be the
;;; entire state of the call hardware.

;;; GROW
;;; control flow for the program might have a deep enough call stack
;;; that the previously allocated control pdl might not be big enough.
;;; this operation is similar to that of growing arrays.
;;; Wiring and unwiring must occur when a bigger control pdl is created.

;;; CONTEXT SWITCH
;;; when a context switch between stack groups occurs the entire call hardware
;;; state must be dumped into the control pdl associated with the outgoing
;;; stack group and restored from the control pdl state of the incomming stack group.
;;; These operations are similar to overflow and underflow handling.
;;; Wiring and unwiring occur at this point.

;;; HANDLE OVERFLOW
;;; when the program overflows the call hardware then its state must be dumped
;;; to the control pdl and restored later.  This dumping must occur on call boundaries.

;;; HANDLE UNDERFLOW
;;; when the program does more returns than the call hardware remembers and there
;;; was previously an overflow, then the state that was dumped to service the overflow
;;; must now be restored.  If there was no previously dumped state then the machine
;;; will have returned to the event horizon.

;;; SCAVENGE
;;; The control pdl must be scavenged in a manner similar to the way the registers
;;; are scavenged.  The scavenger must touch those pieces of the dumped call hardware state
;;; which are boxed, and only those which are boxed.

;;; TOOLS FOR THE DEBUGGER TO LOOK AT THEM
;;; It is probably the case that the debugger will run in a different stack group than
;;; the program being debugged.  In this case, the entire state of the call hardware
;;; for the debugged stack group will be represented in a control pdl.


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; at the base of the call hardware stack a CALL has just occurred.
;;; That call will have come from the call stack underflow handler.

;;; The call stack underflow handler (catcher) uses register set #xff for O and A.
;;; At the base of the call stack will be an entry which will return #xff to O and A,
;;; and the RPC will be a routine which preserves the return values, scrolls the call
;;; stack, and returns with the preserved return values.
;;; This is why the call hardware may only be scrolled so that the base is at a call boundary.

;;; These global registers are used by the control pdl code:
;;;  GR:*CONTROL-PDL*		contains the currently active control pdl.
;;;  GR:*CONTROL-PDL-POINTER*	virtual address into the current control pdl where the next
;;;				record will be written as an unboxed locative.
;;;  GR:*CONTROL-PDL-LIMIT*	if GR:*CONTROL-PDL-POINTER* reaches this then the control pdl is full. 
;;;  GR:*CH-BASE-CSP*		the value of the call stack pointer above which the call stack is valid.
;;;  GR:*CH-TEMP-0*		temporaries used by the call hardware dumper and restorer while
;;;  GR:*CH-TEMP-1*		they can't use locals
;;;  GR:*CH-TEMP-2*
;;;  GR:*CH-TEMP-3*
;;;  GR:*CH-TEMP-4*
;;;  GR:*CH-TEMP-5*
;;;  GR:*CH-TEMP-6*
;;;  GR:*CH-CONTROL-PDL-INDEX*	used by the restorer.  (could just be another temporary)
;;;  GR:*NEXT-CONTROL-PDL*	control pdl to context-switch to


;;; The control pdl object.  Control pdls are arrays of type ART-CONTROL-PDL.

;;; At the base of each control pdl are several words used for bookkeeping.  Immediately after
;;; these words the call hardware dump starts.  These words include
;;;    - pointer to the stack group it belongs to
;;;    - the allocation pointer where dumping continues

;;; The limit after which the control pdl structure must be grown to accomodate more call records
;;; can be calculated from the control pdl's size.

;;; Each frame of the control pdl consists of CONTROL-PDL-FRAME-SIZE words.
;;; The first word contains:
;;;    - the type code: OPEN, OPEN-CALL, TOPEN (2 bits), PROTECTED-OPEN-CALL,
;;;    - the return-destination (7 bits),
;;;    - the global return destination (4 bits) and
;;;    - 16 box bits for the saved registers
;;; The second word contains the typed RPC
;;; The third through eighteenth words contain the saved registers.
(defconstant %%cpdl0-type-code		(byte 2 0))
(defconstant %%cpdl0-rdest		(byte 7 2))
(defconstant %%cpdl0-global-frame	(byte 4 9))
(defconstant %%cpdl0-box-bits		(byte 16 16))	;register zero's box bit is LSB of this field
(defconstant $$cpdl0-type-open			0)	;for type code field
(defconstant $$cpdl0-type-open-call		1)
(defconstant $$cpdl0-type-topen			2)
(defconstant $$cpdl0-type-protected-open-call	3)

(defconstant control-pdl-frame-size 18)
(defconstant control-pdl-frame-offset-to-registers 2)

;;; The control pdl could be full of OPEN-CALL TOPEN frames
(defconstant max-call-hardware-dump (* 2 control-pdl-frame-size 256)
  "The largest possible size that a call hardware dump can be")

(defvar control-pdl-area nil
  "This is the area in which control pdls live")

(defun make-control-pdl-area ()
  (when (or (not (boundp 'control-pdl-area))
	    (null control-pdl-area))
    (setq control-pdl-area
	  (area-data:make-area
	    7 (vinc:dpb-multiple-boxed
		(ceiling max-call-hardware-dump vinc:*qs-in-cluster*) 	region-bits:%%region-bits-swapin-quantum
		region-bits:$$scavenge-enabled				region-bits:%%region-bits-scavenge-bit
		region-bits:$$region-read-write				region-bits:%%region-bits-read-only
		region-bits:$$region-space-structure			region-bits:%%region-bits-space-type
		region-bits:$$region-new-space				region-bits:%%region-bits-new-space
		;;; what should this really be:
		region-bits:$$region-fixed				region-bits:%%region-bits-flippable
		region-bits:$$region-internal-memory			region-bits:%%region-bits-external-bus
		0) 10))))
	 
(defconstant control-pdl-allocation-quantum
	     (* 2 max-call-hardware-dump)
  "amount by which a control pdl is grown when it fills up")	;at least enough for one full call hardware dump

;;; The zeroth slot of the control pdl contains a pointer 
;;; back to the stack group to which the control pdl belongs.
(defmacro CONTROL-PDL-STACK-GROUP (control-pdl)
  "Return the stack group associated with the CONTROL-PDL"
  `(array:%vm-read (hw:24+ 1 ,control-pdl)))

(defmacro SET-CONTROL-PDL-STACK-GROUP (control-pdl stack-group)
  "Set the stack group associated with CONTROL-PDL to STACK-GROUP"
  `(array:%vm-write (hw:24+ 1 ,control-pdl) ,stack-group))

;;; The first slot of the control pdl contains the saved value of the control pdl pointer
;;; when the control pdl is not the current one.
(defmacro CONTROL-PDL-POINTER (control-pdl)
  "Return the saved value of CONTROL-PDL's top of stack pointer"
  `(array:%vm-read (hw:24+ 2 ,control-pdl)))

(defmacro SET-CONTROL-PDL-POINTER (control-pdl new-pointer)
  "Changes the saved value of CONTROL-PDL's top of stack pointer to NEW-POINTER"
  `(array:%vm-write (hw:24+ 2 ,control-pdl) ,new-pointer))

(defconstant control-pdl-base 3
  "Add to a control-pdl objects pointer to find the base for call hardware dumps")

(defun make-control-pdl (stack-group &optional (total-size control-pdl-allocation-quantum))
  (setq total-size (* (ceiling (max total-size control-pdl-allocation-quantum)
			       vinc:*qs-in-cluster*)
		      vinc:*qs-in-cluster*))	;must fall on cluster boundary (for ease in wiring).
  (let ((control-pdl (cons:allocate-structure-in-area
		       control-pdl-base					;3 words including header
		       (- total-size 3)
		       vinc:$$dtp-array
		       (vinc:dpb-multiple-boxed
			 (1- total-size)		array::%%bounds	;don't count header word
			 array:art-control-pdl		array::%%sv-art
			 vinc:$$dtp-array-header-single	vinc:%%data-type
			 0)
		       control-pdl-area)))
    ;;; touch each page
    (do ((i 3 (1+ i)))
	((>= i (1- total-size)))
      (array:%vm-write32 control-pdl i (hw:unboxed-constant 0)))
    (set-control-pdl-pointer control-pdl control-pdl-base)
    (set-control-pdl-stack-group control-pdl stack-group)
    control-pdl))

(defun control-pdl-p (object)
  (and (array:arrayp object)
       (= array:art-control-pdl (hw:ldb object array::%%sv-art 0))))

(defsubst control-pdl-empty-p (control-pdl)
  (progn (when (< (control-pdl-pointer control-pdl) control-pdl-base)
	   (error "control-pdl-pointer below control-pdl-base"))
	 (<= (control-pdl-pointer control-pdl) control-pdl-base)))

(defsubst control-pdl-limit (control-pdl)
  "if control-pdl-pointer reaches here we are out of room"
  (hw:ldb (array:%vm-read32 control-pdl 0) array::%%bounds 0))

(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))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The state of the current control pdl is stored in global registers rather than
;;; in the object itself.  These are used to maintain consistency and for context switching.

(defsubst save-control-pdl-state ()
  (set-control-pdl-pointer gr:*control-pdl*
			   (hw:ldb (hw:24- gr:*control-pdl-pointer* gr:*control-pdl*)
				   (byte 24 0) 0)))

(defsubst load-control-pdl-state ()
  (macrolet ((index-to-address (index)
	       `(cons:make-pointer vinc:$$dtp-unboxed-locative
				   (hw:24+ gr:*control-pdl* ,index))))
    (setq gr:*control-pdl-limit*   (index-to-address (control-pdl-limit gr:*control-pdl*))
	  gr:*control-pdl-pointer* (index-to-address (control-pdl-pointer gr:*control-pdl*)))))

(defun select-control-pdl (control-pdl)
  "Set up the global registers associated with the call hardware dump/restore code
to use CONTROL-PDL.  The previous values are stored in the outgoing control pdl"
  ;;; make sure it is a control pdl
  (unless (control-pdl-p control-pdl)
    (trap:illop "~s is not a control pdl" control-pdl))
  (save-control-pdl-state)
  (setq gr:*control-pdl* control-pdl)
  (load-control-pdl-state))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; hooks for the debugger
;;; read and modify registers in a frame

;(defun control-pdl-depth (control-pdl)
;  "Index of topmost frame of control pdl"
;  (floor (- (control-pdl-pointer control-pdl) control-pdl-base)
;	 control-pdl-frame-size))

;(defun control-pdl-frame-info (control-pdl frame-number)
;;  (declare (values type rpc rdest global-frame))
;  (let ((frame-index (+ control-pdl-base (* control-pdl-frame-size frame-number)))
;	word0 word1)
;    (when (>= frame-index (control-pdl-pointer control-pdl))
;      (li:error "frame not in control pdl"))
;    (setq word0 (array:%vm-read32 control-pdl frame-index))
;    (setq word1 (array:%vm-read32 control-pdl (1+ frame-index)))
;    (values (hw:ldb word0 %%cpdl0-type-code 0)		;type
;	    word1					;RPC
;	    (hw:ldb word0 %%cpdl0-rdest	0)		;RDEST
;	    (hw:ldb word0 %%cpdl0-global-frame 0))))	;global frame

;(defun control-pdl-frame-examine-register (control-pdl frame-number register-number)
;  (let ((frame-index (+ control-pdl-base (* control-pdl-frame-size frame-number)))
;	box-bits datum)
;    (when (>= frame-index (control-pdl-pointer control-pdl))
;      (li:error "frame not in control pdl"))
;    (setq box-bits (hw:ldb (array:%vm-read32 control-pdl frame-index) %%cpdl0-box-bits 0))
;    (setq datum (array:%vm-read32 control-pdl (+ control-pdl-frame-offset-to-registers
;						 register-number frame-index)))
;    (if (hw::32logbitp register-number box-bits)
;	(hw:dpb-boxed datum (byte 32 32) (hw:unboxed-constant 0))	;make boxed
;      datum)))								;unboxed

;(defun control-pdl-frame-modify-register (control-pdl frame-number register-number new-value boxed-p)
;  (let ((frame-index (+ control-pdl-base (* control-pdl-frame-size frame-number)))
;	word0)
;    (when (>= frame-index (control-pdl-pointer control-pdl))
;      (li:error "frame not in control pdl"))
;    (setq word0 (array:%vm-read32 control-pdl frame-index))
;    (flet ((change-datum ()
;	     (array:%vm-write32 control-pdl (+ control-pdl-frame-offset-to-registers
;					 register-number frame-index) new-value))
;	   (change-box-bit ()
;	     (array:%vm-write32 control-pdl frame-index
;			  (hw:dpb (hw:dpb (if boxed-p 1 0)
;					  (byte 1 register-number)
;					  (hw:ldb word0 %%cpdl0-box-bits 0))
;				  %%cpdl0-box-bits
;				  word0))))
;      (if boxed-p				;try and do this safely
;	  (progn (change-datum)
;		 (change-box-bit))
;	(progn (change-box-bit)
;	       (change-datum))) )))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(defun scavenge-control-pdl (control-pdl)
;  (macrolet ((scavenge-word (word)
;	       `(hw:vma-start-read ,word)))
;    (SCAVENGE-WORD (control-pdl-stack-group control-pdl))
;    (do ((frame-offset control-pdl-base (+ frame-offset control-pdl-frame-size))
;	 (end (control-pdl-pointer control-pdl))
;	 frame-box-bits)
;	((>= frame-offset end))
;      (setq frame-box-bits (hw:ldb (array:%vm-read32 control-pdl frame-offset)
;				   %%cpdl0-box-bits 0))
;      ;;; scavenge the pc also
;      (dotimes (register 16)
;	(when (hw:32logbitb register frame-box-bits)
;	  (SCAVENGE-WORD (array:%vm-read32 control-pdl			;do we need to make sure it is boxed
;					   (+ frame-offset		;in case the transporter refuses to move it?
;					      control-pdl-frame-offset-to-registers
;					      register)))) )) ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; we should maybe use a vanilla global variable for the interlock
(defmacro DUMPING-OR-RESTORING-CALL-HARDWARE (doing-it)
  (let ((interlock 'gr:*ch-dumper-return-pc*))
    (if doing-it
	`(progn
	   (unless (null ,interlock)
	     (trap:illop "call hardware dump/restore entered recursively"))
	   (setq ,interlock t))
      `(setq ,interlock nil))))

(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")
    ))


;;; when the control pdl and call hardware are scrolled the base of the call hardware
;;; must be an open-call frame so that the underflow catcher can be reached via a return operation.
;;; Since the call hardware dumper and restorer play with traps and can only be invoked while
;;; traps are enabled, this boundary can not fall on an open-call across which traps are disabled.
;;; To prevent the restorer from putting the underflow handler boundary at an open-call across which
;;; traps are disabled, we make the rule that only the trap handler is allowed to disable traps.
;;; We also have the rule that it must reenable traps by the time is goes TRAP-CALL-PROTECTION-COUNT
;;; deep in calls.  When the call hardware dumper sees a return pc that is a trap entry (pc < 64)
;;; it protects the next TRAP-CALL-PROTECTION-COUNT open-calls that is sees by recording them
;;; as being control pdl frame type $$CPDL0-TYPE-PROTECTED-OPEN-CALL rather than $$CPDL0-TYPE-OPEN-CALL.
;;; The restorer only looks for $$CPDL0-TYPE-OPEN-CALL when deciding how much to restore but when
;;; it does restore, it treats both type codes the same.
(defconstant trap-call-protection-count 2)

(defmacro with-dumper-macros (&body body)
  `(macrolet ((previous-a-frame ()	'gr:*ch-temp-0*)
	      (accumulated-box-bits ()	'gr:*ch-temp-1*)
	      (saved-csp ()		'gr:*ch-temp-2*)
	      (protection-count ()	'gr:*ch-temp-3*)
	      (this-rpc ()		'gr:*ch-temp-4*)
	      (word-1 ()		'gr:*ch-temp-5*)
	      (save-register (register)
		`(progn (hw:write-md-unboxed (,register))
			(hw:vma-start-write-no-gc-trap-unboxed gr:*control-pdl-pointer*)
			(setq gr:*control-pdl-pointer* (hw:24+ 1 gr:*control-pdl-pointer*))))
	      (save-box-bit (register)
		`(setf (accumulated-box-bits) (HW:ACCUMULATE-BOX-BITS (accumulated-box-bits) (,register)))))
       ,@body))

;;; CLEAR-R-FRAME, WRITE-OPEN-CALL-FRAME and WRITE-OPEN-FRAME are invoked using the same hack that CONS-REST
;;; is called with.  This allows the function to return to its caller (whose pc is stored in 
;;; GR:*RETURN-PC-1*).  This hack is required so that no call hardware operation is performed
;;; when calling the function or returning from it.  This way we can access the same registers
;;; as our caller.
(defun write-open-call-frame ()
  (with-dumper-macros
    (progn
      (save-register hw:a0)  (save-box-bit hw:a15)   (save-register hw:a1)  (save-box-bit hw:a14)
      (save-register hw:a2)  (save-box-bit hw:a13)   (save-register hw:a3)  (save-box-bit hw:a12)
      (save-register hw:a4)  (save-box-bit hw:a11)   (save-register hw:a5)  (save-box-bit hw:a10)
      (save-register hw:a6)  (save-box-bit hw:a9)    (save-register hw:a7)  (save-box-bit hw:a8)
      (save-register hw:a8)  (save-box-bit hw:a7)    (save-register hw:a9)  (save-box-bit hw:a6)
      (save-register hw:a10) (save-box-bit hw:a5)    (save-register hw:a11) (save-box-bit hw:a4)
      (save-register hw:a12) (save-box-bit hw:a3)    (save-register hw:a13) (save-box-bit hw:a2)
      (save-register hw:a14) (save-box-bit hw:a1)    (save-register hw:a15) (save-box-bit hw:a0))
    (setf (word-1)
	  (hw:dpb-unboxed (if (zerop (protection-count))
			      $$cpdl0-type-open-call
			    (progn (setf (protection-count) (1- (protection-count)))
				   $$cpdl0-type-protected-open-call))
			  %%cpdl0-type-code
			  (word-1)))
    (when (< (hw:ldb (this-rpc) vinc:%%pointer 0) 64.)
      (setf (protection-count) trap-call-protection-count))
    (hw:write-md-unboxed (hw:dpb-unboxed (accumulated-box-bits) %%cpdl0-box-bits (word-1)))
    (hw:vma-start-write-no-gc-trap-unboxed
      (hw:24+ (- control-pdl-frame-size) gr:*control-pdl-pointer*))
    (hw:dispatch (hw:24+ 1 gr:*ch-dumper-return-pc*))))

(defun write-open-frame ()
  (with-dumper-macros
    (progn
      (save-register hw:o0)  (save-box-bit hw:o15)   (save-register hw:o1)  (save-box-bit hw:o14)
      (save-register hw:o2)  (save-box-bit hw:o13)   (save-register hw:o3)  (save-box-bit hw:o12)
      (save-register hw:o4)  (save-box-bit hw:o11)   (save-register hw:o5)  (save-box-bit hw:o10)
      (save-register hw:o6)  (save-box-bit hw:o9)    (save-register hw:o7)  (save-box-bit hw:o8)
      (save-register hw:o8)  (save-box-bit hw:o7)    (save-register hw:o9)  (save-box-bit hw:o6)
      (save-register hw:o10) (save-box-bit hw:o5)    (save-register hw:o11) (save-box-bit hw:o4)
      (save-register hw:o12) (save-box-bit hw:o3)    (save-register hw:o13) (save-box-bit hw:o2)
      (save-register hw:o14) (save-box-bit hw:o1)    (save-register hw:o15) (save-box-bit hw:o0))
    (hw:write-md-unboxed (hw:dpb-unboxed (accumulated-box-bits) %%cpdl0-box-bits (word-1)))
    (hw:vma-start-write-no-gc-trap-unboxed
      (hw:24+ (- control-pdl-frame-size) gr:*control-pdl-pointer*))
    (hw:dispatch (hw:24+ 1 gr:*ch-dumper-return-pc*))))

(defun clear-r-frame ()
  (setf (hw:r0)  (hw:unboxed-constant 0))   (setf (hw:r1)  (hw:unboxed-constant 0))
  (setf (hw:r2)  (hw:unboxed-constant 0))   (setf (hw:r3)  (hw:unboxed-constant 0))
  (setf (hw:r4)  (hw:unboxed-constant 0))   (setf (hw:r5)  (hw:unboxed-constant 0))
  (setf (hw:r6)  (hw:unboxed-constant 0))   (setf (hw:r7)  (hw:unboxed-constant 0))
  (setf (hw:r8)  (hw:unboxed-constant 0))   (setf (hw:r9)  (hw:unboxed-constant 0))
  (setf (hw:r10) (hw:unboxed-constant 0))   (setf (hw:r11) (hw:unboxed-constant 0))
  (setf (hw:r12) (hw:unboxed-constant 0))   (setf (hw:r13) (hw:unboxed-constant 0))
  (setf (hw:r14) (hw:unboxed-constant 0))   (setf (hw:r15) (hw:unboxed-constant 0))
  (hw:dispatch (hw:24+ 1 gr:*return-pc-1*)))

(defun dump-call-hardware ()
  (with-dumper-macros
    (tagbody
	(dumping-or-restoring-call-hardware t)
	(hw:write-processor-control (hw:dpb hw:$$call-heap-underflow-trap-disable
					    hw:%%processor-control-heap-underflow-trap-enable
					    (hw:read-processor-control)))
	(setf (protection-count) 0)
	(setf (previous-a-frame) 256)	;nonexistant
	(setf (saved-csp) (hw:ldb (hw:read-call-sp-hp) hw:%%ch-csphp-call-stack-pointer 0))
	(hw:trap-off)
     loop
	(setq gr:*ch-base-csp* (hw:8-1+ gr:*ch-base-csp*))
	(hw:write-call-sp-hp (hw:dpb-unboxed gr:*ch-base-csp*
					     hw:%%ch-csphp-call-stack-pointer (hw:read-call-sp-hp)))
	(hw:nop) (hw:nop) (hw:nop) (hw:nop) (hw:nop)	;how many do we need?
	(setf (this-rpc) (hw:ldb (hw:read-return-pc-return-dest)
				 hw:%%ch-rpcd-return-pc gr:*trap-dtp-code-5*))
	(setf (word-1) (hw:unboxed-constant 0))
	(setq gr:*ch-temp-6* (hw:ldb (hw:read-return-pc-return-dest)
				     hw:%%ch-rpcd-return-dest (hw:unboxed-constant 0)))
	(setf (word-1) (hw:dpb-unboxed gr:*ch-temp-6* %%cpdl0-rdest (word-1)))
	(setq gr:*ch-temp-6* (hw:ldb (hw:read-processor-status)
				     hw:%%processor-status-global-return-frame
				     (hw:unboxed-constant 0)))
	(setf (word-1) (hw:dpb-unboxed gr:*ch-temp-6* %%cpdl0-global-frame (word-1)))
;	(hw:jump-saving-pc 'clear-r-frame gr:*ch-dumper-return-pc*)
	(hw::ch-return) (hw:nop) (hw:nop) (hw:nop) (hw:nop) (hw:nop)	;do we need these NOPs
	(hw:write-call-sp-hp (hw:dpb-unboxed (saved-csp)
					     hw:%%ch-csphp-call-stack-pointer (hw:read-call-sp-hp)))
	(hw:nop) (hw:nop) (hw:nop) (hw:nop) (hw:nop)
;	(trap:trap-on)
	(hw:write-memory-control
	  (hw:dpb-unboxed hw:$$trap-enable hw:%%memory-control-master-trap-enable
			  (hw:read-memory-control)))
	(hw:nop) (hw:nop) (hw:nop) (hw:nop)
	(hw:write-md-unboxed (this-rpc))
	(hw:vma-start-write-no-gc-trap-unboxed (hw:24+ 1 gr:*control-pdl-pointer*))
	(setq gr:*ch-temp-6* (hw:ldb (hw:read-open-active-return) hw:%%ch-oar-active 0))
	(setq gr:*control-pdl-pointer* (hw:24+ control-pdl-frame-offset-to-registers
					       gr:*control-pdl-pointer*))
	(cond ((= gr:*ch-temp-6*
		  (hw:ldb (hw:read-open-active-return) hw:%%ch-oar-open 0))	;OPEN-CALL
	       (hw:jump-saving-pc 'write-open-call-frame gr:*ch-dumper-return-pc*)
	       (setf (previous-a-frame) (hw:ldb (hw:read-open-active-return) hw:%%ch-oar-active 0))
	       (hw:trap-off))
	      ((= gr:*ch-temp-6* (previous-a-frame))		;OPEN
	       (setf (word-1) (hw:dpb-unboxed $$cpdl0-type-open %%cpdl0-type-code (word-1)))
	       (hw:jump-saving-pc 'write-open-frame gr:*ch-dumper-return-pc*)
	       (setf (previous-a-frame) (hw:ldb (hw:read-open-active-return) hw:%%ch-oar-active 0))
	       (hw:trap-off)
	       (hw:ch-tcall)
	       (hw:ch-topen-call)
	       (hw:ch-topen))
	      (t				;OPEN-CALL TOPEN
	       (hw:jump-saving-pc 'write-open-call-frame gr:*ch-dumper-return-pc*)
	       (setq gr:*control-pdl-pointer* (hw:24+ control-pdl-frame-offset-to-registers
						      gr:*control-pdl-pointer*))
	       (setf (word-1) (hw:dpb-unboxed $$cpdl0-type-topen %%cpdl0-type-code (word-1)))
	       (hw:jump-saving-pc 'write-open-frame gr:*ch-dumper-return-pc*)
	       (setf (previous-a-frame) (hw:ldb (hw:read-open-active-return) hw:%%ch-oar-active 0))
	       (hw:trap-off)
	       (hw::ch-tcall)))
	(unless (= gr:*ch-base-csp* (saved-csp))
	  (go loop))
     end
	(hw:ch-tcall)
	(hw:write-processor-control (hw:dpb hw:$$call-heap-underflow-trap-enable
					    hw:%%processor-control-heap-underflow-trap-enable
					    (hw:read-processor-control)))
	(trap:trap-on))
    (select-control-pdl gr:*next-control-pdl*)
    (restore-call-hardware)))