;-*- Mode:LISP; Package:COMPILER; Base:8; Readtable:ZL -*-
;	** (c) Copyright 1980 Massachusetts Institute of Technology **
;	** (c) Copyright 1984, Lisp Machine Inc. **

;MCLAP:
;  A self-containted format that can be hung off a property-list, written out in a
;   QFASL file, etc.  The position in control memory and the version of UCADR, etc,
;   are not assumed.

;Two lists of microcompiled functions resident in C-MEM are kept:
;*MCLAP-ACTIVE-FUNCTIONS* and *MCLAP-LOADED-FUNCTIONS*.  Active functions
;are completely installed, ready for execution.  Loaded but not active functions
;are resident in C-MEM, but not currently ready for execution nor installed.
;The main reason a function might not be suitable for execution is that it contains
;unresolved MICRO-MICRO calls.  After the function(s) being called are loaded,
;the function can be activated.
;  The *MCLAP-LOADED-FUNCTIONS* list is ordered and serves as sort of a push down
;list.  Newly loaded functions are always CONSed on the front, and the functions
;at the head of the list is always the first unloaded.


(DEFVAR *INITIALLY-MICROCOMPILED-FUNCTIONS* '())

;Format: 
;a list, ea element
;  a symbol -> tag
;  a list -> a storage word
;       car numeric ->  complete value
;       otherwise
;	   caar -> constant numeric value
;          cadr -> list of (field  value) pairs.
;		   field must be a numeric byte specifier
;         	   value is evaluated by (apply (car value) (cdr value)).

;  legal ops for (car value)
;    (mclap-evaluate-tag <tag>)  these kind of tags defined by symbols above
;    (mclap-evaluate-mc-linkage <linkage to UCADR>)
;       arg can be (misc-entry  <misc-instruction-symbol>)
;    (mclap-micro-micro-linkage <microcoded fctn> <nargs>)
;    (mclap-linkage-eval <mc-linkage-symbol>)
;    (mclap-get-quote-index <s-exp>)
;    (mclap-get-quote-index-vector <list of sexps>)
;    (mclap-get-a-constant <inum number>)
;   The MA- prefix form of each of the above is called from MA- and is the only
;     place the MCLAP- form is generated

(DEFVAR *MC-LINKAGE-ALIST* NIL)
(DEFVAR *UCADR-STATE-LIST* NIL)

(DEFVAR *FUNCTIONS-WITH-MCLAP* NIL)	;list of all functions with "active" MCLAP properties.
		;They are not necessarily loaded or active tho.
(DEFVAR *MCLAP-LOADED-FUNCTIONS* NIL)	;list of microcompiled fctns that actually
		;reside in control mem, "most recent" first.
		;note that these are not necesarily "activated", however.
(DEFVAR *MCLAP-ACTIVE-FUNCTIONS* NIL)	;list of microcompiled fctns actually in use.

(DEFVAR *MCLAP-CODE*)		;args to MCLAP
(DEFVAR *MCLAP-BASE-LOC*)
  ;the next two vars represent constants added to *A-CONSTANT-TABLE* in this assembly.
(DEFVAR *MCLAP-A-CONSTANT-TABLE*)   ;list of numbers already assigned into a-mem
(DEFVAR *MCLAP-A-CONSTANT-TABLE-OFFSET*) ;a-address of first of *MCLAP-A-CONSTANT-TABLE*
(DEFVAR *MCLAP-EXIT-VECTOR-TABLE*)
(DEFVAR *MCLAP-EXIT-VECTOR-OFFSET*)
(DEFVAR *MCLAP-MM-LINKAGE-LIST*)
(DEFVAR *MCLAP-MM-LINKAGE-FLAG*)

(DEFVAR *MCLAP-LOC*)		;current location within MCLAP

(DEFVAR NUMBER-MICRO-ENTRIES NIL)  ;Should have same value as SYSTEM:%NUMBER-OF-MICRO-ENTRIES
				   ;Point is, that one is stored in A-MEM and is reloaded
				   ;if machine gets warm-booted.


(defvar *least-misc-opcode* #o200 "opcodes less then this had some obscure purpose at one time")
(defvar *greatest-misc-opcode* #o1777)

(defsubst misc-opcode->array-index (j)
  (- j *least-misc-opcode*))

(defconst *ma-micro-paging-on-by-default* t)
(defvar *ma-micro-paging-mode* nil "nil, write into physical c-mem, t use microcode paging.")

;on-p is 
;  NIL   		off
;  T     		on
;  :IF-ALREADY-ON  	ON if micro-code has already turned it on, otherwise NO-OP.
(defun set-micro-paging (on-p)
  (cond ((and (eq on-p :IF-ALREADY-ON)
	      (zerop (%logldb (byte 1 10.) si:%disk-switches)))
	 ;not already on, do nothing now
	 )
	(t
	 (ma-reset)
	 (%micro-paging 3)    ;reset CRAM-ADR-MAP, FLUSH PROM.
	 (setq si:%disk-switches (%logdpb (if on-p 1 0) (byte 1 10.) si:%disk-switches))
	 (setq *ma-micro-paging-mode* (if on-p t nil))
	 (ma-initialize-variables))))

;these hold global "state-of-the-world" info.
(DEFVAR *C-MEM-LOC* NIL "Free control mem locn")
(DEFVAR *C-MEM-LOC-LIMIT* NIL)
(DEFVAR *A-CONSTANT-TABLE-FREE-POINTER* NIL "Free A-MEM loc")
(DEFCONST *A-CONSTANT-TABLE-LIMIT* 2400)

(DEFVAR *A-CONSTANT-TABLE-INITIAL-FREE-POINTER* NIL 
  "first A-MEM locn used for MC constants.")
(DEFVAR *A-CONSTANT-TABLE* NIL
  "Contents of A-MEM locs beginning with *A-constant-table-initial-free-pointer,
as LISP quantities.")

(DEFVAR *MC-EXIT-VECTOR-ARRAY* NIL
  "Array holds actual exit vector ref'ed by UCODE.
array-leader 0 is fill pointer.
600 below is after misc's. 1400 allows for 200 misc1's.")

(DEFVAR *MA-MICRO-CODE-SYMBOL-INDEX* (MISC-OPCODE->ARRAY-INDEX (1+ *GREATEST-MISC-OPCODE*))
  "allocates positions in MICRO-CODE-SYMBOL-AREA")

(DEFVAR *MA-MICRO-CODE-SYMBOL-INDEX-ASSIGNMENTS* NIL
  "ASSQ list (<function name> . <idx>)")


(DEFUN MA-INSTALL-MCLAP (FUNCTION-NAME MCLAP)
  (SI:FUNCTION-SPEC-PUTPROP FUNCTION-NAME MCLAP 'MCLAP)
  (PUSHNEW FUNCTION-NAME *FUNCTIONS-WITH-MCLAP* :TEST 'EQUAL))

(DEFUN MA-DEINSTALL-MCLAP (FUNCTION-NAME)
;  (MCLAP-UNLOAD FCTN-NAME)
;  (SI:FUNCTION-SPEC-REMPROP FCTN-NAME 'MCLAP)
;  (SETQ *FUNCTIONS-WITH-MCLAP* (DELETE FUNCTION-NAME *FUNCTIONS-WITH-MCLAP*)))
  )

(DEFUN MA-LOAD-ALL ()
  (APPLY 'MA-LOAD *FUNCTIONS-WITH-MCLAP*))

(DEFUN MA-LOAD (&REST FUNCTIONS)
  (DOLIST (FUNCTION-NAME FUNCTIONS)
    (IF (NULL (SI:FUNCTION-SPEC-GET FUNCTION-NAME 'MCLAP))
	(FERROR NIL "~%Function ~s has no MCLAP" FUNCTION-NAME)))
  (GET-UCADR-STATE-LIST)	;will be fast if already in.
  (COND ((NULL *A-CONSTANT-TABLE-FREE-POINTER*)
	 (MA-INITIALIZE-VARIABLES)))
  (cond ((and *ma-micro-paging-on-by-default*
	      (zerop (%logldb  (byte 1 10.) si:%disk-switches)))
	 (format t "~%Turning on microcode paging.")
	 (set-micro-paging t)))
  (DOLIST (FUNCTION-NAME FUNCTIONS)
    (MCLAP-UNLOAD FUNCTION-NAME))	;remove previous from control mem, if there
 ;do this in two phases so MICRO-MICRO calls between these fctns can work.
  (DOLIST (FUNCTION-NAME FUNCTIONS)
    (MCLAP-LOAD T (SI:FUNCTION-SPEC-GET FUNCTION-NAME 'MCLAP)))
  (DOLIST (FUNCTION-NAME FUNCTIONS)
    (MCLAP-ACTIVATE FUNCTION-NAME))
  (if *ma-micro-paging-mode*
      (compiler:%micro-paging 3)))  ;cause all ucode to be paged-in again so new stuff "seen"
			;FLUSH PROM.

(DEFUN MA-PRINT (FUNCTION-NAME &optional micro-pc-list)
  (lambda:assure-lam-symbols-loaded)
  (cond ((not (boundp 'lambda:lam-symbols-size))
	 (lambda:lam-dont-use-symbols)))
  (let ((*c-mem-loc* *c-mem-loc*)
	(*a-constant-table-free-pointer* *a-constant-table-free-pointer*)
	(*a-constant-table* (copylist *a-constant-table*))
	(*package* (pkg-find-package "LAMBDA"))	;to print less package prefixes
	)
    (LET ((INFO (SI:FUNCTION-SPEC-GET FUNCTION-NAME 'MCLAP-LOADED-INFO)))
      (cond ((OR (NULL INFO)
		 (NOT (MEMBER FUNCTION-NAME *MCLAP-LOADED-FUNCTIONS*))))
	    (t (format t "~%Setting C-MEM location to ~s, which is where ~s is loaded"
		       (first info) function-name)
	       (setq *c-mem-loc* (FIRST INFO))))
      (MCLAP-LOAD 'PRINT (SI:FUNCTION-SPEC-GET FUNCTION-NAME 'MCLAP) micro-pc-list))))

(DEFUN MA-RESET NIL		;UNLOADS ALL
  (do () ((null *mclap-loaded-functions*))
    (MCLAP-UNLOAD (CAR (LAST *MCLAP-LOADED-FUNCTIONS*))))  
  (MA-REBOOT))

(DEFF MA-UNLOAD 'MCLAP-UNLOAD)
  
(DEFUN MCLAP-LOAD (LOAD-P MCLAP &optional micro-pc-list)
  (LET ((PARAM-LIST (FIRST MCLAP))
	(MCLAP-CODE (SECOND MCLAP)))
    (LET ((FUNCTION-NAME (CADR (ASSQ 'FUNCTION-NAME PARAM-LIST))))
      (COND ((NULL *MC-EXIT-VECTOR-ARRAY*)
	     (MA-INITIALIZE-EXIT-VECTOR)))
      (MULTIPLE-VALUE-BIND (NEW-C-LOC RTN-ACT RTN-EVT RTN-MM-LINKAGE-LIST)
	  (MCLAP FUNCTION-NAME
		 LOAD-P				;load-p
		 *C-MEM-LOC*			;base C-MEM loc
		 *A-CONSTANT-TABLE-FREE-POINTER* ;base for new constants 
		 NIL				;EXIT-VECTOR-TABLE
		 (ARRAY-LEADER *MC-EXIT-VECTOR-ARRAY* 0)
		 MCLAP-CODE micro-pc-list)
	(COND ((EQ LOAD-P T)
	       (SI:FUNCTION-SPEC-PUTPROP FUNCTION-NAME
			(LIST *C-MEM-LOC*
			      *A-CONSTANT-TABLE*
			      *A-CONSTANT-TABLE-FREE-POINTER*
			      (ARRAY-LEADER *MC-EXIT-VECTOR-ARRAY* 0) RTN-MM-LINKAGE-LIST
			      (DPB (CADR (ASSQ '%MINARGS PARAM-LIST))
				   606
				   (CADR (ASSQ '%MAXARGS PARAM-LIST)))
			      (MA-ARGLIST-FROM-DEBUG-INFO
				(CDR (ASSQ 'DEBUG-INFO PARAM-LIST))))
			'MCLAP-LOADED-INFO)
	       (DOLIST (C RTN-ACT)
		 (MA-LOAD-A-MEM *A-CONSTANT-TABLE-FREE-POINTER*
				C)
		 (SETQ *A-CONSTANT-TABLE-FREE-POINTER* (1+ *A-CONSTANT-TABLE-FREE-POINTER*))
		 (IF (NOT (< *A-CONSTANT-TABLE-FREE-POINTER* *A-CONSTANT-TABLE-LIMIT*))
		     (FERROR NIL "A-CONSTANT memory full")))
	       (SETQ *A-CONSTANT-TABLE* (append *A-CONSTANT-TABLE* RTN-ACT))
	       (DOLIST (Q RTN-EVT)
		 (MA-LOAD-EXIT-VECTOR-Q Q))
	       (SETQ *C-MEM-LOC* NEW-C-LOC)
	       (IF (NOT (< *C-MEM-LOC* *C-MEM-LOC-LIMIT*))
		   (FERROR NIL "CONTROL memory full"))
	       (PUSH FUNCTION-NAME *MCLAP-LOADED-FUNCTIONS*)))
	))))

(DEFUN MCLAP-ACTIVATE (FUNCTION-NAME)
  (LET ((INFO (SI:FUNCTION-SPEC-GET FUNCTION-NAME 'MCLAP-LOADED-INFO)))
    (IF (NULL INFO) (FERROR NIL "")
	(MCLAP-PLUGIN-MM-CALLS (FIFTH INFO))
	(MA-INSTALL FUNCTION-NAME
		    (SIXTH INFO)	;args q
		    (SEVENTH INFO)	;arglist
		    (FIRST INFO))	;C-MEM starting loc
	(PUSH FUNCTION-NAME *MCLAP-ACTIVE-FUNCTIONS*))))

(DEFUN MCLAP-DEACTIVATE (FUNCTION-NAME)
  (COND ((MEMBER FUNCTION-NAME *MCLAP-ACTIVE-FUNCTIONS*)
	 (SETQ *MCLAP-ACTIVE-FUNCTIONS* (DELETE FUNCTION-NAME *MCLAP-ACTIVE-FUNCTIONS*))
	 (MA-UNINSTALL FUNCTION-NAME)
	 (DOLIST (F *MCLAP-LOADED-FUNCTIONS*)	;if anybody MM calls this guy, deactivate him
	   (COND ((ASSOC FUNCTION-NAME (FIFTH (SI:FUNCTION-SPEC-GET F 'MCLAP-LOADED-INFO))) ;too.
		  (MCLAP-DEACTIVATE F)))))))

(DEFUN MCLAP-UNLOAD (FUNCTION-NAME)
  (PROG (F INFO)
	(COND ((NULL (MEMBER FUNCTION-NAME *MCLAP-LOADED-FUNCTIONS*))
	       (RETURN NIL)))
   L	(COND ((NULL *MCLAP-LOADED-FUNCTIONS*) (FERROR NIL "huh?")))
	(MCLAP-DEACTIVATE (SETQ F (CAR *MCLAP-LOADED-FUNCTIONS*)))
	(COND ((SETQ INFO (SI:FUNCTION-SPEC-GET F 'MCLAP-LOADED-INFO))
	       (SETQ *C-MEM-LOC* (FIRST INFO)
		     *a-constant-table* (SECOND INFO)
		     *A-CONSTANT-TABLE-FREE-POINTER* (THIRD INFO))
	       (STORE-ARRAY-LEADER (FOURTH INFO) *MC-EXIT-VECTOR-ARRAY* 0)
	       (SI:FUNCTION-SPEC-REMPROP F 'MCLAP-LOADED-INFO)))
	(SETQ *MCLAP-LOADED-FUNCTIONS* (CDR *MCLAP-LOADED-FUNCTIONS*))
	(IF (EQUAL F FUNCTION-NAME)
	    (RETURN T)
	    (GO L))))

(DEFUN MA-ARGLIST-FROM-DEBUG-INFO (DEBUG-INFO)
  (MAPCAR (FUNCTION CAR) (CADR (ASSQ 'ARG-MAP DEBUG-INFO))))

;This has no side effects if LOAD-P nil.  Writes C-MEM if LOAD-P T.
; In either case, it can NCONC onto *MCLAP-A-CONSTANT-TABLE* and *MCLAP-EXIT-VECTOR-TABLE*.
(DEFUN MCLAP (FUNCTION-NAME LOAD-P *MCLAP-BASE-LOC*
	      *MCLAP-A-CONSTANT-TABLE-OFFSET*
	      *MCLAP-EXIT-VECTOR-TABLE* *MCLAP-EXIT-VECTOR-OFFSET*
	      *MCLAP-CODE*
	      &optional micro-stack-pcs		;pcs on the micro stack that might be in this fctn
	      )
 (PROG (*MCLAP-MM-LINKAGE-LIST* *MCLAP-MM-LINKAGE-FLAG* NOOPS-DUE-TO-PAGING
	*MCLAP-A-CONSTANT-TABLE*)
       (setq *MCLAP-CODE* (COPYLIST *MCLAP-CODE*)
	     *MCLAP-LOC* *MCLAP-BASE-LOC*)
   ;pass1 determines if MM links need to be one uinst or two, and inserts no-ops
   ; if necessary at micro-code page boundaries.
       (MULTIPLE-VALUE-SETQ (*MCLAP-CODE* NOOPS-DUE-TO-PAGING)
	 (MCLAP-PASS1 *MCLAP-CODE* *MCLAP-LOC*))
       (DOLIST (I *MCLAP-CODE*)
	 (IF (SYMBOLP I)
	     (IF (EQ LOAD-P 'PRINT)
		 (format t "~&   ~s" *MCLAP-LOC*))
	   (SETQ *MCLAP-MM-LINKAGE-FLAG* NIL)
	   (LET ((W (MCLAP-WORD I)))
	     (IF *MCLAP-MM-LINKAGE-FLAG*
		 (PUSH (LIST (CAR *MCLAP-MM-LINKAGE-FLAG*)	;fctn name
			     (CADR *MCLAP-MM-LINKAGE-FLAG*)	;# args
			     *MCLAP-LOC*
			     W)
		       *MCLAP-MM-LINKAGE-LIST*))
	     (COND ((EQ LOAD-P T)
		    (MA-LOAD-C-MEM *MCLAP-LOC* W))
		   ((EQ LOAD-P 'PRINT)
		    (if (memq *mclap-loc* micro-stack-pcs)
			(format t "~&=> ")
		      (format t "~&   "))
		    (LAMBDA:LAM-TYPE-OUT W LAMBDA:LAM-UINST-DESC T T)))
	     (SETQ *MCLAP-LOC* (1+ *MCLAP-LOC*)))))
       (FORMAT T
 "~%For function ~s, ~d Uinsts, ~d NOOPs (avoid XCT-NEXT across Upage boundaries).
   A-OFFSET: ~O"
 function-name (- *mclap-loc* *mclap-base-loc*) noops-due-to-paging
 *A-CONSTANT-TABLE-FREE-POINTER*)
       (RETURN *MCLAP-LOC* *MCLAP-A-CONSTANT-TABLE*
	       *MCLAP-EXIT-VECTOR-TABLE* *MCLAP-MM-LINKAGE-LIST*)
  ))

(DEFUN MCLAP-PLUGIN-MM-CALLS (MM-LINKAGE-LIST)
  (DOLIST (MM MM-LINKAGE-LIST)
    (MA-LOAD-C-MEM (THIRD MM)
		   (DPB (MCLAP-C-MEM-ENTRY-LOC (FIRST MM))
			LAMBDA:LAM-IR-JUMP-ADDR 
			(FOURTH MM)))))

(DEFUN MCLAP-C-MEM-ENTRY-LOC (FUNCTION-NAME)
  (LET ((INFO (SI:FUNCTION-SPEC-GET FUNCTION-NAME 'MCLAP-LOADED-INFO)))
    (IF (OR (NULL INFO)
	    (NOT (MEMBER FUNCTION-NAME *MCLAP-LOADED-FUNCTIONS*)))
	(FERROR NIL "MICRO-MICRO Link to ~S which is not loaded" FUNCTION-NAME)
	(FIRST INFO))))	;return C-MEM starting address.
	
;can add to *MCLAP-A-CONSTANT-TABLE*
(DEFUN MCLAP-PASS1 (CODE LOC)
  (PROG (P TRAILP FIELDLIST TEM NOOPS-DUE-TO-PAGING)
	(SETQ P CODE TRAILP (LOCF CODE)
	      NOOPS-DUE-TO-PAGING 0)
    L	(COND ((NULL P) (RETURN CODE NOOPS-DUE-TO-PAGING))
	      ((SYMBOLP (CAR P))
	       (GO E))
	      ((CONSP (CAR P))
	       (SETQ FIELDLIST (CADAR P))))
	(COND ((AND (CONSP (CAR P))
		    (SETQ TEM (MCLAP-FIELD 'MCLAP-MICRO-MICRO-LINKAGE FIELDLIST)))
	;this term deals with MICRO-MICRO links to Ucompiled fctns.
	       (SETQ TEM (CADR TEM))
	       (LET ((ARGS-INFO (MCLAP-ARGS-INFO (CADR TEM)))	   ;this a MM call. 2 wds?
		     (NARGS (CADDR TEM)))
		 (COND ((OR (< NARGS (LDB %%ARG-DESC-MIN-ARGS ARGS-INFO))
			    (> NARGS (LDB %%ARG-DESC-MAX-ARGS ARGS-INFO)))
			(FERROR NIL 
 "~%Incorrect number of args (~s) in a micro-micro call to ~S" NARGS (CADR TEM))))
		 (COND ((NOT (= (LDB %%ARG-DESC-MIN-ARGS ARGS-INFO)
				(LDB %%ARG-DESC-MAX-ARGS ARGS-INFO))) 
			(LET ((WD (MA-RUNTIME-EVAL 0 0
					   LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-ALU  ;inst
					   LAMBDA:LAM-IR-ALUF LAMBDA:LAM-ALU-SETA
					   LAMBDA:LAM-IR-OB LAMBDA:LAM-OB-ALU
					   LAMBDA:LAM-IR-M-MEM-DEST (MC-LINKAGE-EVAL 'R)
					   LAMBDA:LAM-IR-A-SRC (MA-GET-A-CONSTANT NARGS))))
			  (RPLACD TRAILP (CONS WD P))
			  (setq loc (1+ loc))
			  (SETQ TRAILP (CDR TRAILP))))  ;now points at new cons
		       ))))
   ;The terms of following AND are in this order to exercise INSERT-NOOP-FOR-PAGING-P.  Should
   ; eventually be reversed.
	(COND ((AND *MA-MICRO-PAGING-MODE* 
		    (MCLAP-INSERT-NOOP-FOR-PAGING-P (MCLAP-WORD-CONSTANT-VALUE (CAR P)))
		    (= (LOGAND LOC 17) 17))

	       (SETQ NOOPS-DUE-TO-PAGING (1+ NOOPS-DUE-TO-PAGING))
	       (LET ((WD (MA-RUNTIME-EVAL 0 0)))
		 (RPLACD TRAILP (CONS WD P))
		 (SETQ LOC (1+ LOC))
		 (SETQ TRAILP (CDR TRAILP)))))
	(setq loc (1+ loc))
   E	(SETQ P (CDR (SETQ TRAILP (CDR TRAILP))))
	(GO L)))

; T if no-op necessary if this uinst is last one on page.
(DEFUN MCLAP-INSERT-NOOP-FOR-PAGING-P (V)
  (LET ((OP (LDB LAMBDA:LAM-IR-OP V)))
    (AND (= 0 (LDB MA-XCTED-DURING-XCT-NEXT-FLAG V))
	 (OR (= 1 (LDB LAMBDA:LAM-IR-POPJ-AFTER-NEXT V))
	     (= 1 (LDB MA-I-XCT-NEXT-FLAG V))
	     ;(= OP LAMBDA:LAM-OP-DISPATCH)   ;DISPATCHs dont xct-next unless flagged
	     (AND (= OP LAMBDA:LAM-OP-JUMP)
		  (= 0 (LDB LAMBDA:LAM-IR-N V)))
	     (AND (OR (= OP LAMBDA:LAM-OP-ALU) (= OP LAMBDA:LAM-OP-BYTE))
		  (= 0 (LDB LAMBDA:LAM-IR-A-MEM-DEST-FLAG V))
		  (OR (= (LDB LAMBDA:LAM-IR-FUNC-DEST V) LAMBDA:LAM-FUNC-DEST-IMOD-LOW)
		      (= (LDB LAMBDA:LAM-IR-FUNC-DEST V) LAMBDA:LAM-FUNC-DEST-IMOD-HIGH)))))))

(DEFUN MCLAP-FIELD (FIELD FIELD-LIST)
  (PROG NIL
    L	(COND ((NULL FIELD-LIST) (RETURN NIL))
	      ((AND (CONSP (CAR FIELD-LIST))
		    (CONSP (CADAR FIELD-LIST))
		    (EQ FIELD (CAADAR FIELD-LIST)))
	       (RETURN (CAR FIELD-LIST))))
       (SETQ FIELD-LIST (CDR FIELD-LIST))
       (GO L)))

(DEFUN MCLAP-ARGS-INFO (SYM &AUX TEM)
  (COND ((SETQ TEM (SI:FUNCTION-SPEC-GET SYM 'MCLAP))
	 (LET ((PARAM-LIST (CAR TEM)))
	   (DPB (CADR (ASSQ '%MINARGS PARAM-LIST))
		606
		(CADR (ASSQ '%MAXARGS PARAM-LIST)))))
	(T (%ARGS-INFO SYM))))

;process things made by MA-RUNTIME-EVAL
(DEFUN MCLAP-WORD (W)
  (PROG (V L TEM)
	(COND ((NUMBERP W) (RETURN W)))
	(SETQ V (CAR W) L (CADR W))
    L	(COND ((NULL L) (RETURN V)))
	(COND ((NOT (NUMBERP (SETQ TEM (APPLY (CAR (CADAR L)) (CDR (CADAR L))))))
	       (FERROR NIL "Field failed to evaluate to number ~s" TEM)))
	(SETQ V (DPB TEM (CAAR L) V))
	(SETQ L (CDR L))
	(GO L)))

(DEFUN MCLAP-WORD-CONSTANT-VALUE (W)
  (COND ((NUMBERP W) W)
	(T (CAR W))))

;simplemindedly evaluate tag by searching and counting.
(DEFUN MCLAP-EVALUATE-TAG (TAG)
  (DO ((LOC 0)
       (P *MCLAP-CODE* (CDR P)))
      ((NULL P)
       (FERROR NIL "~%tag not found ~s" TAG))
    (COND ((EQ TAG (CAR P))
	   (RETURN (+ LOC *MCLAP-BASE-LOC*)))
	  ((NOT (SYMBOLP (CAR P)))
	   (SETQ LOC (1+ LOC))))))

(DEFUN MCLAP-MICRO-MICRO-LINKAGE (FCTN NARGS)
  (SETQ *MCLAP-MM-LINKAGE-FLAG* (LIST FCTN NARGS))
  0)

(DEFUN MCLAP-EVALUATE-MC-LINKAGE (ADR)
  (COND	((EQ (CAR ADR) 'MISC-ENTRY)
	 (AR-1 (FUNCTION MICRO-CODE-SYMBOL-AREA)
	       (MISC-OPCODE->ARRAY-INDEX (GET (CADR ADR) 'QLVAL))))
	(T (FERROR NIL ""))))

(COMMENT 	 
     (COND ((NOT (= (%DATA-TYPE (SETQ TEM (CAR (FUNCTION-CELL-LOCATION (CADR ADR)))))
		    DTP-U-ENTRY))
	    (FERROR NIL "mc-entry-adr not DTP-U-ENTRY")))
     (AR-1 (FUNCTION MICRO-CODE-SYMBOL-AREA)
	   (AR-1 (FUNCTION MICRO-CODE-ENTRY-AREA)
		 (%POINTER TEM)))
)

(DEFUN MCLAP-LINKAGE-EVAL (REG)
  (LET ((ANS (CDR (ASSQ REG *MC-LINKAGE-ALIST*))))
    (COND ((NULL ANS)
	   (FORMAT T "~%MCLAP-LINKAGE ~s undefined" REG)
	   0)
	  (T (CADR ANS)))))

(DEFUN MCLAP-GET-QUOTE-INDEX (QUAN &OPTIONAL IGNORE)  ;for compatibility.  Flush soon.
  (PROG (TEM)
     L  (COND ((SETQ TEM (FIND-POSITION-IN-LIST-EQUAL QUAN *MCLAP-EXIT-VECTOR-TABLE*))
	       (RETURN (+ TEM *MCLAP-EXIT-VECTOR-OFFSET*))))
	(SETQ *MCLAP-EXIT-VECTOR-TABLE* (NCONC *MCLAP-EXIT-VECTOR-TABLE*
					 (LIST QUAN)))
	(GO L)))

;add a vector of frobs.  Used by DO-SPECBIND.
(DEFUN MCLAP-GET-QUOTE-INDEX-VECTOR (LIST-OF-QUANS)
  (LET ((VAL (+ (LENGTH *MCLAP-EXIT-VECTOR-TABLE*)
		*MCLAP-EXIT-VECTOR-OFFSET*)))
    (DOLIST (QUAN LIST-OF-QUANS)
      (SETQ *MCLAP-EXIT-VECTOR-TABLE* (NCONC *MCLAP-EXIT-VECTOR-TABLE*
					     (LIST QUAN))))
    VAL))

(DEFUN MCLAP-GET-A-CONSTANT (CON)
  (PROG (TEM)
       (COND ((SETQ TEM (FIND-POSITION-IN-LIST-EQUAL CON *A-CONSTANT-TABLE*))
	      (RETURN (+ TEM *A-CONSTANT-TABLE-INITIAL-FREE-POINTER*))))
    L  (COND ((SETQ TEM (FIND-POSITION-IN-LIST-EQUAL CON *MCLAP-A-CONSTANT-TABLE*))
	      (RETURN (+ TEM *MCLAP-A-CONSTANT-TABLE-OFFSET*))))
       (SETQ *MCLAP-A-CONSTANT-TABLE* (NCONC *MCLAP-A-CONSTANT-TABLE* (LIST CON)))
       (GO L)))

(DEFUN INTERN-THING (THING)
  (COND ((OR (NULL THING) (EQ THING T)) THING)
	((SYMBOLP THING) (INTERN-LOCAL (STRING THING)))
	((LISTP THING) (CONS (INTERN-THING (CAR THING))
			     (INTERN-THING (CDR THING))))
	(T THING)))


(DEFUN GET-UCADR-STATE-LIST (&optional re-read)
  (PKG-BIND "COMPILER"
    (OR (AND (null re-read)
	     *UCADR-STATE-LIST*
	     (EQ %MICROCODE-VERSION-NUMBER
		 (GET-FROM-ALTERNATING-LIST *UCADR-STATE-LIST* 'VERSION-NUMBER)))

	(AND (boundp 'lambda:current-ucode-image)
	     (EQ %MICROCODE-VERSION-NUMBER            ; check for an incremental assembly
		 (LAMBDA:UCODE-IMAGE-VERSION LAMBDA:CURRENT-UCODE-IMAGE))
	     (LET ((DEFAULT-CONS-AREA WORKING-STORAGE-AREA))
	       (SETQ *UCADR-STATE-LIST*
		     (MAPCAR 'INTERN-THING (LAMBDA:UCODE-MODULE-ASSEMBLER-STATE
					     (CAR (LAMBDA:UCODE-IMAGE-MODULE-POINTS
						    LAMBDA:CURRENT-UCODE-IMAGE))))
		     *MC-LINKAGE-ALIST* (GET-FROM-ALTERNATING-LIST *UCADR-STATE-LIST*
								   'MC-LINKAGE-ALIST))))
	(LET* ((DEFAULT-CONS-AREA WORKING-STORAGE-AREA)
	       (FILENAME (FUNCALL (FS:PARSE-PATHNAME "SYS: UBIN; ULAMBDA")
				 ':NEW-TYPE-AND-VERSION "LMC-SYM" %MICROCODE-VERSION-NUMBER))
	       (*print-base* 8)
	       (*read-base* 8))
	  (WITH-OPEN-FILE (STREAM FILENAME '(:READ))
	    (PROG (ITEM ASSEMBLER-STATE)
	       COM0
		  (COND ((NOT (< (SETQ ITEM (READ STREAM)) 0))
			 (GO COM0)))
	       COM
		  (COND ((= ITEM -1) (GO FIN))
			((= ITEM -2) (GO FIN))	;ignore
			((= ITEM -4)
			 (SETQ ASSEMBLER-STATE (READ STREAM))
			 (GO FIN))
			(T (FERROR NIL "~O is not a valid block header" ITEM)))
	       FIN
		  (SETQ *UCADR-STATE-LIST* ASSEMBLER-STATE)
		  (RETURN T)))
	  (SETQ *MC-LINKAGE-ALIST* (GET-FROM-ALTERNATING-LIST *UCADR-STATE-LIST*
							      'MC-LINKAGE-ALIST))
	  T))))


;--- low level stuff ---

(DEFUN MA-INSTALL (FUNCTION-NAME ARG-INFO ARGLIST C-MEM-ADR
				 &AUX MICRO-CODE-ENTRY-INDEX MICRO-CODE-SYMBOL-INDEX)
  (SETQ MICRO-CODE-ENTRY-INDEX 
	(COND ((AND (FDEFINEDP FUNCTION-NAME)
		    (= (%DATA-TYPE (FDEFINITION FUNCTION-NAME)) DTP-U-ENTRY))
	       (%POINTER (FDEFINITION FUNCTION-NAME)))
	      (T	
		(ALLOCATE-MICRO-CODE-ENTRY-SLOT FUNCTION-NAME))))
  (LET ((PREV (AR-1 (FUNCTION SYSTEM:MICRO-CODE-ENTRY-AREA) MICRO-CODE-ENTRY-INDEX)))
    (COND ((AND PREV (NOT (FIXP PREV)))
	   (SI:FUNCTION-SPEC-PUTPROP FUNCTION-NAME PREV 'DEFINITION-BEFORE-MICROCODED))))
  (SETQ MICRO-CODE-SYMBOL-INDEX (GET-MICRO-CODE-SYMBOL-INDEX FUNCTION-NAME))
  ;; Store various data.  MICRO-CODE-ENTRY-NAME-AREA already stored in.
  (SETF (MICRO-CODE-ENTRY-ARGLIST-AREA MICRO-CODE-ENTRY-INDEX) ARGLIST)
  (SETF (MICRO-CODE-ENTRY-ARGS-INFO-AREA MICRO-CODE-ENTRY-INDEX) ARG-INFO)
  (SETF (MICRO-CODE-SYMBOL-AREA MICRO-CODE-SYMBOL-INDEX)
	C-MEM-ADR)
  (SETF (MICRO-CODE-ENTRY-AREA MICRO-CODE-ENTRY-INDEX) 
	MICRO-CODE-SYMBOL-INDEX)

  (setf (micro-code-entry-max-pdl-usage micro-code-entry-index)
	nil)
   ;; Move various free pointers past the words we have used.
  (advance-region-free-pointer-if-necessary MICRO-CODE-ENTRY-AREA MICRO-CODE-ENTRY-INDEX)
  (advance-region-free-pointer-if-necessary MICRO-CODE-ENTRY-NAME-AREA MICRO-CODE-ENTRY-INDEX)
  (advance-region-free-pointer-if-necessary MICRO-CODE-ENTRY-ARGLIST-AREA MICRO-CODE-ENTRY-INDEX)
  (advance-region-free-pointer-if-necessary MICRO-CODE-ENTRY-ARGS-INFO-AREA
					    MICRO-CODE-ENTRY-INDEX)

  (advance-region-free-pointer-if-necessary MICRO-CODE-ENTRY-MAX-PDL-USAGE
					    MICRO-CODE-ENTRY-INDEX)
  ;; Don't mark any of micro-code-symbol-area as used!
  ;; It is "free" as far as saving a LOD band is concerned;
  ;; the data comes from the MCR band.
;  (advance-region-free-pointer-if-necessary MICRO-CODE-SYMBOL-AREA MICRO-CODE-SYMBOL-INDEX)
  )

(DEFUN MA-UNINSTALL (FUNCTION-NAME)
  (LET ((PREV (SI:FUNCTION-SPEC-GET FUNCTION-NAME 'DEFINITION-BEFORE-MICROCODED))
    ;	(FB (FDEFINITION FUNCTION-NAME))
	)
    (COND (PREV
	   (FDEFINE FUNCTION-NAME PREV)
    (COMMENT				;***
	   (COND ((EQ (DATA-TYPE FB) 'DTP-U-ENTRY)
		   (SI:FUNCTION-SPEC-PUTPROP FUNCTION-NAME
			    (AR-1 (FUNCTION MICRO-CODE-ENTRY-AREA) (%POINTER FB))
			    'MICRO-CODE-SYMBOL-INDEX)
		   (AS-1 PREV (FUNCTION MICRO-CODE-ENTRY-AREA) (%POINTER FB)))
		  (T (FDEFINE FUNCTION-NAME PREV))) )
    (SI:FUNCTION-SPEC-REMPROP FUNCTION-NAME 'DEFINITION-BEFORE-MICROCODED)))))

(DEFUN GET-MICRO-CODE-SYMBOL-INDEX (FUNCTION-NAME)
  (COND ((CDR (ASSOC FUNCTION-NAME *MA-MICRO-CODE-SYMBOL-INDEX-ASSIGNMENTS*)))
	(T (PROG1 *MA-MICRO-CODE-SYMBOL-INDEX*
		  (PUSH (CONS FUNCTION-NAME
			      *MA-MICRO-CODE-SYMBOL-INDEX*)
			*MA-MICRO-CODE-SYMBOL-INDEX-ASSIGNMENTS*)
		  (SETQ *MA-MICRO-CODE-SYMBOL-INDEX*
			(1+ *MA-MICRO-CODE-SYMBOL-INDEX*))))))

;Allocate a MICRO-CODE-ENTRY-SLOT.  If not already a DTP-U-UENTRY, allocates one
; and moves current function cell contents there.  Note function can still be
; macro-compiled after this.  It just has an extra level of indirecting that allows
; a microcompiled definition to be snapped in by storing a fixnum index to
; MICRO-CODE-SYMBOL-AREA in the MICRO-CODE-ENTRY-AREA slot.
(DEFUN ALLOCATE-MICRO-CODE-ENTRY-SLOT (FUNCTION-NAME)
  (LET ((FC (COND ((FDEFINEDP FUNCTION-NAME) (FDEFINITION FUNCTION-NAME)))))
    (COND ((= (%DATA-TYPE FC) DTP-U-ENTRY)
	   (%POINTER FC))
	  (T
	   (LET ((ARGS-INFO (COND (FC (ARGS-INFO FC))))  ;DO THIS FIRST SO AS NOT TO GET
		 (ARGLIST (COND (FC (ARGLIST FC)))))     ; THINGS OUT OF PHASE IF ERROR.
	     (LET ((IDX (ARRAY-PUSH (FUNCTION SYSTEM:MICRO-CODE-ENTRY-NAME-AREA)
				    FUNCTION-NAME)))
	       (COND ((NULL IDX)
		      (FERROR NIL "MICRO-CODE-ENTRY-ARRAYS FULL"))
		     (T (ARRAY-PUSH (FUNCTION SYSTEM:MICRO-CODE-ENTRY-AREA) FC)
			(ARRAY-PUSH (FUNCTION SYSTEM:MICRO-CODE-ENTRY-ARGS-INFO-AREA)
				    ARGS-INFO)
			(ARRAY-PUSH (FUNCTION SYSTEM:MICRO-CODE-ENTRY-ARGLIST-AREA)
				    ARGLIST)
			;; Move various free pointers past the words we have used.
			(advance-region-free-pointer-if-necessary
			  SYS:MICRO-CODE-ENTRY-NAME-AREA IDX)
			(advance-region-free-pointer-if-necessary
			  SYS:MICRO-CODE-ENTRY-AREA IDX)
			(advance-region-free-pointer-if-necessary
			  SYS:MICRO-CODE-ENTRY-ARGLIST-AREA IDX)
			(advance-region-free-pointer-if-necessary
			  SYS:MICRO-CODE-ENTRY-ARGS-INFO-AREA IDX)
			(SETQ NUMBER-MICRO-ENTRIES
			      (SETQ SYSTEM:%NUMBER-OF-MICRO-ENTRIES (1+ IDX)))
			(AS-1 NUMBER-MICRO-ENTRIES
			      (FUNCTION SYS:SCRATCH-PAD-INIT-AREA)
			      31)	;A-AMCENT reloads from here on boot.
		        (FDEFINE FUNCTION-NAME (%MAKE-POINTER DTP-U-ENTRY IDX))
			IDX))))))))

(DEFUN MA-RESET-MICRO-CODE-ENTRY-ARRAYS (N)
       (MA-RESET)
       (STORE-ARRAY-LEADER N (FUNCTION SYSTEM:MICRO-CODE-ENTRY-NAME-AREA) 0)
       (STORE-ARRAY-LEADER N (FUNCTION SYSTEM:MICRO-CODE-ENTRY-AREA) 0)
       (STORE-ARRAY-LEADER N (FUNCTION SYSTEM:MICRO-CODE-ENTRY-ARGS-INFO-AREA) 0)
       (STORE-ARRAY-LEADER N (FUNCTION SYSTEM:MICRO-CODE-ENTRY-ARGLIST-AREA) 0)
       (SETQ NUMBER-MICRO-ENTRIES
	     (SETQ SYSTEM:%NUMBER-OF-MICRO-ENTRIES (1+ N)))
       (AS-1 NUMBER-MICRO-ENTRIES
	     (FUNCTION SYS:SCRATCH-PAD-INIT-AREA)
	     31)
       (SETQ SI:%MC-CODE-EXIT-VECTOR (+ (%POINTER *MC-EXIT-VECTOR-ARRAY*)
					1
					(%P-LDB-OFFSET %%ARRAY-LONG-LENGTH-FLAG
						       *MC-EXIT-VECTOR-ARRAY*
						       0)))
       N)

(defun read-exit-vector (n)
  (aref (%find-structure-header (%make-pointer dtp-locative si:%mc-code-exit-vector)) n))

(DEFUN MA-REBOOT NIL	;should not be neccessary now that SCRATCH-PAD-INIT-AREA hacked
			;--mumble-- called by MA-RESET.
  (IF (NUMBERP NUMBER-MICRO-ENTRIES)
      (SETQ SYSTEM:%NUMBER-OF-MICRO-ENTRIES NUMBER-MICRO-ENTRIES))
  (IF *MC-EXIT-VECTOR-ARRAY*
      (SETQ SI:%MC-CODE-EXIT-VECTOR (+ (%POINTER *MC-EXIT-VECTOR-ARRAY*)
				       1
				       (%P-LDB-OFFSET %%ARRAY-LONG-LENGTH-FLAG
						      *MC-EXIT-VECTOR-ARRAY*
						      0)))))

(defun advance-region-free-pointer-if-necessary (region rel-adr)
  "Move up a region's free pointer, if necessary, so that relative location REL-ADR is not free."
  (without-interrupts
    (cond ((> rel-adr (si:%region-free-pointer region))
	   (setf (si:%region-free-pointer region) rel-adr)))))

(DEFUN MA-LOAD-C-MEM (ADR I)
  (setq i (lambda:compute-parity-64 i))
  (cond ((null *ma-micro-paging-mode*)
	 (SI:%WRITE-INTERNAL-PROCESSOR-MEMORIES 1 ADR
						(LAMBDA:LDB-BIG 4040 I)
						(LAMBDA:LDB-BIG 0040 I)))
	(t (advance-region-free-pointer-if-necessary sys:micro-code-paging-area (* 2 adr))
	   (let ((q-adr (+ (si:%region-origin sys:micro-code-paging-area)
			   (* adr 2))))
	     (%p-dpb-offset (ldb 0020 i) 0020 0 q-adr)
	     (%p-dpb-offset (ldb 2020 i) 2020 0 q-adr)
	     (%p-dpb-offset (ldb 4020 i) 0020 0 (1+ q-adr))
	     (%p-dpb-offset (ldb 6020 i) 2020 0 (1+ q-adr))))
    ))

(DEFUN MA-LOAD-A-MEM (ADR A)
  (SI:%WRITE-INTERNAL-PROCESSOR-MEMORIES 4 ADR    ;A/M
    (%LOGDPB (LDB 4020 A) 1020 (LDB 3010 A))
    (%LOGDPB (LDB 1020 A) 1020 (LDB 0010 A))))

(DEFUN MA-INITIALIZE-EXIT-VECTOR ()
  (COND ((NULL *MC-EXIT-VECTOR-ARRAY*)
	 (SETQ *MC-EXIT-VECTOR-ARRAY*
	       (MAKE-ARRAY 1000
			   ':TYPE 'ART-Q-LIST
			   ':AREA SYSTEM:control-tables
			   ':LEADER-LIST '(0))))
	(T (STORE-ARRAY-LEADER 0 *MC-EXIT-VECTOR-ARRAY* 0)))
  (SETQ SI:%MC-CODE-EXIT-VECTOR (+ (%POINTER *MC-EXIT-VECTOR-ARRAY*)
				   1
				   (%P-LDB-OFFSET %%ARRAY-LONG-LENGTH-FLAG
						  *MC-EXIT-VECTOR-ARRAY*
						  0))))

(DEFUN MA-LOAD-EXIT-VECTOR-Q (EV &AUX DTP PTR) 
  (COND ((EQ (CAR EV) 'QUOTE)
	 (SETQ DTP (%DATA-TYPE (CADR EV))
	       PTR (%POINTER (CADR EV))))
	((EQ (CAR EV) 'SPECIAL)
	 (SETQ DTP DTP-EXTERNAL-VALUE-CELL-POINTER
	       PTR (1+ (%POINTER (CADR EV)))))
	((EQ (CAR EV) 'FUNCTION)
	 (SETQ DTP DTP-EXTERNAL-VALUE-CELL-POINTER
	       PTR (+ 2 (%POINTER (CADR EV))))))
  (ARRAY-PUSH *MC-EXIT-VECTOR-ARRAY* (%MAKE-POINTER DTP PTR)))


(DEFUN MA-INITIALIZE-VARIABLES NIL
  (LET ((A-RANGE (GET-FROM-ALTERNATING-LIST *UCADR-STATE-LIST*
					    'A-MEMORY-RANGE-LIST))
	(I-RANGE (GET-FROM-ALTERNATING-LIST *UCADR-STATE-LIST*
					    'I-MEMORY-RANGE-LIST)))
    (SETQ *A-CONSTANT-TABLE-INITIAL-FREE-POINTER*
	  (SETQ *A-CONSTANT-TABLE-FREE-POINTER* 2300
		      ;(+ (CAR (CAR A-RANGE)) (CADR (CAR A-RANGE)))
		))
    (SETQ *A-CONSTANT-TABLE* NIL)
    (SETQ *C-MEM-LOC* (if *ma-micro-paging-mode* 60000  ;start above prom in paging mode.
			(+ (CAR (CAR I-RANGE))
			   (CADR (CAR I-RANGE)))))
    (SETQ *C-MEM-LOC-LIMIT* (IF *MA-MICRO-PAGING-MODE* 177777 36000))))


(DEFUN WRITE-INITIALLY-MICROCOMPILED-FILE NIL
  (MA-WRITE-MCLAP-PROPS "SYS: SYS; UCINIT QFASL >"
			*INITIALLY-MICROCOMPILED-FUNCTIONS*
			`(SETQ *INITIALLY-MICROCOMPILED-FUNCTIONS*
			       ',*INITIALLY-MICROCOMPILED-FUNCTIONS*)))

(DEFUN MA-WRITE-MCLAP-PROPS (FILENAME LIST-OF-FCTNS &OPTIONAL EXP &AUX LOSEP)
  (DOLIST (FUNCTION-NAME LIST-OF-FCTNS)
    (COND ((NULL (SI:FUNCTION-SPEC-GET FUNCTION-NAME 'MCLAP))
	   (FORMAT T "~%~s has no MCLAP property" FUNCTION-NAME)
	   (SETQ LOSEP T))))
  (COND ((OR (NULL LOSEP)
	     (Y-OR-N-P "Do you want to proceed anyway?"))
	 (LOCKING-RESOURCES
	   (SETQ FILENAME (FS:MERGE-PATHNAME-DEFAULTS FILENAME FS:LOAD-PATHNAME-DEFAULTS
						      "QFASL"))
	   (FASD-INITIALIZE)
	   (WITH-OPEN-FILE (FASD-STREAM FILENAME '(:WRITE :FIXNUM))
	     (DOLIST (FUNCTION-NAME LIST-OF-FCTNS)
	       (FASD-FORM `(MA-INSTALL-MCLAP ,FUNCTION-NAME
					     ,(SI:FUNCTION-SPEC-GET FUNCTION-NAME 'MCLAP))))
	     (IF EXP (FASD-FORM EXP))
	     (FASD-END-WHACK)
	     (FASD-END-FILE))))))

;Managing microcode entries and stuff:
;  All actual microcode entry address are stored in MICRO-CODE-SYMBOL-AREA.
;This area is 1000 locations long.  The first 600 are accessible via
;misc macroinstruction (values 200-777).  MICRO-CODE-SYMBOL-NAME-AREA corresponds
;with MICRO-CODE-SYMBOL-AREA Q for Q and gives the NAME for debugging.
;  How DTP-U-ENTRY works:  DTP-U-ENTRY is sort of an indirect pointer relative
;to the origin of MICRO-CODE-ENTRY-AREA.  The Q referenced is to be interpreted
;in functional context in the normal fashion, with one exception: If the
;data type is DTP-FIX,  this is a "real" ucode entry.
;In that case, MICRO-CODE-ENTRY-NAME-AREA, MICRO-CODE-ENTRY-ARGS-INFO-AREA,
;MICRO-CODE-ENTRY-MAX-PDL-USAGE, and MICRO-CODE-ENTRY-ARGLIST-AREA (at the same index)
;give data about this entry.  The DTP-FIX in MICRO-CODE-ENTRY-AREA is an index
;to MICRO-CODE-SYMBOL-AREA which in turn contains the actual control memory
;starting address.  The reason for the indirecting step from MICRO-CODE-ENTRY-AREA
;to MICRO-CODE-SYMBOL-AREA is to separate the world into two independant pieces.
;(The microcode and MICRO-CODE-SYMBOL-AREA separate from the rest of the load).

;  Making new microcoded functions.  Two "degrees of commitment" are available,
;ie, the newly added function can be made available as a misc instruction or not.
;If a misc instruction, the system becomes completely committed
;to this function remaining microcoded forever.  If not, it is possible in the future to
;decommit this function from microcode, reinstating the macrocoded definition.

;  Decommiting can be done either by restoring the DTP-FEF-POINTER to the function cell,
;or by putting it in the MICRO-CODE-ENTRY-AREA position.  This latter option allows
;the microcoded definition to be quickly reinstalled.  
;  One problem with decomitting concerns activation-records for the microcoded
;which may be lying around on various stack-groups.  If later, an attempt is made
;to return through these, randomness will occur.  To avoid this, on a 
;macro-to-micro return, the microcode can check that the function being returnned
;to is still in fact microcoded.

;MICRO-CODE-SYMBOL-AREA is divided in two sections.  0-577 are ref'ed by
;MISC instructions 200-777, and may also be ref'ed by DTP-U-ENTRY's as described above.
;600-777 are entries to microcompiled functions.   (The old MICRO-CODE-SYMBOL-VECTOR
;which used these has been flushed.)



(defun ma-describe-cmem ()
  (dolist (f *mclap-loaded-functions*)
    (let ((info (si:function-spec-get f 'mclap-loaded-info)))
      (format t "~&~7o (~:*~7d.) ~s" (car info) f))))

(defun print-symbolic-micro-address (stream address)
  (cond ((or (null *ma-micro-paging-mode*)
	     (and (< address 60000) (not (fboundp 'lam:lam-find-closest-sym))))
	 (format stream "~s" address))
	((< address 60000)
	 ;;below base of micro-compiled stuff
	 (pkg-bind "LAMBDA"
	   (format stream "~s" (lam:lam-find-closest-sym (+ lam:racmo address)))))
	(t
	 (dolist (f *mclap-loaded-functions*
		    (format stream "~s" address))
	   (let ((info (si:function-spec-get f 'mclap-loaded-info)))
	     (cond ((= address (car info))
		    (format stream "~s" f)
		    (return nil))
		   ((>= address (car info))
		    (format stream "(~s ~s)" f (- address (car info)))
		    (return nil))))))))

(defun show-micro-stack (stream sg)
  (format stream "~&Micro-stack: ")
  (dolist (adr (cddddr (symeval-in-stack-group 'eh:ucode-error-status sg)))
    (print-symbolic-micro-address stream adr)
    (format stream " -> "))
  (print-symbolic-micro-address stream (si:sg-trap-micro-pc sg)))

;;; Some functions to make it easy for the user to define micro compiled
;;; functions and misc instructions. 1/04/85 18:19:38 -George Carrette.

(defmacro define-micro-properties (symbol arglist &rest properties)
  "Examples:
;; A function we simply want to microcompile:
/(define-micro-properties some-function (a b))
;; A function to microcompile and also enable micro->micro calls
;; with stack-level checking
/(define-micro-properties some-function (a b)
  :micro->micro :dynamic) ;; value of :micro->micro would be T for no stack checking.
;; A function to microcompile and define as a MISC instruction,
/(define-micro-properties some-lowlevel-function (a b)
  :opcode #o1777)
"
  `(eval-when (eval compile load)
     (*define-micro-properties '(,symbol :arglist ,arglist ,@properties))))

(defprop serror t :error-reporter)

(defun serror (string &rest l)
  (lexpr-funcall #'cerror :yes nil nil string l))

(defvar *micro-properties-symbols* nil "list of symbols defined by DEFINE-MICRO-PROPERTIES")

(defvar *least-user-misc-opcode* #o1700 "fairly arbitrary safety check for in-the-mean-time")

(defun legal-misc-opcode (code)
  (and (fixp code)
       (<= *least-misc-opcode* code *greatest-misc-opcode*)))

(defun legal-user-misc-opcode (code)
  (and (fixp code)
       (<= *least-user-misc-opcode* code *greatest-misc-opcode*)))


;; properly DEFMIC should put a source-file-name on things which have been defmic'd.

(defun *define-micro-properties (plist &aux (symbol (car plist)))
  (record-source-file-name symbol 'def-micro-properties)
  (setq *micro-properties-symbols* (adjoin (car plist) *micro-properties-symbols*))
  (putprop symbol plist 'micro-properties)
  (putprop symbol t 'microcompile)
  (do ((l (cdr plist) (cddr l))(bad-boys)
       (old-opcode)(new-opcode)(old-name)(pkg))
      ((null l))
    (selectq (car l)
      (:opcode
       (or (null (setq bad-boys (intersection (get plist :arglist) lambda-list-keywords)))
	   (ferror nil "~S is being defined with :OPCODE but has ~{~S~^, ~} in argument list"
		   symbol bad-boys))
       (setq old-opcode (get symbol 'qlval))
       (setq new-opcode (cadr l))
       (check-arg new-opcode
		  legal-misc-opcode
		  "a valid misc instruction opcode")
       (setq pkg (symbol-package symbol))
       (if (not (or (eq pkg (find-package "GLOBAL"))
		    (memq pkg (package-used-by-list "SYSTEM"))))
	   (check-arg new-opcode legal-user-misc-opcode "safe misc instruction opcode to use"))
       (if (and old-opcode (not (= old-opcode new-opcode)))
	   (serror "Changing OPCODE of ~S from #o~O to #o~O, be careful!"
		   symbol old-opcode new-opcode))
       (setq old-name (aref #'micro-code-symbol-name-area (misc-opcode->array-index new-opcode)))
       (cond ((and old-name (not (eq old-name symbol)))
	      (serror "OPCODE #o~o is defined as ~S being redefined as ~S"
		      new-opcode old-name symbol)))
       (do ((l *micro-properties-symbols* (cdr l)))
	   ((null l))
	 (setq old-opcode (get (get (car l) 'micro-properties) :opcode))
	 (cond ((and old-opcode (= old-opcode new-opcode) (not (eq (car l) symbol)))
		(serror "OPCODE #o~o defined by DEFINE-MICRO-PROPERTIES was named:~
                         ~%~S being redefined as ~S" new-opcode (car l) symbol))))
       (eval `(defmic ,symbol ,(cadr l) ,(get plist :arglist) nil)))
      (:micro->micro
       (putprop symbol (cadr l) :depend-on-being-microcompiled))
      (:arglist)
      (t
       (serror "unknown def-micro-property key: ~S" (car l))))))

(defvar *mid-ram-banks* '((:regular  0)
			  (:unused-1 1)
			  (:unused-2 2)
			  (:misc     3)))

(defun hack-macro-instruction-decode-ram (bank index value-to-write)
  (check-arg index
	     (and (fixp index) (<= 0 index #o1777))
	     "A ten-bit-wide integer")
  (check-arg bank (assq bank *mid-ram-banks*) "A macro instruction decode ram bank name")
  (let ((address (+ index (lsh (cadr (assq bank *mid-ram-banks*)) 10.))))
    (cond (value-to-write
	   (%write-internal-processor-memories 5 address 0 value-to-write))
	  ('else
	   (%write-internal-processor-memories 6 address 0 0)))))

(defun read-macro-instruction-decode-ram (bank index)
  (hack-macro-instruction-decode-ram bank index nil))

(defun write-macro-instruction-decode-ram (bank index value)
  (check-arg value (and (fixp value) (<= 0 value #o177777))
	     "A valid micro-program position counter")
  (hack-macro-instruction-decode-ram bank index value))

(defun describe-misc-map ()
  (format t "~%Table of Active Misc Instructions~
            ~% Legend: + is system, * is user, ? is NIL symbol, - is TRAP, = is ILLOP~%")
  (do ((j *least-misc-opcode* (1+ j))
       (syspkgs (list (pkg-find-package "SYSTEM") (pkg-find-package "GLOBAL")))
       (pc-array #'micro-code-symbol-area)
       (name-array #'micro-code-symbol-name-area)
       (c)(pc)(name))
      ((> j *greatest-misc-opcode*))
    (if (zerop (remainder j #o100))
	(format t "~%~4o: " j))
    (setq pc (aref pc-array (misc-opcode->array-index j)))
    (setq name (aref name-array (misc-opcode->array-index j)))
    (cond ((= pc 4)
	   (setq c #/=))
	  ((= pc #o127)
	   (setq c #/-) )
	  ((null name)
	   (setq c #/?))
	  ((memq (symbol-package name) syspkgs)
	   (setq c #/+))
	  ('else
	   (setq c #/*)))
    (send standard-output :tyo c)))


(defun describe-mid-ram-map ()
  (format t "~%Macro Instruction Decode Ram~%Legend: + useful, - is TRAP, = is ILLOP, @ is ZERO.")
  (dolist (bank *mid-ram-banks*)
    (format t "~%~S instructions:" (car bank))
    (do ((j 0 (1+ j))
	 (pc)
	 (c))
	((= j #o2000))
      (if (zerop (remainder j #o100))
	  (format t "~%~4o: " j))
      (setq pc (read-macro-instruction-decode-ram (car bank) j))
      (cond ((= pc 4)
	     (setq c #/=))
	    ((= pc #o127)
	     (setq c #/-))
	    ((= pc 0)
	     (setq c #/@))
	    ('else
	     (setq c #/+)))
      (send standard-output :tyo c))))

(defun enable-micro-misc (function-name &aux opcode info pc-array name-array index)
  (cond ((not (memq function-name *micro-properties-symbols*))
	 (ferror NIL "~S not defined with DEFINE-MICRO-PROPERTIES" function-name))
	((null (setq opcode (get function-name 'qlval)))
	 (ferror nil
		 "No :OPCODE for ~S, check DEFINE-MICRO-PROPERTIES" function-name))
	((OR (NULL (setq info (SI:FUNCTION-SPEC-GET function-name 'MCLAP-LOADED-INFO)))
	     (NOT (MEMBER FUNCTION-NAME *MCLAP-LOADED-FUNCTIONS*)))
	 (ferror nil "~S has not been loaded into the microstore yet" function-name))
	('else
	 (setq pc-array #'micro-code-symbol-area)
	 (setq name-array #'micro-code-symbol-name-area)
	 (setq index (misc-opcode->array-index opcode))
	 (aset (first info) pc-array index)
	 (enable-mid-ram opcode (first info))
	 (let ((sys:%inhibit-read-only t))
	   (aset function-name name-array index))
	 info)))

(defun enable-micro-%misc (instruction-name)
  "This is for enabling a hand-coded %MISC instruction that was installed after the cold load"
  (lambda:assure-lam-symbols-loaded)
  (let ((cname (intern (format nil "%~A" instruction-name) "COMPILER"))
	(sname (intern (format nil "X~A" instruction-name) "LAM")))
    (let ((opcode (or (get cname 'qlval) (ferror nil "No opcode for ~S" cname)))
	  (pc (- (or (lam:lam-lookup-name sname) (ferror nil "No ucode pc for ~S in loaded LAM symbols" sname))
		 lam:racmo)))
      (let ((pc-array #'micro-code-symbol-area)
	    (name-array #'micro-code-symbol-name-area)
	    (index (misc-opcode->array-index opcode)))
	(aset pc pc-array index)
	(enable-mid-ram opcode pc)
	(let ((sys:%inhibit-read-only t))
	  (aset cname name-array index))
	instruction-name))))

(defun enable-mid-ram (opcode uc-pc) 
  (write-macro-instruction-decode-ram ':misc opcode uc-pc))

(defun enable-micro-misc-all ()
  (mapcar #'enable-micro-misc *micro-properties-symbols*))


(add-initialization "Setup for micro-paging"
		    '(set-micro-paging :if-already-on)
		    '(system))
(add-initialization "Setup for micro-paging"
		    '(set-micro-paging :if-already-on)
		    '(warm))