;-*- Mode:LISP; Base:8 -*-
;;; (C) Copyright 1983,1984,1985, Mats Carlsson, UPMAIL.

;;; Version for Lambda (release 2.1 or newer) and Explorer.

;;; Microcode for LM-Prolog.
;;; Potentially dangerous POPJs are marked with ***,
;;; since they could start a macro insn cycle.  However, the corresponding MISCs
;;; are pretty useless with D-IGNORE.

;;; Wired in assumptions on storage conventions:
;;; >> Fill-pointers are at offset -2 from the array pointer.
;;; >> Flavor instances look like <header word, instance vas...>

;;; Not using "carcdr-direct", since the calling conventions are slightly awkward.

(defconst uc-prolog '(  
#+lambda (begin-pagable-ucode)
  (mc-linkage (;;the following are needed for A mem communication.
               a-unify-dispatch
	       a-lmp-vector
	       a-lmp-trail
	       a-lmp-area
	       a-lmp-mode
	       ;;the following are needed because of LAST-ARG-IN-T properties 
	       lmp-cell
	       lmp-reference
	       lmp-dereference
	       lmp-updl
	       lmp-centry
	       #-lexical lmp-invoke
	       ;;the following are needed for our unify-dispatch-table
	       lmp-pop-fail
	       lmpu-x-x
	       lmpu-instance-x
	       lmpu-x-instance
	       lmpu-var-x
	       lmpu-x-var
	       lmpu-var-var
	       lmpu-var-list
	       lmpu-list-var
	       lmpu-list-list
	       ))

;;Exit vector offsets.
    (assign lmpoff-unify 765)
    (assign lmpoff-occurs-in 766)
    (assign lmpoff-unify-term-with-template 767)
    (assign lmpoff-construct 770)
    (assign lmpoff-unify-term-with-term 771)
    (assign lmpoff-array-push-extend 772)
    (assign lmpoff-read-only-variable-flavor 773)
    (assign lmpoff-true 774)
    (assign lmpoff-false 775)
    (assign lmpoff-find-and-cache 776)
    (assign lmpoff-universe 777)

        (locality d-mem)
;;Tail-recursive calls.
        (start-dispatch 0 0)
d-lmp-mmjcall
	(mmjcall inhibit-xct-next-bit)		;tail recursive call
        (end-dispatch)

;;%UNIFY-TERM-WITH-TEMPLATE
        (start-dispatch 3 0)			;PPSS 2503: what kind of occurrence.
d-lmp-unify
        (lmp-put-frame inhibit-xct-next-bit)	;first occurrence
        (lmp-updl)				;subsequent occurrence
	(lmp-pop-succeed inhibit-xct-next-bit)	;void occurrence
	(illop inhibit-xct-next-bit)
        (lmp-ro-unify-1 inhibit-xct-next-bit)	; read-only first occurrence
        (lmp-ro-unify-2)			; read-only subsequent occurrence
	(lmp-ro-uvoid inhibit-xct-next-bit)	; read-only void occurrence
	(illop inhibit-xct-next-bit)
        (end-dispatch)

;;%CONSTRUCT
        (start-dispatch 3 0)			;PPSS 2503: what kind of occurrence.
d-lmp-construct
        (lmp-put-cell-frame) 				;first occurrence
        (lmp-get-frame inhibit-xct-next-bit)      	;subsequent occurrence
	(lmp-cell inhibit-xct-next-bit)			;void occurrence
	(illop inhibit-xct-next-bit)
        (lmp-ro-construct-1) 				; read-only first occurrence
        (lmp-ro-construct-2 inhibit-xct-next-bit) 	; read-only subsequent occurrence
	(lmp-ro-construct-void inhibit-xct-next-bit) 	; read-only void occurrence
	(illop inhibit-xct-next-bit)
        (end-dispatch)

;;First occurrences.
        (start-dispatch 2 0)			;PPSS 2302: base reg ;PPSS 0023: offset
d-lmp-put-frame
        (lmp-put-vector)			;interpreter's vector
        (qstarg)	;argument block
        (qstloc)	;local block
        (#-lexical illop #+lexical lmp-xstore)	;higher context.
        (end-dispatch)

;;Subsequent occurrences.
        (start-dispatch 2 0)			;PPSS 2302: base reg ;PPSS 0023: offset
d-lmp-get-frame
        (lmp-get-vector)			;interpreter's vector
        (qadarg1)	;argument block
        (qadloc1)	;local block
        (#-lexical illop #+lexical lmp-xload)	;higher context.
        (end-dispatch)

;;Special va:s in A-MEM.
	(locality a-mem)
;a-unify-dispatch (0)		;moved to UC-PARAMETERS, following A-FLOATING-ZERO.
;a-lmp-vector (0)
;a-lmp-trail (0)
a-lmp-area (0)
a-lmp-mode (0)

;;And now for the actual code.
        (locality i-mem)

	 (misc-inst-entry occurs-in)
  	 ((m-a) q-typed-pointer pdl-pop)
	 ((m-k) q-typed-pointer pdl-pop)

lmp-occurs-in
         (jump-data-type-not-equal m-a (a-constant (byte-value q-data-type dtp-list))
				       lmp-occurs-in-atom)

lmp-occurs-in-list
	(call-xct-next lmp-carcdr)
       ((m-t) m-a)
        (jump-data-type-not-equal-xct-next m-a (a-constant (byte-value q-data-type dtp-list))
					       lmp-occurs-in-simple-recurse)
	((pdl-push) m-t)
#+lambda (jump-greater-than micro-stack-pntr-and-data (a-constant 20._24.)
			    lmp-occurs-in-slow-recurse)	;Ustack filling up?
#+exp	 (jump-greater-than micro-stack-pntr (a-constant 10.)
			    lmp-occurs-in-slow-recurse)
	 (jump-xct-next lmp-occurs-in-join)	;No, proceed. (Should check stack frame too.)
	(call lmp-occurs-in-list)

lmp-occurs-in-atom
	 ((m-t) a-v-nil)
	 (popj-after-next popj-not-equal m-k a-a)
	((m-t) a-v-true)

lmp-occurs-in-simple-recurse
	 (call lmp-occurs-in-atom)

lmp-occurs-in-join				;Here with key in K and term on stack
	 ((m-a) q-typed-pointer pdl-pop)
	 (popj-not-equal m-t a-v-nil)
	 (jump lmp-occurs-in)

lmp-occurs-in-slow-recurse
	 ((pdl-push) m-k)
	 (dispatch-call (i-arg lmpoff-occurs-in) d-call-exit-vector i-dont-chain)
	 ((pdl-push) q-typed-pointer m-k (a-constant (byte-value q-cdr-code cdr-next)))
	 ((pdl-push) q-typed-pointer m-a (a-constant (byte-value q-cdr-code cdr-nil)))
	 (dispatch-call (i-arg 2) d-mmcall i-dont-chain)
	 (jump-xct-next lmp-occurs-in-join)
	((m-k) q-typed-pointer pdl-pop)

	(misc-inst-entry %reference)
        ((m-t) q-typed-pointer pdl-pop)

lmp-reference					;Inviz. T if it is a variable.
       (popj-after-next
	 popj-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-locative)))
       ((m-t) q-pointer m-t
	(a-constant (byte-value q-data-type dtp-external-value-cell-pointer)))

	(misc-inst-entry %dereference)
        ((m-t) q-typed-pointer pdl-pop)

