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

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