;;; -*- Mode:LISP; Package:LAMBDA; Base:8; Readtable:ZL -*-


;;; Copyright LISP Machine, Inc. 1986
;;;   See filename "Copyright.Text" for		
;;; licensing and release information.


;;;  4 cycle instructions
;;;     source,		write C-PDL, 		write-M, 	dispatch
;;;     source, 	write C-PDL, 		write-M,	slow-dest write
;;;     
;;;  3
;;;     source,		write M,		dispatch
;;;     source,		no-op,			dispatch
;;;     source,		write M,		slow-dest write
;;;	source,		no-op,			slow-dest write
;;;	source,		write M,		delay-for-jump
;;;     srouce,         write C-PDL,		write-M
;;;
;;;  2
;;;     source,		write M
;;;     source,		no-op
;;;

(defconst frist-free-3xxx-adr #o3020)

(defconst tram-dest-seq-normal 0)
(defconst tram-dest-seq-write-a 1)
(defconst tram-dest-seq-write-m 2)
(defconst tram-dest-seq-write-cpp 3)
(defconst tram-dest-seq-write-m-and-cpp 4)
(defconst tram-dest-seq-write-cpi 5)
(defconst tram-dest-seq-write-m-and-cpi 6)

;tram.am.from.write.address
;   0 - source address from cram
;   1 - dest address from pipeline
; the address is latched on sm.clock, so the bit has to be backed up by one.
; Therefore, every last execute cycle has to have it 0, and it has to be
; 1 in the cycle before doing a write-enable to A memory.
; During a dispatch, it has to be back to 0 in the cycle before the dispatch itself
;  (the last execute cycle)
; Therefore, we make it 0 in all execute cycles, and 1 in all source cycles.
;
;  We fill in this bit after everything else is done.

;tram.a.address.from.dispatch
;   0 always except in the last cycle of a dispatch

; tram.a.clock.next tram.m.clock.next
; these are now latches instead of registers
; but are still delayed by one in the hardware
;
; We need the enable signals on the chips to look like this:
;
;    |  dispatch |  any  |
;    | S | E | E | S | E |
;    |___|   |___|___|   |
;    |   \___/   |   \___|   tram.a.clock.next
;    |   |   |   |   |   |   1 = pass, 0 = hold
;    |   |   |   |   |   |
;    |___|   |   |___|   |
;    |   \___|___/   \___|   tram.m.clock.next
;
; That is, it sould be one for the source cycle, then 0 for all of the execute
; cycles, except that the A clock has to return to 1 during the last cycle of a dispatch.
;
; Therefore, this will be implemented by copying tram.source.cycle, and then modifying
; the second to last cycles of the dispatches for A.

; TRAM.NEW.UINST TRAM.FIRST.SOURCE.CYCLE.NEXT
; These are 1 in the last execute cycle, and 0 everywhere else.
; Also implies tram.next.select = 1 and tram.state = 0

(defvar tram-plists (make-array 4000))
(defvar new-tram-array (make-array 10000))
  
(defun new-hh-init-tram (&optional ignore &key check)
  (hh-make-new-tram-array)
  (cond ((null check)
	 (write-hh-new-tram-array-to-tram))
	(t
	 (check-hh-new-tram-array-against-tram))))

(defun try-new-tram ()
  (hh-make-new-tram-array)
  (write-hh-new-tram-array-to-tram)
  (flush))

(defun write-hh-new-tram-array-to-tram ()
  (format t "~&Writing ~a's tram ..."
	  (time:day-of-the-week-string (nth-value 6 (time:get-decoded-time))))
  (dotimes (adr 10000)
    (write-tram adr (aref new-tram-array adr)))
  (setq tram-location-3000 nil)
  (format t " done.")
  )

(defun check-hh-new-tram-array-against-tram ()
  (format t "~&Checking new tram ...")
  (dotimes (adr 10000)
    (if (not (= (read-tram adr) (aref new-tram-array adr)))
	(format t "~&Adr ~o, is ~o should be ~o"
		adr (read-tram adr) (aref new-tram-array adr))))
  (format t " done."))

(defvar active-low-tram-bits)

(DEFUN hh-make-new-tram-array ()
  (setq active-low-tram-bits
	(update-value '(TRAM.M.WE-L 1
				    TRAM.A.WE-L 1
				    TRAM.L.TO.A-L 1
				    TRAM.L.TO.M-L 1)))
	   
  ;initialize to error jump
  (array-initialize new-tram-array
		    (update-value '(TRAM.NEXT.SELECT 1
						     TRAM.STATE 7) active-low-tram-bits))
		    
  (array-initialize tram-plists nil)

  (hh-tram-m-cycles)

  (reset-3xxx-data)

  ;;1003 used as scratch by write-treg-via-tram


  ;;1005 used by force-source-codeword
  ;;   clear a.clock.next, m.clock.next, then jump to 3000
  (aset (make-plist-from-codeword-description
	  '(:dont-change t
			 :fixed-next-cycle-number 1
			 tram.next.cycle.number 1
			 tram.state 17
			 tram.first.source.cycle.next 0
			 tram.next.select 1
			 tram.new.uinst 0
			 tram.a.clock.next 1
			 tram.m.clock.next 1))
	tram-plists 1005)

  (aset (make-plist-from-codeword-description
	  '(:dont-change t
			 :fixed-next-cycle-number 0
			 tram.next.cycle.number 0
			 tram.state 0
			 tram.first.source.cycle.next 1
			 tram.next.select 1
			 tram.new.uinst 0
			 tram.a.clock.next 1
			 tram.m.clock.next 1))
	tram-plists 3017)


  ;;3000 The SOURCE dispatch
  (aset (make-plist-from-codeword-description
	  '(:source-cycle t
			  :fixed-next-cycle-number 1
			  tram.next.select 0
			  TRAM.L.TO.a-L 0
			  TRAM.L.TO.m-L 0
			  ))
	tram-plists 3000)

  ;;3007 error loop
  (aset (make-plist-from-codeword-description
	  '(:fixed-next-cycle-number 1
				   :error t
			  TRAM.NEXT.SELECT 1
			  TRAM.STATE 7))
	tram-plists 3007)

  (DOTIMES (ADR 1000)
    (LET ((DEST-SEQ (LDB (BYTE 3 0) ADR))
	  (SLOW-DEST (LDB (BYTE 1 3) ADR))
	  (UNUSED (LDB (BYTE 1 4) ADR))
	  (NO-OP (LDB (BYTE 1 5) ADR))
	  (ILONG (LDB (BYTE 1 6) ADR))
	  (OPCODE (LDB (BYTE 2 7) ADR))
	  plist
	  )
      (cond ((or (= dest-seq 7)
		 (not (zerop unused)))
	     (setq plist (make-plist-from-codeword-description
			   '(tram.next.select 1
					      :error t
					      :fixed-next-cycle-number 1
					      tram.state 7))))
	    (t
	     ;;First create the first execute codeword for the current instruction.
	     ;;pretend it's an ALU op if it's nooped anyway
	     (setq plist (make-execute-cycle-plist (if (zerop no-op) opcode 0) dest-seq))
	
	     ;;don't drive MFO during NO-OP cycles
	     (if (not (zerop no-op))
		 (putprop plist t :dont-drive-mfo))

	     (if (not (zerop slow-dest))
		 (putprop plist t :slow-dest))
	     
	     (if (not (zerop ilong))
		 (putprop plist t :ilong))
	     ))

      (aset plist tram-plists adr)
      )
    )

  (dotimes (adr frist-free-3xxx-adr)
    (let ((plist (aref tram-plists adr))
	  inst dispatch-or-slow-dest-plist write-m-plist)
      (when plist
	(if (null (get plist :fixed-next-cycle-number))
	    (putprop plist 2 :next-cycle-number))	;will be changed to 0 if only 2 cycle inst

	(setq inst (update-value (get plist :bit-descriptions) active-low-tram-bits))

	(if (get plist :dont-drive-mfo)
	    (setq inst (dpb 0 tram.data.paths.to.mfo inst)))

	(cond ((get plist :slow-dest)
	       (setq dispatch-or-slow-dest-plist
		     (make-plist-from-codeword-description
		       `(:next-cycle-number
			  0
			  tram.slow.dest.write 1
			  TRAM.DATA.PATHS.TO.MFO ,(ldb tram.data.paths.to.mfo inst)
			  TRAM.A.ADDRESS.CONTROL ,(ldb tram.a.address.control inst)
			  )))
	       ))

	(cond ((get plist :finish-dispatch)
	       (setq dispatch-or-slow-dest-plist
		     (make-plist-from-codeword-description
		       '(:next-cycle-number 0
					    TRAM.DATA.PATHS.TO.MFO 1
					    TRAM.A.address.from.dispatch 1
					    )))))
	
	(cond ((get plist :write-m)
	       (setq write-m-plist
		     (make-plist-from-codeword-description
		       '(TRAM.DATA.PATHS.TO.MFO 1
						TRAM.M.WE-L 0
						TRAM.A.WE-L 0)))))

	(cond (dispatch-or-slow-dest-plist
	       (cond ((null write-m-plist)
		      (putprop plist
			       (remember-3xxx-tram-cycle (compute-tram-inst
							   dispatch-or-slow-dest-plist))
			       :goto)
		      (if (get plist :finish-dispatch)
			  (putprop plist t :second-to-last-dispatch-cycle))
		      (store-tram-cycle plist adr inst))
		     (t
		      (putprop write-m-plist 
			       (remember-3xxx-tram-cycle (compute-tram-inst
							   dispatch-or-slow-dest-plist))
			       :goto)
		      (putprop write-m-plist 3 :next-cycle-number)
		      (if (get plist :finish-dispatch)
			  (putprop write-m-plist t :second-to-last-dispatch-cycle))
		      (putprop plist
			       (remember-3xxx-tram-cycle (compute-tram-inst write-m-plist))
			       :goto)
		      (store-tram-cycle plist adr inst))))
	      (write-m-plist
	       (putprop write-m-plist 0 :next-cycle-number)
	       (putprop plist
			(remember-3xxx-tram-cycle (compute-tram-inst write-m-plist))
			:goto)
	       (store-tram-cycle plist adr inst))
	      (t
	       (if (and (null (get plist :error))
			(null (get plist :fixed-next-cycle-number)))
		   (putprop plist 0 :next-cycle-number))
	       (store-tram-cycle plist adr inst))))))

	     
  (aset (update-value '(tram.next.select 1
			  TRAM.L.TO.a-L 0
			  TRAM.L.TO.m-L 0
			  tram.next.cycle.number 1
					 tram.state 0)
		      active-low-tram-bits)
	new-tram-array
	7000)


  (store-3xxx-tram-cycles)

  (copy-next-cycle-number-to-m-address-control)
  )

(defun copy-next-cycle-number-to-m-address-control ()
  (dotimes (adr 10000)
    (setf (ldb tram.m.address.control (aref new-tram-array adr))
	  (ldb tram.next.cycle.number (aref new-tram-array adr)))))

(defun fix-7000-cycles ()
  (do* ((adr 4000 (1+ adr))
	inst)
       ((= adr 10000))
    (if (= adr 5000)
	(setq adr 7000))
    (setq inst (aref new-tram-array adr))
    (cond ((zerop (ldb tram.next.cycle.number inst))
	   (setq inst (dpb 1 tram.next.cycle.number inst))
	   (setq inst (dpb 0 tram.first.source.cycle.next inst))
	   (setq inst (dpb 0 tram.new.uinst inst))
	   (setq inst (dpb 0 tram.a.clock.next inst))
	   (setq inst (dpb 0 tram.m.clock.next inst))
	   (aset inst new-tram-array adr)
	   ))))

(defvar tram-3xxx-alist nil)
(defvar tram-3xxx-highest-address-used nil)

(defun reset-3xxx-data ()
  (setq tram-3xxx-alist nil
	tram-3xxx-highest-address-used frist-free-3xxx-adr))

(defun allocate-tram-3xxx-address ()
  (cond ((>= tram-3xxx-highest-address-used 3377)
	 (ferror nil "ran out of 3xxx addresses"))
	(t (incf tram-3xxx-highest-address-used))))

(defun remember-3xxx-tram-cycle (inst)
  (let ((old (assoc inst tram-3xxx-alist)))
    (cond ((null old)
	   (let ((adr (allocate-tram-3xxx-address)))
	     (push (cons inst adr) tram-3xxx-alist)
	     adr))
	  (t
	   (cdr old)))))

(defun store-3xxx-tram-cycles ()
  (dolist (l tram-3xxx-alist)
    (aset (car l) new-tram-array (cdr l))
    (aset (car l) new-tram-array (+ 4000 (cdr l)))))

(defvar bits-to-fill-in-at-the-end (logior (dpb 1 tram.am.from.write.address 0)
					   (dpb 1 tram.NEW.UINST 0)
					   (dpb 1 tram.a.clock.next 0)
					   (dpb 1 tram.m.clock.next 0)
					   (dpb 1 tram.first.source.cycle.next 0)))

(defun store-tram-cycle (plist adr inst)
  (let ((new-inst (compute-tram-inst plist inst)))
    (aset new-inst new-tram-array adr)
    (aset new-inst new-tram-array (+ adr 4000))))

(defun compute-tram-inst (plist &optional inst)
  (if (null inst)
      (setq inst (update-value (get plist :bit-descriptions) active-low-tram-bits)))

  (cond ((null plist))
	((get plist :dont-change))
	(t
	 (if (not (zerop (logand bits-to-fill-in-at-the-end inst)))
	     (ferror nil "special bits already on"))

	 (if (get plist :source-cycle)
	     (setq inst (dpb 1 tram.am.from.write.address inst)))
	 
	 (if (get plist :next-cycle-number)
	     (setq inst (dpb (get plist :next-cycle-number) tram.next.cycle.number inst)))

	 (if (get plist :fixed-next-cycle-number)
	     (setq inst (dpb (get plist :fixed-next-cycle-number) tram.next.cycle.number inst)))

	 (when (get plist :goto)
	   (setq inst (dpb 1 tram.next.select inst))
	   (setq inst (dpb (get plist :goto) tram.state inst)))

	 (cond ((zerop (ldb tram.next.cycle.number inst))
		;; this is last execute cycle
		(if (not (zerop (ldb tram.state inst)))
		    (ferror nil "last execute cycle, but next state is not 0"))
		(setq inst (dpb 1 tram.first.source.cycle.next inst))
		(setq inst (dpb 1 tram.next.select inst))
		(setq inst (dpb 1 tram.new.uinst inst))
		(setq inst (dpb 1 tram.a.clock.next inst))
		(setq inst (dpb 1 tram.m.clock.next inst)))
	       (t
		(setq inst (dpb 0 tram.first.source.cycle.next inst))
		(setq inst (dpb 0 tram.new.uinst inst))
		(setq inst (dpb 0 tram.a.clock.next inst))
		(setq inst (dpb 0 tram.m.clock.next inst))))

	 (if (get plist :second-to-last-dispatch-cycle)
	     (setq inst (dpb 1 tram.a.clock.next inst)))

	 ))

  inst)

(defun make-plist-from-codeword-description (codeword-description &aux plist bit-descriptions)
  (setq plist (ncons nil))
  (do ((clause codeword-description (cddr clause)))
      ((null clause))
    (cond ((keywordp (car clause))
	   (putprop plist (cadr clause) (car clause)))
	  (t
	   (push (cadr clause) bit-descriptions)
	   (push (car clause) bit-descriptions))))
  (putprop plist bit-descriptions :bit-descriptions)
  plist)

(defun make-execute-cycle-plist (opcode dest-seq)
  (let ((codeword-description
	  (SELECTQ OPCODE
	    ;;ALU 
	    (0
	     (make-execute-codeword-for-alu dest-seq))
	    ;;BYTE
	    (1
	     (make-execute-codeword-for-byte dest-seq))
	    ;;JUMP
	    (2
	     (make-execute-codeword-for-jump dest-seq))
	    ;;Dispatch
	    (3
	     (make-execute-codeword-for-dispatch dest-seq)))))
    (make-plist-from-codeword-description codeword-description)))


(deff make-execute-codeword-for-byte 'make-execute-codeword-for-alu)
(deff make-execute-codeword-for-jump 'make-execute-codeword-for-alu)

(defun make-execute-codeword-for-alu (dest-seq)
  (ecase DEST-SEQ
    (0 '(TRAM.DATA.PATHS.TO.MFO 1))
    ;;write A
    (1 '(TRAM.DATA.PATHS.TO.MFO 1
				TRAM.A.WE-L 0
				))
    ;;write M
    (2 '(TRAM.DATA.PATHS.TO.MFO 1
				TRAM.M.WE-L 0
				TRAM.A.WE-L 0))
    ;;write C-PDL-BUFFER-POINTER
    (3 '(TRAM.DATA.PATHS.TO.MFO 1
				TRAM.M.WE-L 0
				))
    ;;write C-PDL-BUFFER-POINTER, then write M
    (4 '(TRAM.DATA.PATHS.TO.MFO 1
				TRAM.M.WE-L 0
				TRAM.L.TO.m-L 0
				:write-m t))
    ;;write C-PDL-BUFFER-INDEX
    (5 '(TRAM.DATA.PATHS.TO.MFO 1
				TRAM.M.WE-L 0
				))
    ;;write C-PDL-BUFFER-INDEX, then write M
    (6 '(TRAM.DATA.PATHS.TO.MFO 1
				TRAM.M.WE-L 0
				TRAM.L.TO.m-L 0
				:write-m t))
    (7 nil)
    ))

(defun make-execute-codeword-for-dispatch (dest-seq)
  (ecase DEST-SEQ
    (0 '(TRAM.DATA.PATHS.TO.MFO 1
				:finish-dispatch t))
    ;;write A
    (1 '(TRAM.DATA.PATHS.TO.MFO 1
				 TRAM.A.WE-L 0
				 :finish-dispatch t))
    ;;write M
    (2 '(TRAM.DATA.PATHS.TO.MFO 1
				TRAM.M.WE-L 0
				TRAM.A.WE-L 0
				:finish-dispatch t))
    ;;write C-PDL-BUFFER-POINTER
    (3 '(TRAM.DATA.PATHS.TO.MFO 1
				TRAM.M.WE-L 0
				:finish-dispatch t))
    ;;write C-PDL-BUFFER-POINTER then write M
    (4 '(TRAM.DATA.PATHS.TO.MFO 1
				TRAM.M.WE-L 0
				TRAM.L.TO.m-L 0
				:write-m t
				:finish-dispatch t))
    ;;write C-PDL-BUFFER-INDEX
    (5 '(TRAM.DATA.PATHS.TO.MFO 1
				TRAM.M.WE-L 0
				:finish-dispatch t))
    ;;write C-PDL-BUFFER-INDEX then write M
    (6 '(TRAM.DATA.PATHS.TO.MFO 1
				TRAM.M.WE-L 0
				TRAM.L.TO.m-L 0
				:write-m t
				:finish-dispatch t))
    (7 nil)))


(DEFUN TEST-hh-M-MEM-DATA-PATH NIL (TEST-DATA-PATH "M-MEM"'hh-M-MEM-DATA-PATH-ACTOR 32.))
(DEFSELECT (hh-M-MEM-DATA-PATH-ACTOR)
  (:READ (ADDRESS) ADDRESS
    (hh-read-m-mem 1))
  (:WRITE (ADDRESS DATA) ADDRESS
    (hh-WRITE-M-MEM 1 DATA)))

(DEFUN TEST-hh-A-MEM-DATA-PATH NIL (TEST-DATA-PATH "A-MEM"'hh-A-MEM-DATA-PATH-ACTOR 32.))
(DEFSELECT (hh-A-MEM-DATA-PATH-ACTOR)
  (:READ (ADDRESS) ADDRESS
    (hh-read-a-mem 1))
  (:WRITE (ADDRESS DATA) ADDRESS
    (hh-WRITE-a-MEM 1 DATA)))


(defun hh-tram-m-cycles ()
  (aset (make-plist-from-codeword-description
	  '(tram.next.cycle.number 0
	    tram.next.select 1
	    tram.state 21
	    tram.first.source.cycle.next 1
	    tram.new.uinst 1
	    tram.a.clock.next 1
	    tram.m.clock.next 1
	    :dont-change t))
	tram-plists 3020)
  ;;source cycle for jump
  (aset (make-plist-from-codeword-description
	  '(tram.am.from.write.address 1
	    tram.next.select 1
	    tram.state 22
	    tram.next.cycle.number 1
	    :dont-change t))
	tram-plists 3021)
  ;;write ireg here

  ;;don't need execute cycle for jump

  ;;now fake first source cycle of 2 source cycles

  ;;new.uinst to clock L register
  ;;source.cycle.next addresses flow through to A memory
  ;;next.cycle.number is 1 so dont get A or M CS which would prevent
  ;; source data from getting to A and M latches
  ;;A and M clock next so data goes through latches
  (aset (make-plist-from-codeword-description
	  '(tram.next.cycle.number 1
	    tram.first.source.cycle.next 1
	    tram.a.clock.next 1
	    tram.m.clock.next 1
	    tram.data.paths.to.mfo 0
	    tram.new.uinst 1
	    tram.next.select 1
	    tram.state 23
	    :dont-change t))
	tram-plists 3022)
  
  ;;now second fake source cycle
  ;;next.cycle.number 1 makes write pulse after this cycle
  ;;first.source.cycle.next & a.address.control is low so pipeline
  ;;  address will go to A and M memory
  ;;l.to.a and M pass data back to memorys
  (aset (make-plist-from-codeword-description
	  '(tram.next.cycle.number 1
	    tram.first.source.cycle.next 0
	    TRAM.A.address.from.dispatch 0
	    tram.am.from.write.address 1
	    tram.m.address.control 1
	    tram.l.to.a-l 0
	    tram.l.to.m-l 0
	    tram.next.select 1
	    tram.state 24
	    :dont-change t))
	tram-plists 3023)

  ;;get ready to do write
  (aset (make-plist-from-codeword-description
	  '(tram.next.cycle.number 1
	    tram.first.source.cycle.next 0
	    TRAM.A.address.from.dispatch 0
	    tram.am.from.write.address 1
	    tram.m.address.control 1
	    tram.a.clock.next 1
	    tram.m.clock.next 1
	    tram.data.paths.to.mfo 0
	    tram.l.to.a-l 0
	    tram.l.to.m-l 0
	    tram.next.select 1
	    tram.state 25
	    :dont-change t))
	tram-plists 3024)

  ;;Write finally happens here when small chip select pulse is generated between
  ;;  these two.
  ;;Also, set next.cycle.number so no more writes will happen
  (aset (make-plist-from-codeword-description
	  '(tram.next.cycle.number 0
	    tram.data.paths.to.mfo 1
	    tram.new.uinst 1
	    tram.next.select 1
	    tram.state 26
	    :dont-change t))
	tram-plists 3025)

  ;;have to write 0 into ireg here

  (aset (make-plist-from-codeword-description
	  '(tram.next.cycle.number 1
	    tram.first.source.cycle.next 0))
	tram-plists 3026)

  ;;--- now stuff for reads

  ;;pre source cycle for jump
  (aset (make-plist-from-codeword-description
	  '(tram.next.cycle.number 0
	    tram.next.select 1
	    tram.state 31
	    tram.first.source.cycle.next 1
	    tram.new.uinst 1
	    tram.a.clock.next 1
	    tram.m.clock.next 1
	    :dont-change t))
	tram-plists 3030)
	  
  ;;source cycle for jump
  (aset (make-plist-from-codeword-description
	  '(tram.am.from.write.address 0
	    tram.next.select 1
	    tram.state 32
	    tram.next.cycle.number 1
	    :dont-change t))
	tram-plists 3031)

  ;;write ireg from cram here

  ;;don't need execute cycle for jump

  (aset (make-plist-from-codeword-description
	  '(tram.next.cycle.number 0
	    tram.first.source.cycle.next 1
	    TRAM.A.address.from.dispatch 0
	    tram.am.from.write.address 0
	    tram.m.address.control 3
	    tram.a.clock.next 1
	    tram.m.clock.next 1
	    tram.data.paths.to.mfo 1
	    :dont-change t))
	tram-plists 3032)

  (setq frist-free-3xxx-adr 3040)
  )

(defun hh-write-m-mem (adr data)
  (force-source-codeword)
  (let ((write-m-inst (lam-execute (return)
		       lam-ir-op lam-op-alu
		       lam-ir-ob lam-ob-alu
		       lam-ir-aluf lam-alu-setm
		       lam-ir-m-src lam-m-src-spy-reg
		       lam-ir-m-mem-dest adr)))
    (write-cram-dont-worry-about-parity 0 write-m-inst)
    (write-cram-dont-worry-about-parity 1 write-m-inst))

  (hh-write-a-or-m-common data))

(defun hh-write-a-mem (adr data)
  (force-source-codeword)
  (let ((write-m-inst (lam-execute (return)
		       lam-ir-op lam-op-alu
		       lam-ir-ob lam-ob-alu
		       lam-ir-aluf lam-alu-setm
		       lam-ir-m-src lam-m-src-spy-reg
		       lam-ir-a-mem-dest-flag 1
		       lam-ir-a-mem-dest adr)))
    (write-cram-dont-worry-about-parity 0 write-m-inst)
    (write-cram-dont-worry-about-parity 1 write-m-inst))

  (hh-write-a-or-m-common data))

(defun hh-write-a-or-m-common (data)
  ;;setup-machine-to-start-at
  (ASSURE-NOOP-CLEARED)
  (write-ireg (LAM-EXECUTE (return)
	       LAM-IR-OP LAM-OP-JUMP
	       LAM-IR-JUMP-ADDR 0
	       LAM-IR-N 0
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC))

  (LET ((PMR (READ-PMR)))
    (CHANGE-PMR '(SPY-ADDRESS-TRAM-L 0 ALLOW-UINST-CLOCKS 0))

    (WRITE-TRAM-ADR 3020)
    (simple-SM-TICK 2)
    (WRITE-PMR PMR))

  (write-spy-reg data)

  (simple-sm-tick 2)
  (write-ireg (read-cram))
  (simple-sm-tick 4)
  (write-ireg 0)
  (simple-sm-tick 1)
  (force-source-codeword))

(defun hh-read-m-mem (adr)
  (let ((inst (lam-execute (return)
			   lam-ir-op lam-op-alu
			   lam-ir-ob lam-ob-alu
			   lam-ir-aluf lam-alu-setm
			   lam-ir-m-src adr
			   )))
    (write-cram 0 inst)
    (write-cram 1 inst))

  (hh-read-a-or-m-common))

(defun hh-read-a-mem (adr)
  (force-source-codeword)
  (let ((inst (lam-execute (return)
			   lam-ir-op lam-op-alu
			   lam-ir-ob lam-ob-alu
			   lam-ir-aluf lam-alu-seta
			   lam-ir-a-src adr
			   )))
    (write-cram 0 inst)
    (write-cram 1 inst))

  (hh-read-a-or-m-common))

(defun hh-read-a-or-m-common (&aux data)
  (assure-noop-cleared)
  (write-ireg (LAM-EXECUTE (return)
	       LAM-IR-OP LAM-OP-JUMP
	       LAM-IR-JUMP-ADDR 0
	       LAM-IR-N 0
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC))

  (LET ((PMR (READ-PMR)))
    (CHANGE-PMR '(SPY-ADDRESS-TRAM-L 0 ALLOW-UINST-CLOCKS 0))

    (WRITE-TRAM-ADR 3030)
    (simple-SM-TICK 2)
    (WRITE-PMR PMR))

  (simple-sm-tick 2)
  (write-ireg (read-cram))
  (simple-sm-tick 1)
  (setq data (read-mfo))
  (force-source-codeword)
  data)
  

(defun hh-read-a-mem (adr &aux data)
  (force-source-codeword)
  (let ((inst (lam-execute (return)
			   lam-ir-op lam-op-alu
			   lam-ir-ob lam-ob-alu
			   lam-ir-aluf lam-alu-seta
			   lam-ir-a-src adr
			   )))
    (write-cram 0 inst)
    (write-cram 1 inst))

  ;;setup-machine-to-start-at
  (ASSURE-NOOP-CLEARED)
  (write-ireg (LAM-EXECUTE (return)
	       LAM-IR-OP LAM-OP-JUMP
	       LAM-IR-JUMP-ADDR 0
	       LAM-IR-N 0
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC))

  (LET ((PMR (READ-PMR)))
    (CHANGE-PMR '(SPY-ADDRESS-TRAM-L 0 ALLOW-UINST-CLOCKS 0))

    (WRITE-TRAM-ADR 3030)
    (simple-SM-TICK 2)
    (WRITE-PMR PMR))

  (simple-sm-tick 2)
  (write-ireg (read-cram))
  (simple-sm-tick 1)
  (setq data (read-mfo))
  (force-source-codeword)
  data
  )