lmp-dereference					;Read T if it is a variable.
        (popj-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-locative)))
	((vma-start-read) m-t)
	(check-page-read)
	(popj-after-next dispatch transport md)
       ((m-t) q-typed-pointer md)

(begin-comment) (end-comment)

lmp-cell
	(jump-not-equal m-t a-v-nil lmp-cell-named)
	(misc-inst-entry %cell0)		;Make an unnamed value cell.

lmp-cell0
        ((m-b) (a-constant 1))			;Cons 1 word
        (call-xct-next allocate-list-storage)
       ((m-s) a-lmp-area)			;in *PROLOG-WORK-AREA*
        ((m-t vma) q-pointer m-t (a-constant (byte-value q-data-type dtp-locative)))
        ((md-start-write)
         q-typed-pointer m-t (a-constant (byte-value q-cdr-code cdr-nil)))
        (check-page-write)			;Store a self-reference.
        (popj-after-next)
       (gc-write-test)

lmp-cell-named
	((pdl-push) m-t)
	(misc-inst-entry %cell)			;Make a named value cell.
        ((m-b) (a-constant 2))			;Cons 2 words
        (call-xct-next allocate-list-storage)
       ((m-s) a-lmp-area)			;in *PROLOG-WORK-AREA*
        ((m-t vma) q-pointer m-t (a-constant (byte-value q-data-type dtp-locative)))
        ((md-start-write) q-typed-pointer m-t (a-constant (byte-value q-cdr-code cdr-normal)))
        (check-page-write)			;Store a self-reference.
        (gc-write-test)
        ((vma) m+1 vma)
        ((md-start-write)
	  q-typed-pointer pdl-pop (a-constant (byte-value q-cdr-code cdr-error)))
        (check-page-write)			;Store the name.
        (popj-after-next)
       (gc-write-test)

