;;; -*- Mode:LISP; Package:(MICRO GLOBAL); Base:8; Readtable:ZL -*-

;;; 2/21/86
;;; Pace Willisson at LMI
;;;

;;; This is an incremental micro assembler for LAMBDA.  I don't have
;;; time to write a lot of documentation about it, but I'll get some
;;; thoughts down before I stop working on it for a while.

;;; This assembler is mostly compatable with the syntax of the old
;;; assembler LAMLP (and before that CADRLP, I think.)  Someday, it may
;;; be expanded enough to replace LAMLP.

;;; At this point, the way to use it is to write a form like:
;;;
;;;    (define-micro-function car-if-list (l)
;;;      ((m-t) pdl-pop)
;;;      (popj-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-list)))
;;;      ((vma-start-read) m-t)
;;;      (check-page-read)
;;;      (dispatch transport md)
;;;      ((m-t) md)
;;;      (popj))
;;;
;;; DEFINE-MICRO-FUNCTION is a macro that assembles the instructions into
;;; a relocatable format (very similar to the micro-compiler format, but 
;;; not compatable) and arranges to install the instructions in control
;;; memory, and define the name as a DTP-U-ENTRY.  Currently, all of this
;;; happens at load time, but soon the assembly will happen at compile
;;; time.

;;; I haven't addressed the problems of warm boots, or of having such 
;;; functions in saved bands.  We can depend on the micro-code-paging
;;; area to stay loaded during a warm boot on the lambda (this was not true
;;; for the cadr.)  However, we will need a BEFORE-COLD initialization
;;; to turn all of the incremental DTP-U-ENTRYs into regular functions
;;; (an undefine function or even NIL is OK.), and probably a SYSTEM
;;; initialization to put them back.

;;; By the way, there is a bug in the microcode (at least
;;; up to version 1371) that causes the MICRO-CODE-PAGING-AREA to be reloaded
;;; from the LMC file during a warm boot.  This makes breakpoints go away
;;; in initially loaded pagable microcode, but I guess wont affect
;;; incremental stuff.

;;; The way this thing allocates control and A memories is not compatable
;;; with the micro-compiler, so the pair should not be loaded into the
;;; same band.  We will be able to fix this later.