lmp-list
	((m-b) m-r)				;Cons R words
        ((m-s) a-lmp-area)			;in *PROLOG-WORK-AREA*
        (jump-xct-next xlist0)
       (call allocate-list-storage)

lmp-list*
	((m-b) m-r)				;Cons R words
        ((m-s) a-lmp-area)			;in *PROLOG-WORK-AREA*
        (jump-xct-next xlistr0)
       (call allocate-list-storage)

        (misc-inst-entry %unify-term-with-template)

lmp-utemplate					;Here with template in K.
        ((m-k) q-typed-pointer pdl-pop)
        (call-data-type-equal-xct-next pdl-top (a-constant (byte-value q-data-type dtp-locative))
				       qcar3)
       ((m-t) q-typed-pointer pdl-pop)
	((pdl-push) m-t)

lmp-utemplate-nd				;Here if we don't need to dereference.
	(jump-equal m-k a-v-nil lmp-unil)
        (jump-data-type-equal m-k (a-constant (byte-value q-data-type dtp-list))
				  lmp-uconstruct)
        (jump-data-type-equal m-k (a-constant (byte-value q-data-type dtp-locative))
				  lmp-uconstant)
        (call-data-type-equal-xct-next m-k (a-constant (byte-value q-data-type dtp-symbol))
					   lmp-symeval-a)
       ((m-a) m-k)
	(dispatch (byte-field 3 25) m-a d-lmp-unify)	;XCT-NEXT only if subsequent occ.
       (call lmp-get-frame-d)

lmp-uconstant
;Possible bum:
;       (jump-xct-next lmp-updl)
;      (open-qcar m-k)
	((m-t) m-k)
	(jump-xct-next lmp-updl)
       (call qcar3)

lmp-symeval-a
	((vma-start-read) m+1 m-a)
	(check-page-read)
	(dispatch transport md)
        (popj-after-next (m-t) m-a)
       ((m-a) q-typed-pointer md)

lmp-uconstruct					;X & construct
        ((m-t) m-k)
        (jump-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-list))
				  lmp-uconstruct-1)
	(call lmp-carcdr)			;List & construct.
        ((m-k) m-a)				;Recurse, pushing cdrs.
        ((m-c) m-t)
	(call-xct-next lmp-carcdr)
       ((m-t) q-typed-pointer pdl-pop)
        ((pdl-push) m-t)
        ((pdl-push) m-c)
        (jump-equal-xct-next m-k a-v-nil lmp-unil-then-join)
       ((pdl-push) m-a)
#+lambda (call-greater-than micro-stack-pntr-and-data (a-constant 20._24.)	;(Should check frame too.)
			    lmp-utemplate-slow-recurse)
#+lambda (call-less-or-equal micro-stack-pntr-and-data (a-constant 20._24.) lmp-utemplate-nd)
#+exp	 (call-greater-than micro-stack-pntr (a-constant 10.) lmp-utemplate-slow-recurse)
#+exp	 (call-less-or-equal micro-stack-pntr (a-constant 10.) lmp-utemplate-nd)
lmp-uconstruct-join
	(jump-not-equal m-t a-v-nil lmp-utemplate)
        ;drop thru and fail otherwise

lmp-pop2-fail					;Pop two and fail.
	(popj-after-next (m-t) seta pdl-pop a-v-nil)
       (pdl-pop)

lmp-utemplate-slow-recurse			;MMcall %unify-term-with-template.
        (dispatch-call PDL-POP (i-arg lmpoff-unify-term-with-template) d-call-exit-vector i-dont-chain)
        ((pdl-push) q-typed-pointer m-a (a-constant (byte-value q-cdr-code cdr-next)))
        ((pdl-push) q-typed-pointer m-k (a-constant (byte-value q-cdr-code cdr-nil)))
        (dispatch (i-arg 2) d-lmp-mmjcall i-dont-chain)

lmp-uconstruct-1				;Atom & construct.
        (jump-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-locative))
				  lmp-uconstruct-2)
	;Variable & complex term.  Construct it and bind.
        (call lmp-construct-t)
	(jump-xct-next lmpu-var-list)
       ((m-i) a-lmp-mode)

lmp-uconstruct-2
        (jump-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-instance))
				  lmp-pop-fail)
	;Instance & complex term.  Construct it and send :unify msg.
        (jump-xct-next lmpu-instance-x)
       (call lmp-construct-t)

	(misc-inst-entry %construct)
        ((m-t) q-typed-pointer pdl-pop)
	(POPJ-EQUAL M-T A-V-NIL)
lmp-construct-t
        (jump-data-type-equal m-t (a-constant (byte-value q-data-type dtp-list))
			      lmp-construct-list)
lmp-construct-not-list
        (jump-data-type-equal m-t (a-constant (byte-value q-data-type dtp-locative))
			      qcar3)
	((m-a) m-t)
        (call-data-type-equal-xct-next m-t (a-constant (byte-value q-data-type dtp-symbol))
				       lmp-symeval-a)
       ((m-t) a-v-nil)
        (dispatch (byte-field 3 25) m-a d-lmp-construct)       ;XCT-NEXT if first occ.
       ((pdl-push) m-a)

lmp-construct-list				;Construct the cons sitting in T.
#+lambda (jump-greater-than micro-stack-pntr-and-data (a-constant 20._24.)
			    lmp-construct-slow-recurse)	;Chicken out?
#+exp	 (jump-greater-than micro-stack-pntr (a-constant 10.)
			    lmp-construct-slow-recurse)	;Chicken out?
	(call-xct-next lmp-construct-list-rest)
       ((pdl-push) (a-constant (byte-value q-data-type dtp-fix)))	;Push count first.
        (jump-equal-xct-next m-t a-v-nil lmp-list)	;LIST* the elements.
       ((m-r) q-pointer pdl-pop)		;R long.
        (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-locative))
				  lmp-construct-exit)
        ((m-t) q-pointer m-t
	     (a-constant (byte-value q-data-type dtp-external-value-cell-pointer)))
lmp-construct-exit
        ((pdl-push) m-t)
        (jump-xct-next lmp-list*)
       ((m-r) m+1 m-r)

lmp-construct-list-rest
	(call lmp-carcdr)
        ((pdl-push) m-t)
	((m-t) m-a)
	(jump-equal m-t a-v-nil lmp-construct-list-cdr)
	(call lmp-construct-t)
	;Invz element if need be
        (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-locative))
				  lmp-construct-list-cdr)
        ((m-t) q-pointer m-t
	     (a-constant (byte-value q-data-type dtp-external-value-cell-pointer)))

lmp-construct-list-cdr
        ((m-k) q-typed-pointer pdl-pop)		;pop rest of template
        ((m-s) q-typed-pointer pdl-pop)		;pop count
        ((pdl-push) m-t)			;push element
	((pdl-push) m+1 m-s)			;push incf count
	(popj-equal-xct-next m-k a-v-nil)
       ((m-t) m-k)
        (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-list))
				  lmp-construct-not-list)
	((pdl-buffer-index) sub pdl-buffer-pointer a-ap)	;Stack frame filling up?
        (jump-less-or-equal pdl-buffer-index (a-constant 370) lmp-construct-list-rest)
	;drop thru if frame is filling up

lmp-construct-slow-recurse
	((m-k) m-t)				;CALL-EXIT-VECTOR clobbers M-T...
        (dispatch-call (i-arg lmpoff-construct) d-call-exit-vector i-dont-chain)
        ((pdl-push) q-typed-pointer m-k (a-constant (byte-value q-cdr-code cdr-nil)))
        (dispatch (i-arg 1) d-lmp-mmjcall i-dont-chain)

lmp-put-frame					;Store PDL-POP in local frame and succeed.
        ((m-t) q-typed-pointer pdl-top)
	((micro-stack-data-push) (a-constant (i-mem-loc lmp-pop-succeed)))
        (dispatch-xct-next (byte-field 2 23) m-a d-lmp-put-frame)
       ((m-1) (byte-field 23 0) m-a)

lmp-put-cell-frame				;Store a cell into local frame and return it.
        (call lmp-cell)
        ((m-a) pdl-pop)				       ;Was pushed at LMP-CONSTRUCT-LIST -1.
        (dispatch-xct-next (byte-field 2 23) m-a d-lmp-put-frame)
       ((m-1) (byte-field 23 0) m-a)

lmp-get-frame-d					;Dereference after doing...
	((micro-stack-data-push) (a-constant (i-mem-loc lmp-dereference)))
lmp-get-frame					;Get from local frame into T
        (dispatch-xct-next (byte-field 2 23) m-a d-lmp-get-frame)
       ((m-1) (byte-field 23 0) m-a)

lmp-put-vector					;Store in interpreter's vector.
	(call-xct-next qrar3)
       ((m-s) add m-1 a-lmp-vector)
	(popj-after-next (m-t) q-typed-pointer md)
       (no-op)

lmp-get-vector					;Read from interpreter's vector.
        (jump-xct-next qcar3)
       ((m-t) add m-1 a-lmp-vector)

lmp-ro-construct-void				;Make read-only void.
	(jump-xct-next lmp-ro-allocate)
       (call lmp-cell)