;;; The function MICRO-PRINT disassembles a MICRO-FUNCTION.  You need to 
;;; have lambda diag loaded, and it is more interesting if you have 
;;; the running symbol table loaded also.  (Yes, this means that the symbol
;;; table has to be loaded twice, once for IMICRO and once for LAMBDA-DIAG,
;;; that will change someday also.
;;; Here is a handy idiom for the lambda-diag symbol table:
;;;
;;;    (when (null (lam::lam-select-symbols-for-version-if-possible
;;;                  %microcode-version-number))
;;;      (lam::lam-load-ucode-symbols-for-version
;;;        %microcode-version-number))

;;; At the moment, files that use DEFINE-MICRO-FUNCTION should be in the MICRO
;;; package.

;;; The instructions you write are for a MISC instruction.  Look through the
;;; microcode for (misc-inst-entry ...) to see many examples.

;;; Of course, there are many unimplemented instructions.  Among the important
;;; are GC-WRITE-TEST and CHECK-PAGE-WRITE.  They will eventually be available.


;;; The major parts of IMICRO are:
;;;   process-instruction
;;;     uses the definitions in the file LAMBDA-COMPONENTS to build a numeric 
;;;     instructions out of a symbolic list
;;;   micro-assemble-list
;;;     calls process-instruction on a whole program, and takes care of inserting
;;;     no-ops for micro-paging
;;;   the macro DEFINE-MICRO-FUNCTION
;;;     assembles the program and stores it on the property list of the symbol,
;;;     attempts to use RECORD-SOURCE-FILE-NAME to do the normal redefinition 
;;;     warning thing, and calls INSTALL
;;;   INSTALL/UNINSTALL
;;;     these take care of control memory allocation, and allocation of slots in
;;;     the micro-code-entry-area and micro-code-symbol-area, and storing
;;;     programs in control memory
;;;   I-MEM-BLOCK allocator
;;;     this manages free control memory.  you can ask for blocks of any length,
;;;     and require any alignment.  for example, IMICRO always asks for blocks 
;;;     that begin on micro-page boundaries.  the allocator can handle different
;;;     alignment requirements at the same time so that it can eventually be used
;;;     with the micro compiler too.
;;;   instruction macro processor
;;;     if the car of an instruction has a property MICRO:MICRO-MACRO, then it is
;;;     a function that is called with the whole instruction as an argument.
;;;     It returns a list of instructions to be used instead.
;;;   symbol macro processor
;;;     if a symbol in an instruction has the property MICRO:MICRO-EXPAND
;;;     it is a function to call, and it returns a list of symbols to be
;;;     spliced into the instruction instead.
;;;   a-constant allocator
;;;     this is code to evaluate A-CONSTANT forms, and find a location in a
;;;     memory that has that value (allocating one if necessary. - there are
;;;     only about 15 free slots in the current microcodes.)
;;;   micro function disassembler
;;;     this calls the lambda-diag instruction disassembler to print a micro-function.
;;;     if the instruction is installed in control memory, then it is printed
;;;     directly from there, otherwise it tries to find the code on the property
;;;     list.

;TODO:
;  get error if vma-start-read, etc not immediately followed by check-page-read in pagable code

;Major forms of instructions that I handle:
; (jump foo)
; (call foo)
; (jump-xct-next foo)
; (jump-less-than m-a a-b foo)
; (popj-less-than m-a a-b)
; (jump-if-bit-set (byte 1 5) m-a foo)

; ((m-a) dpb m-b (byte 1 0) a-c)
; ((m-a) ldb (byte 1 0) m-a)
; ((m-a) (byte 1 0) m-a)

; ((m-a) m-b)
; ((a-a) m-b)
; ((vma) m-b)
; ((m-a vma) m-b)
; ((m-a) vma)
; ((m-a) add m-b a-c)
; (pdl-pop)

; (dispatch (i-arg 1) d-xxx m-a (byte 1 0))

(defsubst %write-internal-processor-a-memory (addr high-8-bits low-24-bits)
  (si::%write-internal-processor-memories 4 addr high-8-bits low-24-bits))

(defsubst %write-internal-processor-i-memory (addr h-32-bits low-32-bits)
  (si::%write-internal-processor-memories 1 addr h-32-bits low-32-bits))

(defsubst %write-internal-processor-mid-memory (addr data)
  (si::%write-internal-processor-memories 5 addr 0 data))

(defsubst %read-internal-processor-mid-memory (addr)
  (si::%write-internal-processor-memories 6 addr 0 0))

(defvar *previous-uinst-linked-to-next* nil)

(defstruct (i-mem-block (:type :named-array)
			(:print "#<~s Start ~s Length ~s Function ~s ~s>"
				(type-of i-mem-block)
				(i-mem-block-start i-mem-block)
				(i-mem-block-length i-mem-block)
				(i-mem-block-function i-mem-block)
				(%pointer i-mem-block)))
  i-mem-block-start
  i-mem-block-length
  i-mem-block-next
  i-mem-block-prev
  i-mem-block-function
  )

(defmacro define-micro-component (name options &body body)
  `(define-micro-component-1 ',name ',options ',body))

(defun define-micro-component-1 (name options body)
  (let ((fixed-fields 0)
	(fixed-fields-values 0)
	(required-fields nil))
    (do ((rest body (cddr rest)))
	((null rest))
      (let ((field (car rest))
	    (val (cadr rest)))
	(if (null (get field 'lam::constant))
	    (ferror nil "unknown field: ~s" field))
	(cond ((or (integerp val)
		   (get val 'lam::constant))
	       (setq fixed-fields (dpb -1 (symeval field) fixed-fields))
	       (setq fixed-fields-values (dpb (eval val) (symeval field) fixed-fields-values)))
	      ((eq val :required)
	       (push field required-fields))
	      (t
	       (ferror nil "unknown option: ~s" val)))))
    (cond ((null (memq 'destination options))
	   (putprop name fixed-fields 'fixed-fields)
	   (putprop name fixed-fields-values 'fixed-fields-values)
	   (putprop name required-fields 'required-fields))
	  (t
	   (putprop name fixed-fields 'destination-fixed-fields)
	   (putprop name fixed-fields-values 'destination-fixed-fields-values)
	   (putprop name required-fields 'destination-required-fields)))
    nil))


(defsignal bad-inst error () "syntax error")


(defun expand (form &aux x)
  (cond ((null form) nil)
	((symbolp form)
	 (cond ((setq x (get (intern (string form) 'micro) 'micro-expand))
		(values (expand (funcall x form)) t))
	       (t
		form)))
	((atom form)
	 form)
	(t
	 (multiple-value-bind (a splice)
	     (expand (car form))
	   (cond ((null splice)
		  (cons a (expand (cdr form))))
		 ((consp a)
		  (append a (expand (cdr form))))
		 (t
		  (cons a (expand (cdr form)))))))))
	 
(defvar *local-jump-tags*)
(defvar *i-args*)
(defvar *local-m-mem-variables*)
(defvar *local-a-mem-variables*)
(defvar *local-dispatch-tables*)

(defun process-instruction (form)
  (let ((inst 0)
	(load-time-stuff nil)
	(fields-filled-in 0)
	(required-list nil)
	term)
    (setq form (expand form))
    (when (and (consp (car form))
	       (eq (caar form) 'arg-call))
      (setq form `(dispatch i-not-linked (byte-field 0 0) m-zero (dispatch-address ,(cadar form)) . ,(cdr form))))

    (dolist (atom form)
      (cond ((consp atom)
	     (setq term (intern (string (car atom)) (symbol-package 'foo)))
	     (case term
	       (dispatch-address
		(if (not (= (ldb lam-ir-op inst) lam-op-dispatch))
		    (ferror 'bad-inst "d-mem-adr seen in non-dispatch instruction"))
		(if (not (zerop (ldb lam-ir-dispatch-addr fields-filled-in)))
		    (ferror 'bad-inst "overlap - d-mem-adr"))
		(setq fields-filled-in (dpb -1 lam-ir-dispatch-addr fields-filled-in))
		(setq load-time-stuff (append load-time-stuff
					      (list 'lam-ir-dispatch-addr
						    `(a-constant (+ ,(cadr atom)
								    ,(+ (dpb 0 LAM-DISP-R-BIT 0)
									(dpb 1 LAM-DISP-P-BIT 0)
									(dpb 1 LAM-DISP-N-BIT 0))))))))
	       ((byte byte-field lisp-byte)
		(when (eq term 'lisp-byte)
		  (setq atom `(byte-field ,(ldb (byte 6 0) (symbol-value (cadr atom)))
					  ,(ldb (byte 6 6) (symbol-value (cadr atom)))))
		  (setq term 'byte-field))
		(if (and (not (zerop (ldb lam-ir-op fields-filled-in)))
			 (= (ldb lam-ir-op inst) lam-op-alu))
		    (ferror 'bad-inst "(byte ..) in alu instruction"))
		(when (zerop (ldb lam-ir-op fields-filled-in))
		  (setq fields-filled-in (dpb -1 lam-ir-op fields-filled-in))
		  (setq inst (dpb lam-op-byte lam-ir-op inst)))
		(when (and (= (ldb lam-ir-op inst) lam-op-byte)
			   (zerop (ldb lam-ir-byte-func fields-filled-in)))
		  ;;haven't said which kind yet - default to LDB
		  (setq fields-filled-in (dpb -1 lam-ir-byte-func fields-filled-in))
		  (setq inst (dpb lam-byte-func-ldb lam-ir-byte-func inst)))
		(push 'lam-ir-m-src required-list)
		(let ((width (cadr atom))
		      (pos (caddr atom)))
		  (cond ((not (= (ldb lam-ir-op inst) lam-op-jump))
			 (setq fields-filled-in (dpb -1 lam-ir-byte-length-spec fields-filled-in))
			 (setq inst (dpb (if (= (ldb lam-ir-op inst) lam-op-byte)
					     (1- width)
					   width)
					 lam-ir-byte-length-spec
					 inst))))
		  (cond ((or (= (ldb lam-ir-op inst) lam-op-jump)
			     (= (ldb lam-ir-op inst) lam-op-dispatch)
			     (= (ldb lam-ir-byte-func inst) lam-byte-func-ldb))
			 (setq pos (- 32. pos))))
		  (setq fields-filled-in (dpb -1 lam-ir-m-rotate fields-filled-in))
		  (setq inst (dpb pos lam-ir-m-rotate inst))))
	       (a-constant
		(if (not (zerop (ldb lam-ir-a-src fields-filled-in)))
		    (ferror 'bad-inst "overlapping fields - a-mem-adr"))
		(setq fields-filled-in (dpb -1 lam-ir-a-src fields-filled-in))
		(setq load-time-stuff (append load-time-stuff
					      (list 'lam-ir-a-src
						    `(a-constant ,(eval-a-constant (cadr atom)))))))
	       (i-arg
		(if (not (= (ldb lam-ir-op inst) lam-op-dispatch))
		    (ferror 'bad-inst "I-ARG seen but not in dispatch instruction"))
		(setq fields-filled-in (dpb -1 lam-ir-disp-dispatch-constant fields-filled-in))
		(setq inst (dpb (cadr atom) lam-ir-disp-dispatch-constant inst)))
	       (t
		;;must be dest
		(do ((tail atom (cdr tail))
		     dest)
		    ((null tail))
		  (setq dest (intern (string (car tail)) (symbol-package 'foo)))
		  (let ((info (symbol-info dest)))
		    (when (null info)
		      (cond ((memq (car tail) *local-m-mem-variables*)
			     (setq info '(m-mem-adr xxx)))
			    ((memq (car tail) *local-a-mem-variables*)
			     (setq info '(a-mem-adr xxx)))
			    ((assq (car tail) *local-dispatch-tables*)
			     (setq info '(d-mem-adr xxx)))
			    (t (setq info (get dest 'incremental-variable)))
			    ))
		    (cond ((null info)
			   (let ((fixed-fields (get dest 'destination-fixed-fields))
				 (required-fields (get dest 'destination-required-fields)))
			     (when (null fixed-fields)
			       (ferror 'bad-inst "undefined symbol ~s in what is apparently the destination"
				       dest))
			     (if (not (zerop (logand fields-filled-in fixed-fields)))
				 (ferror 'bad-inst "overlap - func dest"))
			     (setq fields-filled-in (+ fields-filled-in fixed-fields))
			     (setq inst (+ inst (get dest 'destination-fixed-fields-values)))
			     (when required-fields
			       (setq required-list (append required-list required-fields)))))
			  (t
			   (ecase (car info)
			     (m-mem-adr
			      (if (not (and (zerop (ldb lam-ir-a-mem-dest-flag fields-filled-in))
					    (zerop (ldb lam-ir-m-mem-dest fields-filled-in))))
				  (ferror 'bad-inst "overlap - m mem dest"))
			      (setq fields-filled-in (dpb -1 lam-ir-m-mem-dest fields-filled-in))
			      (setq load-time-stuff (append load-time-stuff
							    (list 'lam-ir-m-mem-dest dest))))
			     ((a-mem-adr d-mem-adr)
			      (if (not (and (zerop (ldb lam-ir-a-mem-dest fields-filled-in))
					    (zerop (ldb lam-ir-a-mem-dest-flag fields-filled-in))))
				  (ferror 'bad-inst "overlap - a dest"))
			      (setq fields-filled-in (dpb -1 lam-ir-a-mem-dest fields-filled-in))
			      (setq fields-filled-in (dpb -1 lam-ir-a-mem-dest-flag fields-filled-in))
			      (setq inst (dpb -1 lam-ir-a-mem-dest-flag inst))
			      (setq load-time-stuff (append load-time-stuff
							    (list 'lam-ir-a-mem-dest dest))))
			     (i-mem-adr
			      (ferror 'bad-inst "i-mem tag in dest field ~s" dest))))))))))
	    (t
	     (setq term (intern (string atom) (symbol-package 'foo)))
	     (cond ((get term 'fixed-fields)
		    (let ((fixed-fields (get term 'fixed-fields))
			  (required-fields (get term 'required-fields)))
		      (if (not (zerop (logand fields-filled-in fixed-fields)))
			  (ferror 'bad-inst "overlapping fields"))
		      (setq fields-filled-in (+ fields-filled-in fixed-fields))
		      (setq inst (+ inst (get term 'fixed-fields-values)))
		      (when required-fields
			(setq required-list (append required-list required-fields)))
		      ))
		   ;;this use of atom is OK
		   ((memq atom *local-jump-tags*)
		    (if (zerop (ldb lam-ir-op fields-filled-in))
			(ferror 'bad-inst "i-mem-adr seen before opcode known"))
		    (if (not (= (ldb lam-ir-op inst) lam-op-jump))
			(ferror 'bad-inst "i-mem-adr when not in jump inst"))
		    (if (not (zerop (ldb lam-ir-jump-addr fields-filled-in)))
			(ferror 'bad-inst "overlapping fields"))
		    (setq fields-filled-in (dpb -1 lam-ir-jump-addr fields-filled-in))
		    (setq load-time-stuff (append load-time-stuff
						  (list 'lam-ir-jump-addr atom))))
		   ((assq atom *i-args*)
		    (if (not (= (ldb lam-ir-op inst) lam-op-dispatch))
			(ferror 'bad-inst "i-arg on non dispatch"))
		    (setq fields-filled-in (dpb -1 lam-ir-disp-dispatch-constant fields-filled-in))
		    (setq load-time-stuff
			  (append load-time-stuff
				  (list 'lam-ir-disp-dispatch-constant
					`(eval (get-support-entry-vector-slot
						 ',(cadr (assq atom *i-args*))))))))
		   (t
		    (let ((info (symbol-info term)))
		      (when (null info)
			(cond ((memq atom *local-m-mem-variables*)
			       (setq info '(m-mem-adr xxx))
			       (setq term atom))
			      ((memq atom *local-a-mem-variables*)
			       (setq info '(a-mem-adr xxx))
			       (setq term atom))
			      ((assq atom *local-dispatch-tables*)
			       (setq info '(d-mem-adr xxx))
			       (setq term atom))
			      (t (setq info (get term 'incremental-variable)))
			      ))
		      (case (car info)
			(i-mem-adr
			 (if (zerop (ldb lam-ir-op fields-filled-in))
			     (ferror 'bad-inst "i-mem-adr seen before opcode known"))
			 (if (not (= (ldb lam-ir-op inst) lam-op-jump))
			     (ferror 'bad-inst "i-mem-adr when not in jump inst"))
			 (if (not (zerop (ldb lam-ir-jump-addr fields-filled-in)))
			     (ferror 'bad-inst "overlapping fields"))
			 (setq fields-filled-in (dpb -1 lam-ir-jump-addr fields-filled-in))
			 (setq load-time-stuff (append load-time-stuff
						       (list 'lam-ir-jump-addr term))))
			(a-mem-adr
			 (if (not (zerop (ldb lam-ir-a-src fields-filled-in)))
			     (ferror 'bad-inst "overlapping fields - a-mem-adr"))
			 (setq fields-filled-in (dpb -1 lam-ir-a-src fields-filled-in))
			 (setq load-time-stuff (append load-time-stuff
						       (list 'lam-ir-a-src term))))
			(m-mem-adr
			 (if (not (zerop (ldb lam-ir-m-src fields-filled-in)))
			     (ferror 'bad-inst "overlapping fields - m-mem-adr"))
			 (setq fields-filled-in (dpb -1 lam-ir-m-src fields-filled-in))
			 (setq load-time-stuff (append load-time-stuff
						       (list 'lam-ir-m-src term))))
			(d-mem-adr
			 (if (not (= (ldb lam-ir-op inst) lam-op-dispatch))
			     (ferror 'bad-inst "d-mem-adr seen in non-dispatch instruction"))
			 (if (not (zerop (ldb lam-ir-dispatch-addr fields-filled-in)))
			     (ferror 'bad-inst "overlap - d-mem-adr"))
			 (setq fields-filled-in (dpb -1 lam-ir-dispatch-addr fields-filled-in))
			 (setq load-time-stuff (append load-time-stuff
						       (list 'lam-ir-dispatch-addr term))))
			(t
			 (cond ((null info)
				(ferror 'bad-inst "~s is an undefined symbol" atom)))))))))))
    (let ((all-required-fields 0))
      (dolist (f required-list)
	(setq all-required-fields (dpb -1 (symeval f) all-required-fields)))
      (when (ldb-test lam-ir-clobbers-mem-subr-bit all-required-fields)
	(setq fields-filled-in (dpb 1 lam-ir-clobbers-mem-subr-bit fields-filled-in))
	(setq inst (dpb 1 lam-ir-clobbers-mem-subr-bit inst)))
      (if (not (= (logand fields-filled-in all-required-fields)
		  all-required-fields))
	  (ferror nil "required field not filled in")))
    (cond ((zerop (ldb lam-ir-op fields-filled-in))
	   ;;didn't fill in opcode - must be ALU
	   (if (zerop (ldb lam-ir-ob fields-filled-in))
	       (setq inst (dpb lam-ob-alu lam-ir-ob inst)))
	   (cond ((zerop (ldb lam-ir-aluf fields-filled-in))
		  (cond ((not (zerop (ldb lam-ir-m-src fields-filled-in)))
			 (setq inst (dpb lam-alu-setm lam-ir-aluf inst)))
			((not (zerop (ldb lam-ir-a-src fields-filled-in)))
			 (setq inst (dpb lam-alu-seta lam-ir-aluf inst)))
			(t
			 (ferror 'bad-inst "can't figure out what alu function to use")))))))
    ;;if a byte instruction that doesn't specify an a src, default to 2@a (A-ZERO)
    (cond ((and (= (ldb lam-ir-op inst) lam-op-byte)
		(zerop (ldb lam-ir-a-src fields-filled-in)))
	   (setq load-time-stuff (append load-time-stuff
					 (list 'lam-ir-a-src 'a-zero)))))
    (cons inst load-time-stuff)))

(defun eval-a-constant (form)
  (cond ((numberp form) form)
	((symbolp form)
	 (cond ((get form 'micro-symbol-value))
	       ((or (get form 'si::system-constant)
		    (memq form q-data-types))
		(symbol-value form))
	       (t
		(ferror nil "can't evaluate ~s" form))))
	((consp form)
	 (ecase (car form)
	   (eval (eval (cadr form)))
	   (byte-value
	    (dpb (eval-a-constant (caddr form))
		 (eval-a-constant (cadr form))
		 0))
	   (byte
	    (byte (eval-a-constant (cadr form))
		  (eval-a-constant (caddr form))))
	   (plus
	    (apply '+ (mapcar 'eval-a-constant (cdr form))))
	   ))))

(defun micro-assemble-list (list)
  (let ((adr 0)
	output
	(*local-m-mem-variables* nil)
	(*local-a-mem-variables* nil)
	(*local-dispatch-tables* nil)
	(*local-jump-tags* nil)
	new-list
	)
    (labels ((micro-assemble-list-1 (sub-list)
				    (dolist (inst sub-list)
				      (cond ((symbolp inst)
					     (push inst output))
					    ((and (symbolp (car inst))
						  (string-equal (string (car inst)) "ERROR-TABLE"))
					     (push inst output))
					    ((and (symbolp (car inst))
						  (get (intern (string (car inst))
							       'micro)
						       'micro-macro))
					     (micro-assemble-list-1 (funcall (get (intern (string (car inst))
											  'micro)
										  'micro-macro) inst)))
					    (t
					     (let ((bin-inst (process-instruction inst)))
					       (when (alignment-needed-for-micro-paging adr (car bin-inst))
						 (push (list 0) output)
						 (incf adr))
					       (push bin-inst output)
					       (incf adr))))))
	     )
      (do* ((inst-list list (cdr inst-list))
	    (inst (car inst-list) (car inst-list))
	    (mode 'i-mem)
	    )
	   ((null inst-list)
	    (setq inst-list (reverse new-list)))
	(when (and (consp inst)
		   (symbolp (car inst))
		   (string-equal (string (car inst)) "LOCALITY"))
	  (ecase (intern (string (cadr inst)) 'micro)
	    (i-mem (setq mode 'i-mem))
	    (m-mem (setq mode 'm-mem))
	    (a-mem (setq mode 'a-mem))
	    (d-mem (setq mode 'd-mem)))
	  (setq inst-list (cdr inst-list))
	  (setq inst (car inst-list))
	  )
	(ecase mode
	  (i-mem
	   (cond ((symbolp inst)
		  (push inst *local-jump-tags*)
		  (push inst new-list))
		 (t
		  (push inst new-list))))
	  (m-mem
	   (pop inst-list)
	   (when (not (equal (car inst-list) '(0)))
	     (ferror nil "can't initialize m memory: ~s" inst))
	   (push inst *local-m-mem-variables*)
	   (let ((a-name (string-append inst)))
	     (aset #/A a-name 0)
	     (push (intern a-name (symbol-package inst)) *local-a-mem-variables*))
	   )
	  (a-mem
	   (pop inst-list)
	   (when (not (equal (car inst-list) '(0)))
	     (ferror nil "can't initialize a memory: ~s" inst))
	   (push inst *local-a-mem-variables*))
	  (d-mem
	   (let* ((start-form (pop inst-list))
		  (table-name (pop inst-list))
		  table
		  )
	     (when (not (string-equal (string (car start-form)) "START-DISPATCH"))
	       (ferror nil "no START-DISPATCH"))
	     (when (not (symbolp table-name))
	       (ferror nil "no name for table"))
	     (when (not (zerop (caddr start-form)))
	       (ferror nil "can't default in these dispatch tables"))
	     (when (not (<= 0 (cadr start-form) 6))
	       (ferror nil "dispatch table width bad"))
	     (dotimes (i (ash 1 (cadr start-form)))
	       (push (pop inst-list) table))
	     (setq table (reverse table))
	     (push (cons table-name table) *local-dispatch-tables*)
	     (let ((end-dispatch (car inst-list)))
	       (when (or (not (consp end-dispatch))
			 (not (string-equal (string (car end-dispatch)) "END-DISPATCH")))
		 (ferror nil "no END-DISPATCH")))))))
	       
      (setq new-list (reverse new-list))
      (setq *previous-uinst-linked-to-next* nil)
      (micro-assemble-list-1 new-list)
      (values (reverse output)
	      (reverse *local-m-mem-variables*)
	      (reverse *local-a-mem-variables*)
	      (reverse *local-dispatch-tables*)
	      ))))

;(defun micro-assemble-list (list)
;  (do ((input list (cdr input))
;       (adr 0 (1+ adr))
;       output)
;      ((null input)
;       (reverse output))
;    (push (process-instruction (car input)) output)
;    (when (alignment-needed-for-micro-paging adr (caar output))
;      (let ((temp (pop output)))
;	(push (list 0) output)
;	(push temp output))
;      (incf adr))
;    ))

(defconst lam-ir-this-instruction-linked-to-next (byte 1 64.))
(defprop lam-ir-this-instruction-linked-to-next t lam::constant)
(defconst lam-ir-this-instruction-not-linked-to-next (byte 1 65.))
(defprop  lam-ir-this-instruction-not-linked-to-next t lam::constant)
;XCT-NEXT and OA-MOD sequences cannot straddle page boundaries in pagable UCODE.
;(If the second page weren't there, taking a micro-fault to get it would not work.)
;This predicate tries to avoid such lossage, however, it is only able to deal with
;sequences of two "interlocked" uinsts.  Unfortunately, three can be useful, such as where
;an OA-MOD is used on a uinst which is an XCT-NEXT.  This has to be outlawwed in
;pagable ucode for now, altho we could easily add a manual frob which would insert two 
;no-ops if necessary, etc.  VMA-START-READ, etc, lose because information needed by the
;following CALL-CONDITIONAL-IF-PAGE-FAULT, etc, could be lost in case of micro-fault.
(defun alignment-needed-for-micro-paging (adr inst)
  (let* ((op (ldb lam-ir-op inst))
	 (i-link-to-next
	   (and (zerop (ldb lam-ir-this-instruction-not-linked-to-next inst))
		(OR (= 1 (ldb lam-ir-this-instruction-linked-to-next inst))
		    (= 1 (ldb lam-ir-popj-after-next inst))
		    (= op lam-op-dispatch)	       ;for now, any dispatch might xct-next
		    (and (= op lam-op-jump)
			 (= 0 (ldb lam-ir-n inst)))
		    (and (or (= op lam-op-alu) (= op lam-op-byte))
			 (= 0 (ldb lam-ir-a-mem-dest-flag inst))
			 (or (= (ldb lam-ir-func-dest inst) lam-func-dest-dp-mode)
			     (= (ldb lam-ir-func-dest inst) lam-func-dest-imod-low)
			     (= (ldb lam-ir-func-dest inst) lam-func-dest-imod-high)
			     (= (ldb lam-ir-func-dest inst) lam-func-dest-vma-start-read)
			     (= (ldb lam-ir-func-dest inst) lam-func-dest-vma-start-write)
			     (= (ldb lam-ir-func-dest inst) lam-func-dest-md-start-write)
			     ))))))
    (cond ((and *previous-uinst-linked-to-next*
		(zerop (logand 17 adr)))
	   (ferror 'bad-inst "first inst on micro paged linked to previous")))
    (cond ((and *previous-uinst-linked-to-next*
		i-link-to-next)
	   (cond ((= 17 (logand 17 adr))
		  (ferror 'bad-inst "more than 2 linked uinst crossing a micro page"))
		 (t
		  (ferror 'bad-inst "more than 2 linked uinst luckily aligned this time")))))

    (cond (i-link-to-next
	   (cond ((= #o17 (logand #o17 adr))
		  (setq *previous-uinst-linked-to-next* nil)
		  t)
		 (t
		  (setq *previous-uinst-linked-to-next* t)
		  nil)))
	  (t
	   (setq *previous-uinst-linked-to-next* nil)
	   nil))))

(defmacro define-a-memory-variable (name initial-value)
  `(PROGN (LET ((ADDRESS
		  (FIND-OR-MAKE-A-VARIABLE (QUOTE ,name) ,initial-value NIL 'RANDOM-A-MEMORY-VARIABLE)))
	    (PUTPROP (QUOTE ,name) '(A-MEM-ADR XXX) 'INCREMENTAL-VARIABLE)
	    (PUTPROP (QUOTE ,name) ADDRESS 'A-MEM-ADR))))

(defmacro define-micro-function (name &rest form)
  (declare (arglist name arglist &body body))
  `(define-micro-function-1 ',name ',form))

(defun define-micro-function-1 (name form)
  (when (not (symbolp name))
    (ferror nil "micro function name must be a symbol"))
  (let ((lambda-exp (si::process-defun-body name form t))
	documentation
	arglist
	declarations
	body
	macro-compiled-alternative
	*i-args*
	)
    ;;now we have (named-lambda (foo (documentation "foobar")) (args) (declare (...) (...)) body)
    ;;the declare may be absent
    (setq documentation (cadr (assq 'si::documentation (si::debugging-info lambda-exp))))
    (setq arglist (third lambda-exp))
    (setq body (cdddr lambda-exp))
    (when (eq (caar body) 'declare)
      (setq declarations (cdr (car body)))
      (pop body))

    (dolist (atom arglist)
      (if (char-equal (aref (string atom) 0) #/&)
	  (ferror nil "no lambda list keywords allowed")))

    (setq macro-compiled-alternative
	  (or (cadr (assq ':macro-compiled-alternative
			  declarations))
	      'micro-function-no-macro-definition))

    (setq *i-args* (mapcar #'(lambda (pair) (list (car pair) (eval (cadr pair))))
			   (cdr (assq :support-vector declarations))))

    (when (and (eq (get name 'compiler::p1) 'compiler::placeholder-p1)
	       (get name 'compiler::new-micro-n-args)
	       (not (= (length arglist)
		       (get name 'compiler::new-micro-n-args))))
      (ferror nil "can't change number of arguments after compiling with :CALL-AS-MISC-INSTRUCTION declaration"))

    (when (null (record-source-file-name name 'defun))
      (return-from define-micro-function-1 nil))

    (uninstall name)
    (putprop name macro-compiled-alternative 'macro-compiled-alternative)
    (multiple-value-bind (inst m-mem a-mem disp)
	(micro-assemble-list body)
      (putprop name inst 'new-micro-out)
      (putprop name m-mem 'local-m-mem)
      (putprop name a-mem 'local-a-mem)
      (putprop name disp 'local-disp))
    (putprop name (length arglist) 'compiler::new-micro-n-args)
    (putprop name arglist 'new-micro-arglist)

    (install name)

    (when (cadr (assq :call-as-misc-instruction declarations))
      (make-misc-callable-function name))

    name))

(defmacro define-micro-patch (name &rest form)
  (declare (arglist name offset &body body))
  `(define-micro-patch-1 ',name ',form))

(defun define-micro-patch-1 (name form &aux i-mem-adr)
  (when (not (symbolp name))
    (ferror nil "name must be symbol"))

  (let ((lambda-exp (si::process-defun-body name form t))
	documentation
	options
	declarations
	body
	*i-args*
	)
    ;;now we have (named-lambda (foo (documentation "foobar")) (args) (declare (...) (...)) body)
    ;;the declare may be absent
    (setq documentation (cadr (assq 'si::documentation (si::debugging-info lambda-exp))))
    (setq options (third lambda-exp))
    (setq body (cdddr lambda-exp))
    (when (eq (caar body) 'declare)
      (setq declarations (cdr (car body)))
      (pop body))

    (when (null (record-source-file-name name 'defun))
      (return-from define-micro-patch-1 nil))

    (setq i-mem-adr (i-mem-lookup name))
    (when (null i-mem-adr)
      (ferror nil "micro patch must refer to a i-mem label"))
    (when options
      (incf i-mem-adr (car options)))

    (setq *i-args* (cdr (assq :support-vector declarations)))

    (uninstall name)

    (push '(no-op) body)
    (putprop name (micro-assemble-list body) 'new-micro-out)
    (putprop name i-mem-adr 'micro-patch-adr)
    (install-patch name)

    name))

(defvar *installed-patches* nil)

(defun install-patch (name)
  (uninstall name)

  (let ((block (allocate-i-mem-block (count-instructions (get name 'new-micro-out)) 4))
	(aborted t))
    (unwind-protect
	(progn
	  (putprop name block 'i-mem-block)
	  (setf (i-mem-block-function block) name)
	  (link name (i-mem-block-start block))
	  (if (not (= (count-instructions (get name 'new-micro-out))
		      (length (get name 'new-micro-linked))))
	      (ferror nil "linking shouldn't change size"))
	  (when (not (= (car (get name 'new-micro-linked))
			(dpb lam-ob-alu lam-ir-ob 0)))
	    (ferror nil "patch doesn't start with no-op"))
	  (do ((code (get name 'new-micro-linked) (cdr code))
	       (adr (i-mem-block-start block) (1+ adr)))
	      ((null code))
	    (write-c-mem adr (car code)))
	  
	  (write-c-mem (i-mem-block-start block) (read-c-mem (get name 'micro-patch-adr)))

	  (setq aborted 'can-unpatch)
	  (write-c-mem (get name 'micro-patch-adr)
		       (lam::lam-execute (return)
			 lam-ir-op lam-op-jump
			 lam-ir-jump-cond lam-jump-cond-unc
			 lam-ir-p 1
			 lam-ir-n 1
			 lam-ir-jump-addr (i-mem-block-start block)))

	  (push name *installed-patches*)
	  (setq aborted nil)
	  )
      (when aborted
	(when (eq aborted 'can-unpatch)
	  (write-c-mem (get name 'micro-patch-adr)
		       (read-c-mem (i-mem-block-start block))))
	(free-i-mem-block block)
	(putprop name nil 'i-mem-block)
	(flush-error-table-entries name)
	(free-a-memory-for-function name)
	(setq *installed-patches* (delq name *installed-patches*))
	)))
  name)

(defun temp-patch (name)
  (write-c-mem (get name 'micro-patch-adr)
	       (lam::lam-execute (return)
				lam-ir-op lam-op-jump
				lam-ir-jump-cond lam-jump-cond-unc
				lam-ir-p 1
				lam-ir-n 1
				lam-ir-jump-addr (i-mem-block-start (get name 'i-mem-block)))))

(defun temp-unpatch (name)
  (write-c-mem (get name 'micro-patch-adr)
	       (read-c-mem (i-mem-block-start (get name 'i-mem-block)))))

;;; The Areas:
;;;
;;; MICRO-CODE-ENTRY-AREA
;;;  Indexed by the "U-ENTRY" number, that is, the pointer field of a DTP-U-ENTRY
;;; word.  U-ENTRY numbers for the initial functions are assigned by the cold load builder.
;;; As the cold load builder reads the DEFMIC file, it pushes each defmic onto a list.
;;; Later in the building process, it assigns values to each function, starting with
;;; 0 for *CATCH, and then 1 with the last DEFMIC.  Therefore, adding new DEFMICs to
;;; the end changes all of the DTP-U-ENTRYs.  The point is that the U-ENTRY is 
;;; a per band number and cannot be communicated between bands.
;;; Anyway, this table is referenced when you call a DTP-U-ENTRY.  The pointer field
;;; of the DTP-U-ENTRY is used to index this table.  If the value is a FIXNUM, then it
;;; is an index into the MICRO-CODE-SYMBOL-AREA table.  Otherwise, the DTP-U-ENTRY
;;; acts like an invisible pointer.  For example, the table can contain a symbol
;;; and the call will proceed to look at the symbol pointer, then finially at the
;;; symbol's function cell.

;;; MICRO-CODE-SYMBOL-AREA
;;;  indexed by (- misc-inst-number #o200)

;;; MICRO-CODE-ENTRY-NAME-AREA
;;; MICRO-CODE-ENTRY-ARGS-INFO-AREA
;;; MICRO-CODE-ENTRY-MAX-PDL-USAGE - apparently not used
;;; MICRO-CODE-ENTRY-ARGLIST-AREA
;;; MICRO-CODE-SYMBOL-NAME-AREA
;;;  indexed by (- misc-inst-number #o200)
  

(defvar *installed-functions* nil)

(defvar *local-symbols*)

(defun convert-m-name-to-a-name (m-name)
  (let ((a-name (string-append m-name)))
    (aset #/A a-name 0)
    (intern a-name (symbol-package m-name))))

(defun convert-a-name-to-m-name (a-name)
  (let ((m-name (string-append a-name)))
    (aset #/M m-name 0)
    (intern m-name (symbol-package a-name))))

(defun install (name)
  (uninstall name)

  (let ((block (allocate-i-mem-block (count-instructions (get name 'new-micro-out)) 4))
	(arglist (get name 'new-micro-arglist))
	(aborted t)
	(symbol-area-slot (get name 'micro-symbol-area-slot))
	(entry-area-slot (get name 'micro-entry-area-slot))
	(*local-symbols* nil)
	)
    (unwind-protect
	(progn
	  (putprop name block 'i-mem-block)
	  (setf (i-mem-block-function block) name)

	  (dolist (m-var (get name 'local-m-mem))
	    (let ((m-var-loc (find-or-make-m-variable m-var 0 nil name)))
	      (putprop m-var m-var-loc 'a-mem-adr)
	      (putprop (convert-m-name-to-a-name m-var) m-var-loc 'a-mem-adr)
	      (push (cons m-var m-var-loc) *local-symbols*)
	      (push (cons (convert-m-name-to-a-name m-var) m-var-loc) *local-symbols*)))

	  (let ((just-a-mem (loop for var in (get name 'local-a-mem)
				  when (not (memq (intern (let ((m-name (string-append (string var))))
							    (aset #/M m-name 0)
							    m-name)
							  (symbol-package 'var))
						  (get name 'local-m-mem)))
				  collect var)))
	    (when just-a-mem
	      (let ((a-mem-block (allocate-a-mem-block (length just-a-mem) 0 name)))
		(do ((vars just-a-mem (cdr vars))
		     (offset 0 (1+ offset)))
		    ((null vars))
		  (putprop (car vars) (+ a-mem-block offset) 'a-mem-adr)
		  (push (cons (car vars) (+ a-mem-block offset)) *local-symbols*)
		  (setf (cadr (aref *a-memory-usage-table* (+ a-mem-block offset))) (car vars))
		  ))))

	  (when (get name 'local-disp)
	    (dolist (disp (get name 'local-disp))
	      (push (cons (car disp)
			  (allocate-a-mem-block (length (cdr disp)) (1- (haulong (length (cdr disp)))) name))
		    *local-symbols*)))

	  (putprop name *local-symbols* 'local-symbols)

	  (link name (i-mem-block-start block))
	  (if (not (= (count-instructions (get name 'new-micro-out))
		      (length (get name 'new-micro-linked))))
	      (ferror nil "linking shouldn't change size"))

	      

	    
	  (do ((code (get name 'new-micro-linked) (cdr code))
	       (adr (i-mem-block-start block) (1+ adr)))
	      ((null code))
	    (write-c-mem adr (car code)))
	  (aset (i-mem-block-start block) #'si::micro-code-symbol-area symbol-area-slot)
	  (aset (dpb (length arglist)
		     %%arg-desc-min-args
		     (dpb (length arglist)
			  %%arg-desc-max-args
			  0))
		#'si::micro-code-entry-args-info-area
		entry-area-slot)
	  (aset arglist #'si::micro-code-entry-arglist-area entry-area-slot)
	  
	  (aset symbol-area-slot #'si::micro-code-entry-area entry-area-slot)

	  (setq eh::extra-error-table (append (get name 'new-micro-error-table-entries)
					     eh::extra-error-table))

	  (%write-internal-processor-mid-memory
	    (+ (* 3 1024.) #o200 symbol-area-slot) (i-mem-block-start block))

	  (push name *installed-functions*)
	  (setq aborted nil)
	  )
      (when aborted
	(aset (get name 'macro-compiled-alternative) #'si::micro-code-entry-area entry-area-slot)
	(free-i-mem-block block)
	(putprop name nil 'i-mem-block)
	(%write-internal-processor-mid-memory
	  (+ (* 3 1024.) #o200 symbol-area-slot) (symbol-table-get 'lam::micro-code-symbol-table-fill-value))
	(flush-error-table-entries name)
	(free-a-memory-for-function name)
	(setq *installed-functions* (delq name *installed-functions*))
	)))
  name)
    
(defun flush-error-table-entries (name)
  (dolist (ete (get name 'new-micro-error-table-entries))
    (let ((old-ete (assq (car ete) eh::extra-error-table)))
      (when old-ete
	(setq eh::extra-error-table (delq old-ete eh::extra-error-table))))))

(defun check-micro-consistancy (name)
  (if (not (= (%data-type (symbol-function name)) dtp-u-entry))
      (ferror nil "the function cell of ~s is not DTP-U-ENTRY"))
  (let ((entry-area-slot (get name 'micro-entry-area-slot))
	(symbol-area-slot (get name 'micro-symbol-area-slot))
	(block (get name 'i-mem-block))
	)
    (if (or (not (fixnump entry-area-slot))
	    (not (fixnump symbol-area-slot)))
	(ferror nil "bad plist on ~s" name))
    (when (not (= entry-area-slot (%pointer (symbol-function name))))
      (ferror nil "entry-area-slot bad on ~s" name))
    (when (and (fixnump (aref #'si::micro-code-entry-area entry-area-slot))
	       (not (= symbol-area-slot (aref #'si::micro-code-entry-area entry-area-slot))))
      (ferror nil "symbol-area-slot bad on ~s" name))
    (cond (block
	   (if (not (typep block 'i-mem-block))
	       (ferror nil "bad ~s property on ~s" 'I-MEM-BLOCK name))
	    (if (not (= (i-mem-block-start block)
			(aref #'si::micro-code-symbol-area symbol-area-slot)))
		(ferror nil "active address not beginning of i-mem-block for ~s" name))
	    (if (not (= (i-mem-block-start block)
			(%read-internal-processor-mid-memory (+ (* 3 1024.) #o200 symbol-area-slot))))
		(ferror nil "MID ram doesn't have starting address")))
	  ((not (= (aref #'si::micro-code-symbol-area symbol-area-slot)
		   (symbol-table-get 'lam::micro-code-symbol-table-fill-value)))
	   (ferror nil "~s is not loaded in control memory, but its symbol-area entry is not ILLEGAL-INSTRUCTION" name)))
    t))
	    

(defun uninstall (name)
  (cond ((memq name *installed-patches*)
	 (let ((block (get name 'i-mem-block)))
	   (when (null block)
	     (ferror nil "no block"))
	   (write-c-mem (get name 'micro-patch-adr)
			(read-c-mem (i-mem-block-start block)))
	   (setq *installed-patches* (delq name *installed-patches*))
	   (free-i-mem-block (get name 'i-mem-block))
	   (putprop name nil 'i-mem-block))
	 (flush-error-table-entries name)
	 (free-a-memory-for-function name)
	 )
	(t
	 (when (or (not (fboundp name))
		   (not (= (%data-type (symbol-function name)) dtp-u-entry)))
	   (make-function-into-u-entry name (if (fboundp name)
						(symbol-function name)
					      'not-micro-defined)))
	 (check-micro-consistancy name)
	 (let ((symbol-area-slot (get name 'micro-symbol-area-slot))
	       (entry-area-slot (get name 'micro-entry-area-slot)))
	   (aset (get name 'macro-compiled-alternative) #'si::micro-code-entry-area entry-area-slot)
	   (setq *installed-functions* (delq name *installed-functions*))
	   (aset (symbol-table-get 'lam::micro-code-symbol-table-fill-value)
		 #'si::micro-code-symbol-area
		 symbol-area-slot)
	   (%write-internal-processor-mid-memory
	     (+ (* 3 1024.) #o200 symbol-area-slot) (symbol-table-get 'lam::micro-code-symbol-table-fill-value))
	   (aset 0 #'si::micro-code-entry-args-info-area entry-area-slot)
	   (aset '() #'si::micro-code-entry-arglist-area entry-area-slot)
	   (when (get name 'i-mem-block)
	     (free-i-mem-block (get name 'i-mem-block))
	     (putprop name nil 'i-mem-block))
	   )
	 (flush-error-table-entries name)
	 (free-a-memory-for-function name)
	 )))

(defun make-function-into-u-entry (name macro-function)
  (let (entry-area-slot symbol-area-slot)
    (cond ((get name 'micro-symbol-area-slot)
	   (setq entry-area-slot (get name 'micro-entry-area-slot))
	   (setq symbol-area-slot (get name 'micro-symbol-area-slot))
	   (when (and (fboundp name)
		      (= (%data-type (symbol-function name)) dtp-u-entry)
		      (not (= (%pointer (symbol-function name)) entry-area-slot)))
	     (ferror nil "out of phase")))
	  (t
	   (setq symbol-area-slot (get-slot-in-micro-code-symbol-area))
	   (setq entry-area-slot (get-slot-in-micro-code-entry-area))
	   (putprop name entry-area-slot 'micro-entry-area-slot)
	   (putprop name symbol-area-slot 'micro-symbol-area-slot)))
    
    (aset macro-function #'si::micro-code-entry-area entry-area-slot)
    (aset (symbol-table-get 'lam::micro-code-symbol-table-fill-value)
	  #'si::micro-code-symbol-area
	  symbol-area-slot)
    (let ((si::%inhibit-read-only t))
      (aset name #'si::micro-code-symbol-name-area symbol-area-slot))
    (aset 0 #'si::micro-code-entry-args-info-area entry-area-slot)
    (aset '() #'si::micro-code-entry-arglist-area entry-area-slot)
    (aset name #'si::micro-code-entry-name-area entry-area-slot)
    (setf (symbol-function name) (%make-pointer dtp-u-entry entry-area-slot))))
  
(defun count-instructions (code)
  (do ((tail code (cdr tail))
       (length 0))
      ((null tail)
       length)
    (when (and (consp (car tail))
	       (integerp (caar tail)))
      (incf length))))


(defun link (function beg-adr &aux x)
  beg-adr
  (let ((code (get function 'new-micro-out))
	(*local-jump-tags* nil)
	error-table-entries)
    (if (null code) (ferror nil "no code"))
    (do ((adr beg-adr)
	 (tail code (cdr tail)))
	((null tail))
      (cond ((symbolp (car tail))
	     (push (list (car tail) adr) *local-jump-tags*))
	    ((eq (caar tail) 'error-table)
	     (push (cons (1- adr) (mapcar #'(lambda (sym) (intern (string sym) "EH")) (cdr (car tail))))
		   error-table-entries))
	    (t
	     (incf adr))))
    (putprop function
	     (loop for word in code
		   when (and (consp word)
			     (not (eq (car word) 'error-table)))
		   collect (resolve word function))
	     'new-micro-linked)
    (putprop function
	     error-table-entries
	     'new-micro-error-table-entries)
    (dolist (disp (get function 'local-disp))
      (do* ((entry-list (cdr disp) (cdr entry-list))
	    (entry (car entry-list) (car entry-list))
	    (adr (cdr (assq (car disp) *local-symbols*)) (1+ adr)))
	   ((null entry-list))
	(let ((val 0))
	  (dolist (atom entry)
	    (case atom
	      (n-bit (setq val (dpb 1 lam-disp-n-bit val)))
	      (p-bit (setq val (dpb 1 lam-disp-p-bit val)))
	      (r-bit (setq val (dpb 1 lam-disp-r-bit val)))
	      (t
	       (cond ((setq x (cadr (assq atom *local-jump-tags*)))
		      (setq val (dpb x (byte 16. 0) val)))
		     ((setq x (symbol-info atom))
		      (setq val (dpb x (byte 16. 0) val)))
		     (t
		      (ferror nil "can't find ~s" atom))))))
	  (write-a-mem adr val))))
	
    )
  nil)

(defun resolve (word function)
  (labels ((resolve-eval (exp)
	    (cond ((atom exp)
		   (cond ((numberp exp) exp)
			 (t
			  (let ((adr (or (cadr (assq exp *local-jump-tags*))
					 (cdr (assq exp *local-symbols*))
					 (cadr (symbol-info exp))
					 (get exp 'a-mem-adr))))
			    (cond ((null adr)
				   (ferror nil "can't resolve ~s" exp))
				  (t
				   adr))))))
		  (t
		   (ecase (car exp)
		     (+
		      (apply '+ (mapcar #'resolve-eval (cdr exp))))
		     (eval
		      (eval (cadr exp)))
		     (a-constant
		      (find-or-make-a-constant (resolve-eval (cadr exp)) function))
		     )))))
    (let ((inst (car word))
	  (fields (cdr word)))
      (do ((next fields (cddr next)))
	  ((null next))
	(let ((field (car next))
	      (val (cadr next)))
	  (setq inst (dpb (resolve-eval val)
			  (symbol-value field)
			  inst))))
      inst)))


(defvar *reinstall-list* nil)

(defun uninstall-micro-functions-for-disk-save ()
  (setq *reinstall-list* (copylist *installed-functions*))
  (mapcar 'uninstall *reinstall-list*))

(add-initialization "uninstall micro-functions before disk-save"
		    '(uninstall-micro-functions-for-disk-save)
		    '(before-cold))

(defun reinstall-micro-functions-after-boot ()
  (mapcar 'install *reinstall-list*)
  (setq *reinstall-list* nil))

(add-initialization "reinstall micro-functions after boot"
		    '(reinstall-micro-functions-after-boot)
		    '(system))

(defun micro-print (function &optional from-property-list)
  (lam::assure-lam-symbols-loaded)
  (let ((code (get function 'new-micro-linked)))
    (cond ((null code)
	   (format t "~&No code."))
	  ((and (null from-property-list)
		(fboundp function)
		(= (%data-type (symbol-function function)) dtp-u-entry)
		(fixnump (aref #'si::micro-code-entry-area (%pointer (symbol-function function)))))
	   (format t "~&From control memory:")
	   (do* ((adr (aref #'si::micro-code-symbol-area
			    (aref #'si::micro-code-entry-area (%pointer (symbol-function function)))) (1+ adr))
		 (end (+ adr (length (get function 'new-micro-linked)))))
		((>= adr end))
	     (let ((*package* (find-package "LAMBDA")))
	       (format t "~&~5o: " adr)
	       (lam::lam-type-out (read-c-mem adr) lam::lam-uinst-desc t :get-from-running-a-mem))))
	  ((and (null from-property-list)
		(get function 'i-mem-block))
	   (format t "~&From I-MEM-BLOCK")
	   (do* ((adr (i-mem-block-start (get function 'i-mem-block)) (1+ adr))
		 (end (+ adr (length (get function 'new-micro-linked)))))
		((>= adr end))
	     (let ((*package* (find-package "LAMBDA")))
	       (format t "~&~5o: " adr)
	       (lam::lam-type-out (read-c-mem adr) lam::lam-uinst-desc t :get-from-running-a-mem))))
	  (t
	   (format t "~&From property list:")
	   (let ((*package* (find-package "LAMBDA")))
	     (do ((inst-list code (cdr inst-list))
		  (adr 0 (1+ adr)))
		 ((null inst-list))
	       (format t "~&~5o: " adr)
	       (lam::lam-type-out (car inst-list) lam::lam-uinst-desc t t)))))))

(defun micro-code-area-store-and-extend (val name index)
  (setf (aref #'si::region-free-pointer (symbol-value name)) (1+ index))
  (%p-dpb cdr-next %%q-cdr-code (locf (aref (symbol-function name) (1- index))))
  (%p-dpb cdr-nil %%q-cdr-code (locf (aref (symbol-function name) index)))
  (setf (aref (symbol-function name) index) val)
  (incf (fill-pointer (symbol-function name))))

(defun get-slot-in-micro-code-entry-area (&aux entry-index)
  (when (not (= si::%number-of-micro-entries
		(fill-pointer #'si::micro-code-entry-area)))
    (ferror nil "out of phase"))
  (cond ((< si::%number-of-micro-entries
	    (array-length #'si::micro-code-entry-area))
	 (setq entry-index si::%number-of-micro-entries)

	 (micro-code-area-store-and-extend nil 'si::micro-code-entry-area entry-index)
	 (micro-code-area-store-and-extend nil 'si::micro-code-entry-name-area entry-index)
	 (micro-code-area-store-and-extend 0 'si::micro-code-entry-args-info-area entry-index)
	 (micro-code-area-store-and-extend nil 'si::micro-code-entry-arglist-area entry-index)
	 
	 (incf si::%number-of-micro-entries)
	 entry-index)
	(t
	 (ferror nil "out of entry area slots"))))

(defvar *next-micro-code-symbol-area-index* nil)

(defun get-slot-in-micro-code-symbol-area (&aux slot)
  (when (null *next-micro-code-symbol-area-index*)
    (setq *next-micro-code-symbol-area-index* (- 1023. #o200)))
  (setq slot *next-micro-code-symbol-area-index*)
  (decf *next-micro-code-symbol-area-index*)
  (when (<= *next-micro-code-symbol-area-index*
	    (- (symbol-table-get 'lam::highest-misc-entry) #o200))
    (ferror nil "out of micro-code-symbol-area slots"))
  
  (aset (symbol-table-get 'lam::micro-code-symbol-table-fill-value)
	#'si::micro-code-symbol-area
	slot)
  (let ((si::%inhibit-read-only t))
    (aset nil #'si::micro-code-symbol-name-area slot))
  slot)

(defun clear-all-stat-bits ()
  (do ((offset 0 (1+ offset))
       (adr (si::%region-origin si::micro-code-paging-area) (+ adr 2))
       (adr+1 (1+ (si::%region-origin si::micro-code-paging-area)) (+ adr+1 2))
       (end (* 16. (read-meter 'si::%highest-handcode-ucode-page))))
      ((>= offset end))
    (%p-dpb 0 (byte 1 25.) adr+1)
    (let ((hi (dpb (%p-ldb (byte 16. 16.) adr+1)
		   (byte 16. 16.)
		   (%p-ldb (byte 16. 0) adr+1)))
	  (lo (dpb (%p-ldb (byte 16. 16.) adr)
		   (byte 16. 16.)
		   (%p-ldb (byte 16. 0) adr))))
      (%write-internal-processor-i-memory offset hi lo)))

  (do ((offset (* 16. (read-meter 'si::%highest-handcode-ucode-page)) (1+ offset))
       (adr+1 (+ (* 2 (* 16. (read-meter 'si::%highest-handcode-ucode-page)))
		 1
		 (si::%region-origin si::micro-code-paging-area))
	      (+ adr+1 2)))
      ((>= offset 65536.))
    (%p-dpb 0 (byte 1 25.) adr+1))
  (select-processor
    (:lambda
      (si::%micro-paging 1))
    ((:explorer :cadr)))
  )


(defun read-c-mem (adr)
  (setq adr (i-mem-lookup adr))
  (let ((origin (si::%region-origin si::micro-code-paging-area))
	(offset (* adr 2)))
    (dpb (%p-ldb (byte 16. 16.) (+ origin offset 1))
	 (byte 16. 48.)
	 (dpb (%p-ldb (byte 16. 0) (+ origin offset 1))
	      (byte 16. 32.)
	      (dpb (%p-ldb (byte 16. 16.) (+ origin offset))
		   (byte 16. 16.)
		   (%p-ldb (byte 16. 0) (+ origin offset)))))))

(defun write-c-mem (adr inst)
  (setq adr (i-mem-lookup adr))
  (let ((origin (+ (* adr 2) (si::%region-origin si::micro-code-paging-area))))
    (without-interrupts
      (%p-dpb (ldb (byte 16. 0) inst) (byte 16. 0) origin)
      (%p-dpb (ldb (byte 16. 16.) inst) (byte 16. 16.) origin)
      (%p-dpb (ldb (byte 16. 32.) inst) (byte 16. 0) (+ origin 1))
      (%p-dpb (ldb (byte 16. 48.) inst) (byte 16. 16.) (+ origin 1)))
    (cond ((select-processor
	     (:lambda
	       (< adr (* 16. (read-meter 'si::%highest-handcode-ucode-page))))
	     ((:explorer :cadr)
	      t))
	   (%write-internal-processor-i-memory
	     adr
	     (ash inst -32.)
	     inst))
	  (t
	   (si::%micro-paging 1)))
    inst))

(defun write-micro-code-paging-area (adr inst)
  (setq adr (i-mem-lookup adr))
  (let ((origin (+ (* adr 2) (si::%region-origin si::micro-code-paging-area))))
    (without-interrupts
      (%p-dpb (ldb (byte 16. 0) inst) (byte 16. 0) origin)
      (%p-dpb (ldb (byte 16. 16.) inst) (byte 16. 16.) origin)
      (%p-dpb (ldb (byte 16. 32.) inst) (byte 16. 0) (+ origin 1))
      (%p-dpb (ldb (byte 16. 48.) inst) (byte 16. 16.) (+ origin 1))))
  inst)



  

(defvar *i-mem-blocks* nil)

(defun print-i-mem-blocks ()
  (when (not (= (i-mem-block-start *i-mem-blocks*)
		(symbol-table-get 'lam::pagable-i-mem-loc)))
    (format t "~&Warning: doesn't start at PAGABLE-I-MEM-LOC"))
  (do ((block *i-mem-blocks* (i-mem-block-next block)))
      ((null block))
    (print block)
    (when (and (i-mem-block-next block)
	       (not (= (+ (i-mem-block-start block)
			  (i-mem-block-length block))
		       (i-mem-block-start (i-mem-block-next block)))))
      (format t "   warning, a hole of ~d. words"
	      (- (i-mem-block-start (i-mem-block-next block))
		 (+ (i-mem-block-start block)
		    (i-mem-block-length block)))))))

(defun set-up-i-mem-blocks ()
  (let ((lowest-loc (symbol-table-get 'lam::pagable-i-mem-loc)))
    (setq *i-mem-blocks* (make-i-mem-block i-mem-block-start lowest-loc
					      i-mem-block-length (- (^ 2 (select-processor
									   (:lambda 16.)
									   ((:explorer :cadr) 14.)))
								    lowest-loc)
					      i-mem-block-next nil
					      i-mem-block-prev nil
					      i-mem-block-function nil
					      ))))

(defun allocate-i-mem-block (n-words &optional (alignment 0))
  ;;do a best fit thing
  (let (closest)
    (do ((block *i-mem-blocks* (i-mem-block-next block)))
	((null block))
      (when (and (null (i-mem-block-function block))
		 (<= n-words (- (i-mem-block-length block)
				(wasted-words-in-block block alignment)))
		 (or (null closest)
		     (< (i-mem-block-length block)
			(i-mem-block-length closest))))
	(setq closest block)))
    (when closest
      (let ((wasted-words (wasted-words-in-block closest alignment)))
	(when (not (zerop wasted-words))
	  (let ((wasted-block (make-i-mem-block i-mem-block-start (i-mem-block-start closest)
						i-mem-block-length wasted-words
						i-mem-block-next closest
						i-mem-block-prev (i-mem-block-prev closest)
						i-mem-block-function nil)))
	    (setf (i-mem-block-prev closest) wasted-block)
	    (cond ((null (i-mem-block-prev wasted-block))
		   (setq *i-mem-blocks* wasted-block))
		  (t
		   (setf (i-mem-block-next (i-mem-block-prev wasted-block)) wasted-block)))
	    (incf (i-mem-block-start closest) wasted-words)
	    (decf (i-mem-block-length closest) wasted-words))))

      (cond ((= (i-mem-block-length closest) n-words)
	     (setf (i-mem-block-function closest) t))
	    (t
	     (let ((new-block (make-i-mem-block i-mem-block-start (+ (i-mem-block-start closest) n-words)
						i-mem-block-length (- (i-mem-block-length closest) n-words)
						i-mem-block-next (i-mem-block-next closest)
						i-mem-block-prev closest
						i-mem-block-function nil)))
	       (when (i-mem-block-next closest)
		 (setf (i-mem-block-prev (i-mem-block-next closest)) new-block))
	       (setf (i-mem-block-length closest) n-words)
	       (setf (i-mem-block-next closest) new-block)
	       (setf (i-mem-block-function closest) t))))
      closest)))

(defun wasted-words-in-block (block alignment)
  (let* ((modulus (ash 1 alignment))
	 (mask (1- modulus)))
    (logand mask (- modulus (logand (i-mem-block-start block) mask)))))

(defun free-i-mem-block (block)
  (when (null (i-mem-block-function block))
    (ferror nil "block already free"))
  (setf (i-mem-block-function block) nil)
  (when (and (i-mem-block-prev block)
	     (null (i-mem-block-function (i-mem-block-prev block)))
	     (= (+ (i-mem-block-start (i-mem-block-prev block))
		   (i-mem-block-length (i-mem-block-prev block)))
		(i-mem-block-start block)))
    (incf (i-mem-block-length (i-mem-block-prev block))
	  (i-mem-block-length block))
    (setf (i-mem-block-next (i-mem-block-prev block)) (i-mem-block-next block))
    (setf (i-mem-block-prev (i-mem-block-next block)) (i-mem-block-prev block))
    (setq block (i-mem-block-prev block)))
  (when (and (i-mem-block-next block)
	     (null (i-mem-block-function (i-mem-block-next block)))
	     (= (+ (i-mem-block-start block)
		   (i-mem-block-length block))
		(i-mem-block-start (i-mem-block-next block))))
    (incf (i-mem-block-length block) (i-mem-block-length (i-mem-block-next block)))
    (when (i-mem-block-next (i-mem-block-next block))
      (setf (i-mem-block-prev (i-mem-block-next (i-mem-block-next block))) block))
    (setf (i-mem-block-next block) (i-mem-block-next (i-mem-block-next block))))
  nil)

(defvar *a-memory-usage-table* nil)

(defun print-a-memory-usage-table ()
  (format t "~&V=system variabe, C=system constant, D=system dispatch, M=mouse cursor")
  (format t "~&S=scan pointer, L=reverse l1 map, p=constants page, m=c mem reverse map")
  (format t "~&u=user constant, a=user unboxed, A=user boxed, .=empty, ?=unknown")
  (do ((adr 0 (1+ adr))
       type)
      ((= adr 4096.))
    (when (zerop (ldb (byte 6 0) adr))
      (format t "~&~5o: " adr))
    (setq type (aref *a-memory-usage-table* adr))
    (when (consp type)
      (setq type (car type)))
    (send standard-output :tyo
	  (case type
	    (system-variable #/V)
	    (system-constant #/C)
	    (system-dispatch #/D)
	    (mouse-cursor #/M)
	    ((findcore-scan-pointers aging-scan-pointers) #/S)
	    (reverse-first-level-map #/L)
	    (copy-of-constants-page #/p)
	    (c-mem-reverse-map #/m)
	    (user-constant #/c)
	    (user-unboxed-variable #/a)
	    (user-boxed-variable #/A)
	    (nil #/.)
	    (t
	     #/?
	     (ferror nil "unknown ~s" (aref *a-memory-usage-table* adr))
	     )))))
	     
	     

(defun set-up-a-memory-usage-table ()
  (when (null *a-memory-usage-table*)
    (setq *a-memory-usage-table* (make-array 4096.)))
  (array-initialize *a-memory-usage-table* nil)
  (loop for adr from 0 below (symbol-table-get 'lam::a-mem-loc)
	do (aset 'system-variable *a-memory-usage-table* adr))
  (loop for adr from (symbol-table-get 'lam::a-constant-base) below (symbol-table-get 'lam::a-constant-loc)
	do (aset 'system-constant *a-memory-usage-table* adr))
  (select-processor
    (:lambda
      (dolist (range (symbol-table-get 'lam::d-memory-range-list))
	(loop for adr from (car range) below (+ (car range) (cadr range))
	      do (aset 'system-dispatch *a-memory-usage-table* adr))))
    ((:explorer :cadr)))
  ;; mouse cursor now out of a-memory.
  ;;  (loop for adr from #o1600 below #o1740
  ;;        do (aset 'mouse-cursor *a-memory-usage-table* adr))
  (loop for adr from #o1740 below #o1760
	do (aset 'findcore-scan-pointers *a-memory-usage-table* adr))
  (loop for adr from #o1760 below #o2000
	do (aset 'aging-scan-pointers *a-memory-usage-table* adr))
  ;;note: 1774 to 1777 used by explorer PROM to pass boot info
  (select-processor
    (:lambda
      (loop for adr from #o2000 below #o2200
	    do (aset 'reverse-first-level-map *a-memory-usage-table* adr)))
    ((:explorer :cadr)))
  (loop for adr from #o2200 below #o2300
	do (aset 'copy-of-constants-page *a-memory-usage-table* adr))
  ;;#o2300 to #o2400 free
  (loop for adr from #o2400 below #o3000
	do (aset 'c-mem-reverse-map *a-memory-usage-table* adr))
  
  (select-processor
    (:lambda
      (dolist (block (symbol-table-get 'lam::d-mem-free-blocks))
	(when block
	  (loop for adr from (cdr block) below (+ (cdr block) (car block))
		when (not (null (aref *a-memory-usage-table* adr)))
		do (ferror nil "d-mem-free-block not really free")))))
    ((:explorer :cadr)))

  (dolist (var '(m-36 m-37 m-41 m-42
		 m-55 m-56 m-57 m-60 m-61 m-62 m-63 m-64 m-65 m-66 m-67))
    (when (m-mem-lookup var)
      (aset nil *a-memory-usage-table* (m-mem-lookup var))))

  ;;check to make sure free locs are 0

  )
  
(defun allocate-a-mem-block (length alignment function)
  (do ((possibility nil)
       (adr 64. (1+ adr))
       (alignment-mask (1- (ash 1 alignment)))
       )
      ((= adr (array-length *a-memory-usage-table*))
       (ferror nil "no space"))
    (cond ((null possibility)
	   (when (and (null (aref *a-memory-usage-table* adr))
		      (zerop (logand alignment-mask adr)))
	     (setq possibility adr)))
	  ((aref *a-memory-usage-table* adr)
	   (setq possibility nil))
	  ((= (- adr possibility) length)
	   (dotimes (offset length)
	     (aset `(user-unboxed-variable ,(gensym) ,function)
		   *a-memory-usage-table*
		   (+ possibility offset)))
	   (return possibility)))))
		      
  
(defun find-or-make-a-variable (name initial-value boxed-p function)
  (when boxed-p
    (ferror nil "not yet supported"))
  (do ((adr 64. (1+ adr))
       (type (if boxed-p 'user-boxed-variable 'user-unboxed-variable))
       first-free-slot
       )
      ((= adr (array-length *a-memory-usage-table*))
       (when (null first-free-slot)
	 (ferror nil "out of a slots"))
       (when (not (zerop (read-a-mem first-free-slot)))
	 (ferror nil "slot not 0"))
       (write-a-mem first-free-slot initial-value)
       (aset (list type name function) *a-memory-usage-table* first-free-slot)
       first-free-slot)
    (let ((slot (aref *a-memory-usage-table* adr)))
      (when (and (null first-free-slot)
		 (null slot))
	(setq first-free-slot adr))
      (when (and (consp slot)
		 (eq (car slot) type)
		 (eq (cadr slot) name))
	(when (not (memq function (cddr slot)))
	  (aset (append slot (list function)) *a-memory-usage-table* adr))
	(return adr)))))

(defun find-or-make-m-variable (name initial-value boxed-p function)
  (when boxed-p
    (ferror nil "not yet supported"))
  (do ((adr 0 (1+ adr))
       (type (if boxed-p 'user-boxed-variable 'user-unboxed-variable))
       first-free-slot
       )
      ((= adr 64.)
       (when (null first-free-slot)
	 (ferror nil "out of m slots"))
       (when (not (zerop (read-a-mem first-free-slot)))
	 (ferror nil "slot not 0"))
       (write-a-mem first-free-slot initial-value)
       (aset (list type name function) *a-memory-usage-table* first-free-slot)
       first-free-slot)
    (let ((slot (aref *a-memory-usage-table* adr)))
      (when (and (null first-free-slot)
		 (null slot))
	(setq first-free-slot adr))
      (when (and (consp slot)
		 (eq (car slot) type)
		 (eq (cadr slot) name))
	(when (not (memq function (cddr slot)))
	  (aset (append slot (list function)) *a-memory-usage-table* adr))
	(return adr)))))

(defun find-or-make-a-constant (val for-function)
  (do ((adr 64. (1+ adr))
       first-free-slot)
      ((= adr (array-length *a-memory-usage-table*))
       (when (null first-free-slot)
	 (ferror nil "out of a constant slots"))
       (aset (list 'user-constant val for-function) *a-memory-usage-table* first-free-slot)
       (when (not (zerop (read-a-mem first-free-slot)))
	 (ferror nil "slot not 0"))
       (write-a-mem first-free-slot val)
       first-free-slot)
    (let ((slot (aref *a-memory-usage-table* adr)))
      (when (and (null slot)
		 (null first-free-slot))
	(setq first-free-slot adr))
      (cond ((and (eq slot 'system-constant)
		  (= val (read-a-mem adr)))
	     (return adr))
	    ((and (consp slot)
		  (eq (car slot) 'user-constant)
		  (= val (cadr slot)))
	     (when (not (memq for-function (cddr slot)))
	       (aset (append slot (list for-function)) *a-memory-usage-table* adr))
	     (return adr))))))
	    
(defun free-a-memory-for-function (function)
  (do ((adr 0 (1+ adr)))
      ((= adr (array-length *a-memory-usage-table*)))
    (let ((slot (aref *a-memory-usage-table* adr)))
      (when (and (consp slot)
		 (memq (car slot) '(user-constant user-unboxed-variable user-boxed-variable))
		 (memq function (cddr slot)))
	(setf (cddr slot) (remq function (cddr slot)))
	(when (null (cddr slot))
	  (setq slot nil)
	  (write-a-mem adr 0)
	  )
	(aset slot *a-memory-usage-table* adr)))))

(defun print-user-a-memory-slots ()
  (do ((adr 0 (1+ adr)))
      ((= adr (array-length *a-memory-usage-table*)))
    (let ((slot (aref *a-memory-usage-table* adr)))
      (when (and (consp slot)
		 (memq (car slot) '(user-constant user-unboxed-variable user-boxed-variable)))
	(format t "~&~5o: ~s" adr slot)))))
		 
(defun read-a-mem (adr)
  (cond ((< adr 0)
	 (ferror nil "bad adr"))
	((< adr 1024.)
	 (dpb (%p-ldb (byte 16. 16.) (%pointer-plus si::a-memory-virtual-address adr))
	      (byte 16. 16.)
	      (%p-ldb (byte 16. 0) (%pointer-plus si::a-memory-virtual-address adr))))
	((< adr 4096.)
	 (%read-a-mem adr))
	(t
	 (ferror nil "bad adr"))))


(defun write-a-mem (adr val)
  (cond ((< adr 0)
	 (ferror nil "bad adr"))
	((< adr 1024.)
	 (%p-dpb (ldb (byte 16. 0) val)
		 (byte 16. 0)
		 (%pointer-plus si::a-memory-virtual-address
				adr))
	 (%p-dpb (ldb (byte 16. 16.) val)
		 (byte 16. 16.)
		 (%pointer-plus si::a-memory-virtual-address
				adr)))
	((< adr 4096.)
	 (%write-a-mem adr val))
	(t
	 (ferror nil "bad adr")))
  val)
  



;;choose real numbers later and put into defmic
compiler:(defmic placeholder-0 1200 () nil)
compiler:(defmic placeholder-1 1201 () nil)
compiler:(defmic placeholder-2 1202 () nil)
compiler:(defmic placeholder-3 1203 () nil)
compiler:(defmic placeholder-4 1204 () nil)
compiler:(defmic placeholder-5 1205 () nil)
compiler:(defmic placeholder-6 1206 () nil)
compiler:(defmic placeholder-7 1207 () nil)

(let ((si::%inhibit-read-only t))
  (aset 'compiler::placeholder-0 #'si::micro-code-symbol-name-area 1000)
  (aset 'compiler::placeholder-1 #'si::micro-code-symbol-name-area 1001)
  (aset 'compiler::placeholder-2 #'si::micro-code-symbol-name-area 1002)
  (aset 'compiler::placeholder-3 #'si::micro-code-symbol-name-area 1003)
  (aset 'compiler::placeholder-4 #'si::micro-code-symbol-name-area 1004)
  (aset 'compiler::placeholder-5 #'si::micro-code-symbol-name-area 1005)
  (aset 'compiler::placeholder-6 #'si::micro-code-symbol-name-area 1006)
  (aset 'compiler::placeholder-7 #'si::micro-code-symbol-name-area 1007))

(defun make-misc-callable-function (name)
  (when (null (get name 'compiler::new-micro-n-args))
    (ferror nil "must be micro-function"))
  (putprop name 'compiler::placeholder-p1 'compiler::p1)
  (putprop name 'compiler::placeholder-p2 'compiler::p2))


(defmethod (eh::illegal-instruction :patch-illegal-instruction-if-possible) ()
  (when eh::pc
    (let* ((offset (floor eh::pc 2))
	   (byte-spec (byte 16. (if (oddp eh::pc) 16. 0)))
	   (inst (%p-ldb-offset byte-spec eh::compiled-function offset))
	   (op (ldb (byte 4 #o11) inst))
	   (sub-op (ldb (byte 3 #o15) inst))
	   ;(dest (ldb (byte 2 #o16) inst))
	   (disp (ldb (byte #o11 0) inst))
	   misc-number)
      (when (= op #o15)
	;;it is a MISC or MISC1 inst
	(setq misc-number disp)
	(if (bit-test 1 sub-op)
	    (incf misc-number #o1000))
	(when (<= (get 'compiler::placeholder-0 'compiler::qlval)
		  misc-number
		  (+ (get 'compiler::placeholder-0 'compiler::qlval) 7))
	  (let ((placeholder-number (- misc-number (get 'compiler::placeholder-0 'compiler::qlval)))
		(table (cdr (assq 'compiler::placeholder-to-micro-function-table (debugging-info eh::compiled-function))))
		info)
	    (when table
	      (dolist (entry table)
		(when (= (cadr entry) placeholder-number)
		  (setq info entry)
		  (return)))
	      (when info
		(let* ((micro-function (car info))
		       (symbol-area-slot (get micro-function 'micro-symbol-area-slot)))
		  (when symbol-area-slot
		    (cond ((< (+ symbol-area-slot #o200) #o1000)
			   (setq inst (dpb 0 (byte 1 13.) inst))
			   (setq inst (dpb (+ symbol-area-slot #o200) (byte 9. 0) inst)))
			  (t
			   (setq inst (dpb 1 (byte 1 13.) inst))
			   (setq inst (dpb (+ symbol-area-slot #o200) (byte 9. 0) inst))))
		    (let ((si::%inhibit-read-only t))
		      (%p-dpb-offset inst byte-spec eh::compiled-function offset))
		    (aref #'si::micro-code-symbol-area symbol-area-slot)
		    ))))))))))
			   

;stat bit is (byte 1 57.) = bit 25. in high word
(defun write-stat-bit (adr val)
  (setq adr (i-mem-lookup adr))
  (write-c-mem adr
	       (dpb val
		    (byte 1 57.)
		    (read-c-mem adr))))

(defun read-stat-bit (sym)
  (setq sym (i-mem-lookup sym))
  (ldb (byte 1 57.) (read-c-mem sym)))

(defun write-stat-bits-in-range (from to val)
  (setq from (i-mem-lookup from))
  (setq to (i-mem-lookup to))
  (if (not (< 0 from to 65536.))
      (ferror nil "addresses out of range"))
  (do ((adr from (1+ adr)))
      ((>= adr to))
    (write-stat-bit adr val)))

#|
(write-stat-bits-in-range 'qmlp '(qmlp 3) 0)
(write-stat-bits-in-range 'p3adi '(LOAD-PDL-BUFFER-INDEX 3) 1)
(write-stat-bits-in-range 'qical0-fef 'qimove-ignore-fef-0 1)
(write-stat-bits-in-range 'qmddl 'fetch-fef-offset 1)
|#

(defun set-macro-single-step (flag)
  "FLAG means:
 T   - go to QMLP between every macro instruction
 NIL - transfer directly from the end of one macro instruction to the beginning
       of the next, if it is already present in the high bits of the macro-ir"
  (let* ((adr (i-mem-lookup '(lam::sg-alt-main-x -1)))
	 (inst (read-c-mem adr))
	 (a-adr (find-or-make-a-constant (dpb 1 (byte 1 #o37) 0) t)))
    (if (or (null a-adr)
	    (not (= (ldb lam::lam-ir-op inst) lam::lam-op-alu))
	    (not (= (ldb lam::lam-ir-ob inst) lam::lam-ob-alu))
	    (not (= (ldb lam::lam-ir-func-dest inst) lam::lam-func-dest-rg-mode))
	    (not (= (ldb lam::lam-ir-m-src inst) lam::lam-m-src-rg-mode)))
	(ferror nil "unexpected instruction"))
    (setq inst (dpb (if flag
			lam::lam-alu-ior
		      lam::lam-alu-andca
		      )
		    lam::lam-ir-aluf
		    inst))
    (write-c-mem adr inst)))

; was needed in old microcode
;(defun patch-mid-ucode ()
;  (let ((new-inst (lam::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-lc
;				   lam-ir-func-dest lam-func-dest-lc)))
;    (when (ldb-test lam-ir-source-to-macro-ir (read-c-mem '(xripm-mid -2)))
;      (write-c-mem '(xripm-mid -2) new-inst))
;    (when (ldb-test lam-ir-source-to-macro-ir (read-c-mem '(unknown-misc -2)))
;      (write-c-mem '(unknown-misc -2) new-inst))))
  
(defun get-support-entry-vector-slot (object &aux empty-slot)
  (do ((slot 0 (1+ slot)))
      ((= slot (array-length #'si::support-entry-vector)))
    (let ((val (aref #'si::support-entry-vector slot)))
    (cond ((eq val object)
	   (return-from get-support-entry-vector-slot slot))
	  ((null val)
	   ;;get highest empty slot
	   (setq empty-slot slot)))))
  (when (null empty-slot)
    (ferror nil "out of slots"))
  (let ((si::%inhibit-read-only t))
    (aset object #'si::support-entry-vector empty-slot))
  empty-slot)
  
	   


(defun initialize-support-entry-vector (&aux (si::%inhibit-read-only t))
  (let ((start (si::%region-free-pointer si::support-entry-vector)))
    (aset (si::%region-length si::support-entry-vector)
	  #'si::region-free-pointer
	  si::support-entry-vector)
    (do ((offset start (1+ offset)))
	((= offset (si::%region-length si::support-entry-vector)))
      (%p-store-contents (%pointer-plus (si::%region-origin si::support-entry-vector)
					offset)
			 nil))
    ;;just check to make sure no DTP-TRAPs
    (dotimes (offset #o400)
      (if (zerop (%p-ldb %%q-data-type (%pointer-plus (si::%region-origin si::support-entry-vector) offset)))
	  (%p-store-contents (%pointer-plus (si::%region-origin si::support-entry-vector) offset) nil)))

    ))

(defun set-up-once ()
  (when (not (= si::%number-of-micro-entries
		(fill-pointer #'si::micro-code-entry-area)))
    (ferror nil "entry area out of phase"))

  (set-up-i-mem-blocks)

  (when (not (boundp 'eh::extra-error-table))
    (setq eh::extra-error-table nil))

  (set-up-a-memory-usage-table)

;  (patch-mid-ucode)
  (initialize-support-entry-vector)
  )

(add-initialization "set up new micro assembler"
		    '(set-up-once)
		    '(:once))