lmp-ro-construct-1				;Make read-only 1st occ.
	(jump-xct-next lmp-ro-allocate)
       (call lmp-put-cell-frame)

lmp-ro-construct-2				;Make read-only 2nd occ.
	(call lmp-get-frame-d)
        (popj-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-locative)))
        ;drop thru if we are a variable

;;(make-instance-in-area *prolog-work-area* read-only-variable ':cell <T>)
lmp-ro-allocate
	((pdl-push) m-t)
        ((m-b) (a-constant 2))			;Cons 2 words
        ((m-a) (a-constant 2))
        (call-xct-next allocate-structure-storage)
       ((m-s) a-lmp-area)			;in *PROLOG-WORK-AREA*
	(dispatch-call (i-arg lmpoff-read-only-variable-flavor) d-read-exit-vector i-dont-chain)
	((write-memory-data)
	 q-pointer md (a-constant (byte-value q-data-type dtp-instance-header)))
	((vma-start-write m-t)
	 q-pointer m-t (a-constant (byte-value q-data-type dtp-instance)))
        (check-page-write)
        (gc-write-test)
	((md) q-typed-pointer pdl-pop (a-constant (byte-value q-cdr-code cdr-nil)))
	((vma-start-write) add m-t (a-constant 1))
        (check-page-write)
        (popj-after-next)
       (gc-write-test)

lmp-ro-uvoid					;Unify with read-only void.
        (jump-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-locative))
				  lmp-pop-fail)
	(jump-xct-next lmpu-var-x)
       (call lmp-ro-construct-void)

lmp-ro-unify-1					;Unify with read-only 1st occ.
        (jump-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-locative))
				  lmp-pop-fail)
	(jump-xct-next lmpu-var-x)
       (call lmp-ro-construct-1)

lmp-ro-unify-2					;Unify with read-only 2nd occ.
        (jump-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-locative))
				  lmp-ro-unify-nonvar)
        (jump-xct-next lmpu-var-x)
       (call-data-type-equal m-t (a-constant (byte-value q-data-type dtp-locative))
				 lmp-ro-allocate)

lmp-ro-unify-nonvar				;NV&V  fail, NV&NV  unify
        (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-locative))
				  lmp-updl)
        (jump lmp-pop-fail)


lmp-unil-then-join
	((micro-stack-data-push) (a-constant (i-mem-loc lmp-uconstruct-join)))
lmp-unil					;Unify PDL with NIL.
	((pdl-top m-tem) q-typed-pointer pdl-top)
	(jump-equal m-tem a-v-nil lmp-pop-succeed)
        (jump-data-type-equal-xct-next pdl-top
					   (a-constant (byte-value q-data-type dtp-locative))
					   lmpu-var-x)
       ((m-t) a-v-nil)
        (jump-data-type-equal pdl-top
				  (a-constant (byte-value q-data-type dtp-instance))
				  lmpu-instance-x)
	;All other cases fail...

lmp-pop-fail					;Pop one and fail.
	(popj-after-next (m-t) a-v-nil)
       (pdl-pop)

        (misc-inst-entry %unify-term-with-term)
        ((m-t) q-typed-pointer pdl-pop)

lmp-updl					;Here to unify PDL with T.
	((m-s pdl-top) q-typed-pointer pdl-top)	;Make S=PDL
	(jump-equal m-s a-t lmp-pop-succeed)
	;Start of less strange code, as suggested by khs.
	((m-i) a-lmp-mode output-selector-leftshift-1)

lmp-updl-1					;Unify S=PDL with T and ST.
						;M-I has mode bits when recursing,
						;gets bit 1 in bit 2 the first time.
	((m-1) q-data-type m-s)
	((m-2) q-data-type m-t)		   ;could save a cycle if table were on
	((m-3) dpb m-1 (byte-field 5 5) a-2)	; 0 modulo 2000...
	((vma-start-read) add m-3 a-unify-dispatch)
	(check-page-read)		   ;no transport since it's static
	((m-i) selective-deposit m-i (byte-field 1 2) a-lmp-mode)
	((oa-reg-low) dpb md oal-jump a-zero)
        (jump 0)

lmpu-x-x					;Chicken out to EQUAL.
	((pdl-push) m-t)
	(jump xequal)

lmpu-var-var					;Variable & variable.
	(jump-xct-next lmpu-var-x)
       ((m-t) q-pointer m-t
	(a-constant (byte-value q-data-type dtp-external-value-cell-pointer)))

lmpu-list-var					;List & variable.
	((pdl-top) m-t)
	((m-t) m-s)
	;drop thru

lmpu-var-list					;Variable & list.
	(call-if-bit-set (byte-field 1 0) m-i lmpu-var-list-check)
	;drop thru

lmpu-var-x
	(call-xct-next qrar3)
       ((m-s) q-typed-pointer pdl-pop)

        (call-not-equal-xct-next m-array-pointer a-lmp-trail decode-1d-array-uncached)
        ((m-array-pointer) dpb m-zero q-cdr-code a-lmp-trail)
        ((vma-start-read) sub m-array-pointer (a-constant 2))
	(check-page-read)
        ;;m-array-pointer is not generally transported
	(dispatch transport md)
	((m-q) q-pointer md)
	(jump-greater-or-equal-xct-next m-q a-array-length lmpu-var-x-ov)	;Check overflow.
       ((m-k) m-t)
	((m-t md-start-write) m+1 md)		;Bump fill-pointer.
	(check-page-write)
	((vma) add m-array-origin a-q)
	((md-start-write) m-k)			;Store trail-item.
	(check-page-write)
	(gc-write-test)
	(popj)		;this can be D-IGNORE!

lmpu-var-x-ov					;Overflow handling.
        (dispatch-call (i-arg lmpoff-array-push-extend) d-call-exit-vector i-dont-chain)
        ((pdl-push) a-lmp-trail)		;Don't worry about cdr code...
        ((pdl-push) q-typed-pointer m-k (a-constant (byte-value q-cdr-code cdr-nil)))
        (dispatch (i-arg 2) d-lmp-mmjcall i-dont-chain)

lmpu-x-var					;Non-variable & variable.
	((pdl-top) m-t)
	(jump-xct-next lmpu-var-x)
       ((m-t) m-s)

lmpu-x-instance					;Non-variable & instance.
	((pdl-top) m-t)
	((m-t) m-s)
	;drop thru

lmpu-instance-x					;Instance & non-variable.
        (call-xct-next p3zero)		;Escape to a :UNIFY method.
       ((m-s) pdl-pop)
        ((pdl-push) m-s)
        (dispatch-call (i-arg lmpoff-unify) d-read-exit-vector i-dont-chain)
        ((pdl-push) q-typed-pointer md (a-constant (byte-value q-cdr-code cdr-next)))
        ((pdl-push) q-typed-pointer m-t (a-constant (byte-value q-cdr-code cdr-nil)))
        (dispatch (i-arg 2) d-lmp-mmjcall i-dont-chain)

lmpu-list-list					;Here to unify two lists.
	 (call-if-bit-set (byte-field 1 2) m-i lmpu-unbind-later)
	 ((m-c) m-s)				;C gets first arg,
	 (call-xct-next lmp-carcdr)		;A and T get its parts.
	((m-d) m-t)				;D gets second arg,
	 ((m-b) m-a)				;B and S=TOP get its parts.
	 ((m-s pdl-top) m-t)
	 (call-xct-next lmp-carcdr)
	((m-t) m-c)
	 (jump-equal m-a a-b lmpu-equal-cars)
	 (jump-equal m-s a-t lmpu-equal-cdrs)
	 ((pdl-push) m-t)
	 ((pdl-push m-s) m-a)				;Recurse on cars.
	 (call-if-bit-set-xct-next (byte-field 1 1) m-i lmpu-llh-bind)
	((m-t) m-b)
#+lambda (call-greater-than micro-stack-pntr-and-data (a-constant 20._24.)
		lmpu-slow-recurse)
#+lambda (call-less-or-equal micro-stack-pntr-and-data (a-constant 20._24.)
		lmp-updl-1)
#+exp	 (call-greater-than micro-stack-pntr (a-constant 10.)
		lmpu-slow-recurse)
#+exp	 (call-less-or-equal micro-stack-pntr (a-constant 10.)
		lmp-updl-1)
	 (jump-equal m-t a-v-nil lmp-pop2-fail)
	 ((pdl-buffer-index) sub pdl-buffer-pointer (a-constant 1))	;Dereference cdrs.
         (call-data-type-equal-xct-next c-pdl-buffer-index
					(a-constant (byte-value q-data-type dtp-locative))
					qcar3)
        ((m-t) c-pdl-buffer-index)
         ((m-s c-pdl-buffer-index) m-t)
         (call-data-type-equal-xct-next pdl-top
					(a-constant (byte-value q-data-type dtp-locative))
					qcar3)
        ((m-t) q-typed-pointer pdl-pop)
         (jump-not-equal-xct-next m-s a-t lmp-updl-1)	;Iterate on cdrs if .
        ((m-i) a-lmp-mode)
         ;drop thru if cdrs eq.

lmp-pop-succeed
	 (popj-after-next (m-t) a-v-true)
	(pdl-pop)

lmpu-slow-recurse
	 ((m-a) pdl-pop)				;First arg pushed already.
	 ((m-b) m-t)
         (dispatch-call (i-arg lmpoff-unify-term-with-term) d-call-exit-vector i-dont-chain)
         ((pdl-push) q-typed-pointer m-a (a-constant (byte-value q-cdr-code cdr-next)))
         ((pdl-push) q-typed-pointer m-b (a-constant (byte-value q-cdr-code cdr-nil)))
         (dispatch (i-arg 2) d-lmp-mmjcall i-dont-chain)

lmpu-equal-cars						;Just iterate.
	 (jump-equal m-s a-t lmp-pop-succeed)
	 (jump-xct-next lmp-updl-1)
	(call-if-bit-set (byte-field 1 1) m-i lmpu-llh-bind)

lmpu-equal-cdrs						;Just iterate.
	 ((m-t) m-a)
	 ((pdl-top m-s) m-b)
	 (jump-xct-next lmp-updl-1)
	(call-if-bit-set (byte-field 1 1) m-i lmpu-llh-bind)

lmpu-var-list-check
	((m-k) pdl-top)
	(call-xct-next lmp-occurs-in-list)
       ((pdl-push m-a) m-t)
        (popj-equal-xct-next m-t a-v-nil)
       ((m-t) q-typed-pointer pdl-pop)
        (jump-xct-next lmp-pop-fail)	   ;Occur check succeeded, cause failure.
       (micro-stack-data-pop)

lmpu-llh-bind	;Bind the first cons to a RPLACD-FORWARD to the second cons.
	 ((pdl-push) m-t)
         ((pdl-push) q-pointer m-c (a-constant (byte-value q-data-type dtp-locative)))
	 ((m-t) q-pointer m-d (a-constant (byte-value q-data-type dtp-rplacd-forward)))
	 (jump-xct-next poptj)
        (call xbind1)

lmpu-unbind-later			   ;Save specPDL index and unwind before returning.
	 ((m-3) a-qlbndp)
	 ((pdl-top) q-pointer m-3 (a-constant (byte-value q-data-type dtp-locative)))
	 ((pdl-push) m-s)
	 (popj-after-next (m-i) a-lmp-mode)	;Turn off M-I<2>.
        ((micro-stack-data-push) (a-constant (i-mem-loc xunbind-to-index)))

lmp-carcdr					;A := car(T), T := cdr(T)
	  ((vma-start-read) m-t)
	  (check-page-read)
	  (dispatch transport md)
#+lambda (micro-fault-ok-here)
	  (jump-not-equal-xct-next vma a-t qcdr3)	;Full cdr if the car was forwarded
	 ((m-a) q-typed-pointer md)
	  (dispatch q-cdr-code md cdr-cdr-dispatch)	;XCT-NEXT on CDR-NEXT
	 ((m-t) add vma (a-constant 1))

        (misc-inst-entry %untrail)
;;Scratchpad registers used here:
;;PDL-TOP is MARK
;;M-I is transported array-pointer 
;;M-K is *TRAIL*
;;M-E is 1+last trail item address
        ((pdl-top) q-typed-pointer pdl-top)

lmp-untrail-restart				;Initialize.
        (call-not-equal-xct-next m-array-pointer a-lmp-trail decode-1d-array-uncached)
        ((m-array-pointer) dpb m-zero q-cdr-code a-lmp-trail)
	((vma-start-read) sub m-array-pointer (a-constant 2))
	(check-page-read)
        ;;m-array-pointer is not generally transported
	(dispatch transport md)
        ((m-i) add vma (a-constant 2))
        ((m-k) q-typed-pointer md)
        ((m-e) add m-array-origin a-k)

lmp-untrail-loop
        (jump-greater-or-equal pdl-top a-k lmp-pop-fail)
        ((m-k md) sub m-k (a-constant 1))	;*TRAIL* := *TRAIL*-1
	((vma-start-write) sub m-i (a-constant 2))
	(check-page-write)
        ((m-e vma-start-read) sub m-e (a-constant 1))	;Get next item.
        (check-page-read)
	(dispatch transport md)			;Transport to newspace.
	((m-t) q-typed-pointer md)
	((md-start-write) a-v-nil)		;Clobber item with NIL.
	(check-page-write)
        (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-locative))
				  lmp-untrail-invoke)
	((vma-start-read) m-t)
	(check-page-read)			;Transporting done already, just want the cdr code.
        ((md-start-write) selective-deposit md q-cdr-code a-t)
	(check-page-write)
	(jump-xct-next lmp-untrail-loop)
       (gc-write-test)

lmp-untrail-invoke
	(jump-xct-next lmp-untrail-restart)	;Re-initialize after invoking,
       (call lmp-invoke)			; since it can have side-effects.

#-lexical	(misc-inst-entry %invoke)
;; This is as #-LEXICAL (apply (car x) (cdr x)) #+LEXICAL (funcall x),
;; but checks for TRUE and FALSE first, which are frequent cases in continuations.
#-lexical	((m-t) q-typed-pointer pdl-pop)

lmp-invoke

#-lexical (call-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-list))
				    illop)
#-lexical	(call lmp-carcdr)		;A := fctn, T := args.
#-lexical	(dispatch-call (i-arg lmpoff-true) d-read-exit-vector i-dont-chain)
#-lexical	((md) q-typed-pointer md)
#-lexical	(jump-equal md a-a xtrue)		;Succeed if fctn is TRUE.
#-lexical	(dispatch-call (i-arg lmpoff-false) d-read-exit-vector i-dont-chain)
#-lexical	((md) q-typed-pointer md)
#-lexical	(popj-equal md a-a)			;Fail if fctn is FALSE.
#-lexical	((pdl-push) m-a)
#-lexical	(jump-xct-next uaply)			;APPLY otherwise.
#-lexical      ((pdl-push) m-t)

#+LEXICAL	(call p3zero)
#+LEXICAL	((pdl-push) m-t)
#+LEXICAL	(dispatch (i-arg 0) d-lmp-mmjcall i-dont-chain)


	(misc-inst-entry %current-entrypoint)
        ((m-t) q-typed-pointer pdl-pop)
lmp-centry
	((vma-start-read) m-t)	;K := definitions alist.
	(check-page-read)
	(dispatch transport md)
	((m-k) q-typed-pointer md)
        (dispatch-call (i-arg lmpoff-universe) d-read-exit-vector i-dont-chain)	;B := *universe*.
	((m-b) q-typed-pointer md)
	(jump-equal m-k a-v-nil lmp-nodef)	;Any definitions at all?
	((vma-start-read) m-k)			;K := cache item.
	(check-page-read)
	(dispatch transport md)
	(call-xct-next lmp-carcdr)		;A := latest universe, T := defn.
       ((m-t) q-typed-pointer md)
        (jump-equal-xct-next m-b a-a qcar3)

lmp-nodef
       ((m-a) q-typed-pointer pdl-pop)		;A := predicator
	(dispatch-call (i-arg lmpoff-find-and-cache) d-call-exit-vector i-dont-chain)
	((pdl-push) q-typed-pointer m-k (a-constant (byte-value q-cdr-code cdr-next)))	;defs
	((pdl-push) q-typed-pointer m-b (a-constant (byte-value q-cdr-code cdr-next)))	;worlds
	((pdl-push) q-typed-pointer m-a (a-constant (byte-value q-cdr-code cdr-nil)))	;name
        (dispatch-call (i-arg 3) d-mmcall i-dont-chain)
        (jump qcar)
; Micro-Paging crock doesn't like the following.  -- should be OK now.
;	(jump-xct-next qcar)			;Full CAR since arg may become NIL.
;       (dispatch-call (i-arg 3) d-mmcall i-dont-chain)

;;STORE IN LOCAL BLOCK
QSTLOC
	(POPJ-AFTER-NEXT (PDL-BUFFER-INDEX) ADD M-1 A-LOCALP)
       ((C-PDL-BUFFER-INDEX) M-T)
;;STORE IN ARGUMENT BLOCK
QSTARG
	(POPJ-AFTER-NEXT (PDL-BUFFER-INDEX) ADD M-AP A-1 ALU-CARRY-IN-ONE)
       ((C-PDL-BUFFER-INDEX) M-T)
;;STORE IN HIGHER CONTEXT
#+LEXICAL	lmp-xstore
#+LEXICAL	 ((pdl-push) dpb m-zero (byte-field 5 23) a-a)
#+LEXICAL	 (jump xstore-in-higher-context)

;;REF LOCAL BLOCK
QADLOC1
	(POPJ-AFTER-NEXT (PDL-BUFFER-INDEX) ADD M-1 A-LOCALP)
       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)
;;REF ARGUMENT BLOCK.  CANNOT BE INVISIBLE POINTER.
QADARG1
	(POPJ-AFTER-NEXT (PDL-BUFFER-INDEX) ADD M-AP A-1 ALU-CARRY-IN-ONE)
       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)
;;LOAD FROM HIGHER CONTEXT
#+LEXICAL	lmp-xload
#+LEXICAL	 ((pdl-push) dpb m-zero (byte-field 5 23) a-a)
#+LEXICAL	 (jump xload-from-higher-context)

#+lambda (end-pagable-ucode)
        ))