;-*- Mode:LISP; Readtable:ZL; Base:8; Fonts:(CPTFONT CPTFONTB) -*-


(defconst uc-closure '(

;;; Here is how lexical closures work
;;; A lexical closure consists of a piece of code and an environment to
;;; resolve free variable references.  The code is implemented by a FEF and the
;;; environment is implemented as a list of vectors.  Each car in the environment is
;;; a lexical environment frame which is a vector of variable bindings.  As there is
;;; no way to extend the number of variables in a lexical environment, a vector
;;; saves space, but more importantly, since the lexically visible variables can be
;;; known at compile time, the compiler can generate code that simply "arefs" a
;;; given frame and finds the correct value of a lexical variable.  A lexical
;;; environment is a list of these vectors.

;;; A closure is implemented like this:
;;;   (dtp-closure          )
;;;                      |
;;;                 /----/ pointer to closure
;;;                
;;;   (cdr-next dtp-fef-pointer   --)--- points to a fef containing the code
;;;   (cdr-nil  dtp-list            )
;;;                              |
;;;                 /------------/ pointer to lexical environment
;;;                
;;;   (cdr-normal dtp-list        --)--- points to lexical frame
;;;   (cdr-error  dtp-list        --)--- points to next environment

;;; Now for the nitty gritty details.
;;; When a stack frame is active (i.e. it is still on the stack and can be run.)  The
;;; variables which are bound in the frame live on the stack.  The lexical frame
;;; must contain pointers to the actual locations of the variables.  The lexical
;;; frames consist of a vector of pointers to the actual locations which are tagged
;;; with DTP-EXTERNAL-VALUE-CELL-POINTER (evcp).  When the stack frame is exited, the
;;; values of the variables are copied into the heap and all the evcp's to the stack
;;; are changed to point to the heap copy.

;;; Lexical contexts may be flattened.  This saves space and time in several areas.
;;; However, some lexical contexts cannot be flattened because this would cause
;;; sharing of variables that should be unshared.  The compiler can recognize this
;;; and create code that unshares certain shared variables.

;;; How a frame with closures is set up in the first place:

;Frame begins here     (dtp-fix) ;bits controlling return
;		       (dtp-fix)
;		  (DTP-FEF-POINTER   --)---> to code for the frame.
;Arguments        (cdr-next ......)
; cdr codes are   (cdr-next ......)
; set right               : <more args>
;                         :
; last arg        (cdr-nil  ......)
;Locals           (...............) <--- A-LOCALP if this is the current function
; random boxed    (...............)
; objects                 : <more locals>
;                         :
;Closure          (cdr-error dtp-locative  ---)---> to heap closures for purpose
; locatives               : <more locatives>        of disconnecting.
;                         :
; In the last two locals:
;Shared lexical frame    (dtp-list   ---)---> to the shared frame
;Unshared frame list     (dtp-list   ---)---> to unshared frame list

; The top of the stack is here.

;;; Notes on the above diagram.
;;; 1) The word just before the lexical frame is used
;;;    to locate the beginning of the stack
;;;    frame.
;;; 2) The lexical frame need not be there.  All the local slots
;;;    are set to point to nil when the frame is entered.  When it comes
;;;    time to make a stack closure, the next to last local slot is
;;;    checked to see if a lexical frame has been made.  If it has not,
;;;    (i.e. it is nil) the FEF is looked at to find a list of args and
;;;    locals to forward the slots in the lexical frame to.  If the list
;;;    in the FEF is nil, this means that the current frame is empty.
;;;    In this case, the next to last local is set to T indicating an
;;;    empty frame.
;;; 3) Note 3 is self referential.
;;; 4) A-LEXICAL-ENVIRONMENT will point to the context outside of this
;;;    frame so all closures created in this frame will contain a copy
;;;    of A-LEXICAL-ENVIRONMENT.

(begin-pagable-ucode)

1CLOSURE-TRAP*

     ;Closure trap is an efficiency hack to speed up downward funargs.  If
     ;we take a closure trap, we mark the frame for copy out on popping, otherwise,
     ;we know that there are no closures pointing to this frame and we can just
     ;punt.

     ;Save some regs.
  ((pdl-push) m-t)
  ((pdl-push) m-a)

     ;Save the location and md.
  ((pdl-push) vma)
  ((pdl-push) md)

     ;Read the lexical environment.  It is the cadr of the closure. (cdr coded)
  ((vma-start-read) add md (a-constant 1))
  (check-page-read)
  (dispatch transport md)
  ((m-t) q-typed-pointer md)

     ;Now we cdr on down the lexical environment and mark each stack frame
     ;that contains the variables used in the lexical environment.

1closure-trap-loop*
     ;Quit when we reach the end of the loop.
  (jump-equal m-t a-v-nil closure-trap-store-closure)
     ;M-A gets the lexical frame, M-T gets the next environment.
  (call carcdr-no-sb)

     ;Empty frames need no work done.
  (jump-equal m-a a-v-true closure-trap-loop)

     ;Otherwise, read the cell before the lexical frame.  It is either an evcp to the 
     ;frame FEF or something else.  If it is an evcp, we do some work.  If it is not,
     ;we keep scanning on down.
  ((vma-start-read) sub m-a (a-constant 1))
  (check-page-read)
  (dispatch transport-no-evcp md)
  (check-data-type-jump-not-equal md m-tem dtp-external-value-cell-pointer
				  closure-trap-loop)

     ;MD has the evcp to the fef.  The address field points to the beginning of the
     ;stack frame.  Turn on the copy out bit if necessary.  If the bit is on, we don't
     ;need to continue to trace back.

  ((vma-start-read) add md (a-constant (eval %lp-entry-state)))
  (check-page-read)
  (dispatch transport md)
     ;Check if bad data in the stack frame.
  (check-data-type-call-not-equal md m-tem dtp-fix illop)
     ;Note if the ens-environment-pointer bit is set, the attention bit is too, so we
     ;can skip it.
  (jump-if-bit-set (lisp-byte %%lp-ens-environment-pointer-points-here 1) md
		   closure-trap-store-closure)
  ((md-start-write) ior md
			(a-constant (byte-value
				      (lisp-byte %%lp-ens-environment-pointer-points-here) 1)))
  (check-page-write) ;wrote a fixnum, no volatility test.
  
     ;Turn on the attention bit if necessary.
  ((vma-start-read) add vma 
  		    (a-constant (difference (eval %lp-call-state) (eval %lp-entry-state))))
  (check-page-read)
  (dispatch transport md)
  (check-data-type-call-not-equal md m-tem dtp-fix illop)
  (jump-if-bit-set (lisp-byte %%lp-cls-attention) md closure-trap-loop)
  ((md-start-write) ior md
                        (a-constant (byte-value (lisp-byte %%lp-cls-attention) 1)))
  (check-page-write) ;wrote a fixnum, no volatility.
  (jump closure-trap-loop)

1closure-trap-store-closure*
     ;Write back a dtp-closure.
  ((m-tem) (a-constant (eval dtp-closure)))
  ((m-tem1) pdl-pop)
  ((md) dpb m-tem q-data-type a-tem1)
  ((vma-start-write) pdl-pop)
  (check-page-write)
  (gc-write-test)
     ;Restore regs.
  ((m-a) pdl-pop)
  ((m-t) pdl-pop)
  (popj)


1MAKE-CLOSURE-TOP-LEVEL*
  (jump-xct-next make-closure-1)
 ((pdl-push) a-v-nil)

1MAKE-CLOSURE*
  ((pdl-push) a-lexical-environment)

1make-closure-1*

     ;The low 9 bits of the MAKE-CLOSURE instruction specify the local
     ;slot that holds the locative to the q in the closure that holds
     ;the lexical frame of the closure.  When we make a closure, we may
     ;have to set up the lexical frame, the dtp-list pointer to the top
     ;of the stack frame, the list of lexical frame copies and the
     ;pointer to the lexical frame itself.

     ;M-C gets the lexical-frame
  (call find-or-create-lexical-frame)
  ((pdl-push) m-c)

     ;Allocate 4 slots, 2 for the closure, 2 for the environment.
  ((m-b) (a-constant 4))
  (call-xct-next allocate-list-storage)
 ((m-s) dpb m-zero q-all-but-typed-pointer a-background-cons-area)

     ;Fill in the slots we allocated.  This is done in order of things on the
     ;stack and is pretty random.

     ;Put in the lexical frame.
  ((vma) add m-t (a-constant 2))
  ((md-start-write) dpb pdl-pop q-typed-pointer (a-constant (byte-value q-cdr-code cdr-normal)))
  (check-page-write)
  (gc-write-test)

     ;Put in the lexical environment tail.
  ((vma) add m-t (a-constant 3))
  ((md-start-write) dpb pdl-pop q-typed-pointer (a-constant (byte-value q-cdr-code cdr-error)))
  (check-page-write)
  (gc-write-test)

     ;Put in the FEF pointer.
  ((vma) m-t)
  ((md-start-write) dpb pdl-pop q-typed-pointer (a-constant (byte-value q-cdr-code cdr-next)))
  (check-page-write)
  (gc-write-test)
  
    ;Put in the environment pointer.
  ((vma) add m-t (a-constant 1))
  ((m-tem) add m-t (a-constant 2))
  ((md-start-write) dpb m-tem q-pointer (a-constant (plus (byte-value q-cdr-code cdr-nil)
							  (byte-value q-data-type dtp-list))))
  (check-page-write)
  (gc-write-test)
 

; The tail recursion flag doesn't work, so we don't need this code.
;     ;This code marks the frame so tail recursion will not flush it.
;     ;This is probably unnecessary, but the stack closure code has it
;     ;and we shouldn't just lose randomly.
;  ((pdl-buffer-index) add m-ap (a-constant (eval %lp-entry-state)))
;  ((m-2) c-pdl-buffer-index)
;  ((c-pdl-buffer-index) dpb m-minus-one (lisp-byte
;					  %%lp-ens-unsafe-rest-arg) a-2)
     ;Locate the local slot to contain the locative.
  ((pdl-index) macro-ir-adr)
  ((pdl-index) add pdl-index a-localp)
     ;Put a locative there
  ((m-t) add m-t (a-constant 3))
  ((c-pdl-buffer-index) dpb m-t q-pointer 
			(a-constant
			  (plus (byte-value q-data-type dtp-locative)
				(byte-value q-cdr-code cdr-error))))

  ((pdl-index) add m-ap (a-constant (eval %lp-entry-state)))
     ;Illop if illegal data at beginning of stack frame.
  (check-data-type-call-not-equal c-pdl-buffer-index m-tem dtp-fix illop)

     ;If we have already taken a closure trap in this frame, make a regular closure
     ;instead of a stack closure.
  (jump-if-bit-set (lisp-byte %%lp-ens-environment-pointer-points-here) c-pdl-buffer-index
		   store-regular-closure)
  (popj-after-next no-op)
 ((pdl-push m-t) q-pointer m-t (a-constant (byte-value q-data-type dtp-stack-closure)))

1store-regular-closure*
  (popj-after-next no-op)
 ((pdl-push m-t) q-pointer m-t (a-constant (byte-value q-data-type dtp-closure)))


1FIND-OR-CREATE-LEXICAL-FRAME*
     ;This routine sets up the lexical frame.  If it is already set up,
     ;it just returns.  The lexical frame in either case will be in M-C.

  (call find-lexical-frame)

     ;If the slot is not nil, it is already set up.
  (popj-not-equal-xct-next c-pdl-buffer-index a-v-nil)
 ((m-c) c-pdl-buffer-index)

     ;The slot is nil, so we need to set it up.
     ;Get the FEF cell two before the instructions.  This is the lexical
     ;map.
  ((m-c) pdl-index) ;save for create lexical frame empty.
  ((vma-start-read) m-fef)
  (check-page-read) ;FEF is not in oldspace, so no transport here.
  ((m-1) (lisp-byte %%fefh-pc-in-words) md)
  ((m-1) m-a-1 m-1 (a-constant 1)) ;subtract 2
  ((vma-start-read) add m-fef a-1)   ;Read the location.
  (check-page-read)
  (dispatch transport md)

     ;Make vma point to the car of list.  Since the list guaranteed to
     ;be cdr coded, we can simply scan down it by bumping the vma
     ;instead of having to car and cdr.
  ((vma) q-typed-pointer md)

     ;NIL in the FEF means no lexical frame
  (jump-equal vma a-v-nil create-lexical-frame-empty)

     ;Calculate length of first lexical frame.  Save address of FEF map
     ;for later.
  (call-xct-next find-length-of-cdr-coded-list)
 ((pdl-push) vma)

     ;Now we allocate that +1 in the heap in the background cons area.
     ;Allocate list storage takes boxed size untyped in M-B and area in
     ;M-S.  Returns address in M-T.
  ((pdl-push) q-pointer m-b)
  ((m-b) add m-b (a-constant 1))
  (call-xct-next allocate-list-storage)
 ((m-s) dpb m-zero q-all-but-typed-pointer a-background-cons-area)

     ;Install new lexical frame in stack frame.
  (call find-lexical-frame)
  ((m-tem) add m-t (a-constant 1))
  ((c-pdl-buffer-index) dpb m-tem q-pointer (a-constant (byte-value q-data-type dtp-list)))

     ;M-B gets count minus one.
  ((m-b) sub pdl-pop (a-constant 1))
     ;M-K gets stuff to merge into lexical frame.
  (call-xct-next convert-pdl-buffer-address)
 ((m-k) m-ap)

     ;Write the address of the FEF in the first lexical frame slot.
  ((vma) m-t)
  ((md-start-write m-k) dpb m-k q-pointer
	 (a-constant (plus (byte-value q-data-type
				       dtp-external-value-cell-pointer)
			   (byte-value q-cdr-code cdr-next))))
  (check-page-write)
  (gc-write-test)

     ;M-C gets offset of local block with respect to arg 0.
  ((m-c) a-localp)
  ((m-c) m-a-1 m-c a-ap)
     ;M-D gets address of one beyond the end of the FEF map.
  ((m-d) m+a+1 pdl-pop a-b)

1find-or-create-lexical-frame-fill-frame*
     ;Read from the FEF map.
  ((vma-start-read m-d) sub m-d (a-constant 1))
  (check-page-read)
  (dispatch transport md)
     ;If the fixnum in the FEF map has the sign bit set, it is a local.
     ;Anyway, only the low 10 bits are of interest.
  (jump-if-bit-clear-xct-next boxed-sign-bit md
			      find-or-create-lexical-frame-arg)
 ((m-1) (byte-field 10. 0) md)
  ((m-1) add m-1 a-c) ;Otherwise, it is a local: add the local offset

1find-or-create-lexical-frame-arg*
     ;Get the pointer into the new lexical frame, and write a cdr-next
     ;evcp to the appropriate spot.
  ((vma m-t) add m-t (a-constant 1))
  ((md-start-write) m+a+1 m-k a-1)
  (check-page-write)
  (gc-write-test)
     ;Loop if not done.
  (jump-not-equal-xct-next m-b a-zero find-or-create-lexical-frame-fill-frame)
 ((m-b) sub m-b (a-constant 1))

     ;Rewrite the last one to be cdr nil.
  ((md-start-write) dpb md q-typed-pointer
			   (a-constant (byte-value q-cdr-code cdr-nil)))
  (check-page-write) ;No gc-write test, we just changed the cdr code.

     ;Get the lexical frame in M-C.
  (call find-lexical-frame)
  (popj-after-next no-op)
 ((m-c) c-pdl-buffer-index)

1create-lexical-frame-empty*
     ;M-C and the slot in the frame just get A-V-TRUE.
  (popj-after-next
    (pdl-index) m-c)
 ((c-pdl-buffer-index m-c) a-v-true)


1FIND-LEXICAL-FRAME*
     ;It is one slot before the list of frame copies.
  (call find-list-of-lexical-frame-copies)
     ;pdl-index points to the list of frame copies.
  (popj-after-next no-op)
 ((pdl-index) sub pdl-index (a-constant 1))

1FIND-LIST-OF-LEXICAL-FRAME-COPIES*
     ;Looks at m-fef and makes pdl-index point to the location in the
     ;pdl buffer that holds the lexical frame copy list.

     ;Find the %fefhi-misc word
  ((vma-start-read) add m-fef (a-constant (eval %fefhi-misc)))
  (check-page-read)
     ;Extract the local block length.
  ((pdl-index) (lisp-byte %%fefhi-ms-local-block-length) md)
     ;Add it to the beginning of the locals, and subtract 1.
  (popj-after-next
    (pdl-index) add pdl-index a-localp)
 ((pdl-index) sub pdl-index (a-constant 1))


1CLOSURE-DISCONNECT-FIRST*
     ;In order to unshare lexical variables, we must have two copies
     ;of the lexical frame.  CLOSURE-DISCONNECT-FIRST copies the lexical
     ;frame and makes a closure use the copy instead of the original.
     ;The compiler will not issue this instruction if the lexical frame
     ;is T.

  (call unshare-lexical-frame)

1CLOSURE-DISCONNECT*
     ;Should be called with the new lexical frame in M-T.  The compiler
     ;only puts these instructions immediately after a previous
     ;closure-disconnect of closure-disconnect-first.  Therefore, we
     ;must leave the new environment in M-T.

     ;Find out which closure to disconnect.
  ((m-a) macro-ir-adr)
  ((pdl-index m-k) add m-a a-localp)

     ;If the closure is not set up, no need to disconnect.
  (popj-equal c-pdl-buffer-index a-v-nil)

     ;Otherwise, it is a locative to the pointer to the lexical frame to
     ;replace.
  (check-data-type-call-not-equal c-pdl-buffer-index m-tem dtp-locative
				  illop)
     ;Indirect through the locative.
  ((vma-start-read) c-pdl-buffer-index)
  (check-page-read)
  (dispatch transport md)
     ;Smash pointer to old closure.
  ((pdl-index) m-k)
  ((c-pdl-buffer-index) a-v-nil)
     ;Put in pointer to lexical environment copy.
  ((md-start-write) selective-deposit md q-all-but-pointer a-t)
  (check-page-write)
  (gc-write-test)
  (popj)

1UNSHARE-LEXICAL-FRAME*
     ;Copy the lexical frame and put it on the list of lexical frame
     ;copies.  The new frame is in M-T.

     ;Find and copy the lexical frame.

  (call find-lexical-frame)
  (popj-equal c-pdl-buffer-index a-v-nil)
  (call-xct-next copy-cdr-coded-list)
 ((vma m-k) sub c-pdl-buffer-index (a-constant 1))

     ;Save M-T (copy) for later
  ((pdl-push m-t) add m-t (a-constant 1))
     ;Find list of frame copies, push M-T for qcons
  (call-xct-next find-list-of-lexical-frame-copies)
 ((pdl-push) m-t)

     ;Push frame list for qcons and cons up new list.
  ((pdl-push) c-pdl-buffer-index)
  (call-xct-next qcons)
 ((m-s) dpb m-zero q-all-but-typed-pointer a-background-cons-area)
 
     ;Point at list of copies.
  (call find-list-of-lexical-frame-copies)
     ;Smash with new cons, and return copy in M-T.
  (popj-after-next
    (c-pdl-buffer-index) m-t)
 ((m-t) pdl-pop)


1COPY-CDR-CODED-LIST*
     ;Returns a copy in M-T of the cdr coded list in VMA.

     ;VMA gets clobbered by call, so we must save it.  M-B gets set up
     ;by call, so nothing need be done.
  (call-xct-next find-length-of-cdr-coded-list)
 ((pdl-push) vma)

     ;Make some room for the copy.
  (call-xct-next allocate-list-storage)
 ((m-s) dpb m-zero q-all-but-typed-pointer a-background-cons-area)

     ;Set up for loop.  Save M-T to unclobber later.
     ;M-B has the count minus one.  M-S gets the source.  M-T gets the
     ;copy.
  ((m-b) sub m-b (a-constant 1))
  ((m-s) sub pdl-pop (a-constant 1))
  ((pdl-push m-t) sub m-t (a-constant 1))

1copy-cdr-coded-list-loop*
     ;Read the old value.  Use transport-no-evcp because this is primarily used
     ;for copying lexical frames which are full of evcps.  Using this funny
     ;transport causes them not to be snapped.
  ((vma-start-read m-s) add m-s (a-constant 1))
  (check-page-read)
  (dispatch transport-no-evcp md)
     ;Write it into the new location.
  ((vma-start-write m-t) add m-t (a-constant 1))
  (check-page-write)
  (gc-write-test)
     ;Loop until done.
  (jump-not-equal-xct-next m-b a-zero copy-cdr-coded-list-loop)
 ((m-b) sub m-b (a-constant 1))

     ;Result goes in M-T.
  (popj-after-next
    (m-t) add pdl-pop (a-constant 1))
 ((m-t) dpb m-t q-pointer (a-constant (byte-value q-data-type dtp-list)))


1FIND-LENGTH-OF-CDR-CODED-LIST*
     ;Calculates length of cdr coded list pointed to by vma.  Untyped
     ;result goes into M-B. Smashes M-TEM, VMA and MD.

     ;Prepare for the loop.
  ((m-b) (a-constant 1))
  ((vma) sub vma (a-constant 1))
  
1find-length-of-cdr-coded-list-loop*
     ;Read the next cell.  Use transport-no-evcp because this is primarily used
     ;for copying lexical frames which are full of evcps.  Using this funny
     ;transport causes them not to be snapped.
  ((vma-start-read) add vma (a-constant 1))
  (check-page-read)
  (dispatch transport-no-evcp md)
     ;If cdr-nil, return.
     ;If cdr-next, loop.
     ;Otherwise, error.
  ((m-tem) q-cdr-code md)
  (popj-equal m-tem (a-constant (eval cdr-nil)))
  (jump-equal-xct-next m-tem (a-constant (eval cdr-next))
		       find-length-of-cdr-coded-list-loop)
 ((m-b) add m-b (a-constant 1))
  (call illop) ;if cdr-error or cdr-normal


1CLOSURE-UNSHARE*
     ;Unshare a local variable in all copies (made by
     ;CLOSURE-DISCONNECT) of this frame's lexical frame.  The address
     ;field of the instruction is a 9-bit number which is this
     ;variable's index in the lexical frame.  We do this as follows: It
     ;is assumed that we have made a copy of the stack-consed lexical
     ;frame and pushed it onto the list of lexical frame copies.  In the
     ;list of frame copies, the slots in the frame point with evcps to
     ;the locals and args of the frame.  In order to unshare a variable,
     ;we snap the evcp on the first frame in the list and then walk down
     ;the list and change the evcp's in their slots to point to the copy
     ;in the first slot.  If we find something already snapped in one of
     ;the lexical frames on the list, we do not want to share with it,
     ;so we quit.

     ; This instruction is never used in a frame whose lexical frame is
     ; T (empty).

     ;Find the list of copies, if it is nil, nothing to unshare.
  (call find-list-of-lexical-frame-copies)
  (popj-equal-xct-next c-pdl-buffer-index a-v-nil)
 ((m-t) c-pdl-buffer-index)

     ;M-B gets the number of the slot.
  ((m-b) macro-ir-adr)

     ;Read evcp from current lexical frame.
  ((pdl-index) sub pdl-index (a-constant 1))
  ((vma-start-read) add c-pdl-buffer-index a-b)
  (check-page-read)
  (dispatch transport-no-evcp md)

     ;M-K gets the evcp, M-C gets the value at the end of the evcp.
  ((vma-start-read m-k) q-typed-pointer md)
  (check-page-read)
  (dispatch transport md)
  ((m-c) q-typed-pointer md)

     ;M-1 will hold flag telling if we have unshared once.
  ((M-1) M-ZERO)

1closure-unshare-forward-to-copy*
     ;M-K has an evcp -> the stack slot for the local we are unsharing.
     ;M-C has what to store in place of any evcps pointing to this
     ;local.  M-1 is zero if we have not yet found an evcp pointing to
     ;this local.  M-B has the index of this local's slot in the lexical
     ;frame, and in copies of it.  M-T has the list of all lexical frame
     ;copies made in this frame.  Examine each element of the list.
     ;Note that all the ones we need to unforward must be more recent
     ;than the ones we don't need to unforward, so we can exit the first
     ;time we find one already unforwarded.  If we hit the end of the
     ;list, we are done.  The first time around this loop, we write the
     ;snapped value and create an evcp to the snapped value to write on
     ;subsequent loops.

     ;Done if at the end of the copy list.
  (popj-equal m-t a-v-nil)
     ;This spreads a cons into M-A (gets car) and M-T (gets cdr)
  (call carcdr-no-sb)
     ;Read the slot in the lexical frame.
  ((vma-start-read) add m-a a-b)
  (check-page-read)
  (dispatch transport-no-evcp md)
  ((m-2) q-typed-pointer md)
     ;If it is not the evcp, we are done, it is unshared.
  (popj-not-equal m-2 a-k)
     ;Otherwise, make it be an evcp with the right cdr codes to the copy
     ;in the first frame, or, if we are working on the first frame, the
     ;actual value that the other evcps should point to.
  ((md-start-write) selective-deposit m-c q-typed-pointer a-2)
  (check-page-write)
  (gc-write-test)
     ;If we just wrote the value, make up an evcp to the value to use
     ;from now on.
     ;Flag in M-1 tells whether this is the first iteration.
  (jump-not-equal m-1 a-zero closure-unshare-forward-to-copy)
     ;toggle the flag.
  ((m-1) m-minus-one)
     ;Now, M-C will have an EVCP to the value, not the value itself.
  (jump-xct-next closure-unshare-forward-to-copy)
 ((m-c) dpb vma q-pointer
	       (a-constant (byte-value q-data-type dtp-external-value-cell-pointer)))

1CLOSURE-PREPARE-TO-POP-STACK-FRAME*
     ;Move all lexical variables out of the stack and into a lexical
     ;frame.

     ;First, we snap all the evcp's in the lexical frame.
     ;Frame must exist because this is only called after a stack closure trap has
     ;been taken.
  (call find-lexical-frame)
  ((m-j) sub c-pdl-buffer-index (a-constant 1))
     ;Set up for loop.
  ((vma) sub m-j (a-constant 1))
  
1closure-prepare-to-pop-snap-first-frame*
     ;Read through the evcp and write back the value, setting the cdr
     ;codes correctly.
  ((pdl-push) add vma (a-constant 1))
  ((vma-start-read) add vma (a-constant 1))
  (check-page-read)
  (dispatch transport-no-evcp md)
     ;Read through the evcp.
  ((m-2) q-cdr-code md)
  ((vma-start-read) q-pointer md)
  (check-page-read)
  (dispatch transport md)
     ;Insert old cdr-codes into new values.
  ((m-tem) md)
  ((md) dpb m-2 q-cdr-code a-tem)
     ;Write it back.
  ((vma-start-write) pdl-pop)
  (check-page-write)
  (gc-write-test)
     ;Loop until done.
  (jump-not-equal m-2 (a-constant (eval cdr-nil))
		  closure-prepare-to-pop-snap-first-frame)


  (call find-list-of-lexical-frame-copies)
     ;Quit if no copies, m-j gets top of original.
  (popj-equal-xct-next c-pdl-buffer-index a-v-nil)
 ((m-t) c-pdl-buffer-index)
  ((m-j) dpb m-j q-pointer (a-constant (byte-value q-data-type dtp-external-value-cell-pointer)))
     ;Setup M-K to point to beginning of args and locals of this stack
     ;frame.
  (call-xct-next convert-pdl-buffer-address)
 ((m-k) m-ap)
  ((m-k) dpb m-k q-pointer
	 (a-constant (byte-value q-data-type
				 dtp-external-value-cell-pointer)))
     ;Setup m-e to point to end of args and locals of this stack frame.
  ((pdl-index) sub pdl-index a-ap)
  ((m-e) m+a+1 pdl-index a-k)

1closure-prepare-to-pop-unshare-all-frames*
     ;If we are at the end, we quit.
  (popj-equal m-t a-v-nil)
     ;Spread the car and cdr.
  (call carcdr-no-sb)
     ;Bash the evcp to the stack frame with a nil.
  ((vma m-a) sub m-a (a-constant 1))
  ((m-tem) a-v-nil)
  ((md-start-write) dpb m-tem q-typed-pointer (a-constant (byte-value q-cdr-code cdr-next)))
  (check-page-write)
  (gc-write-test)

1closure-prepare-to-pop-unshare-one-frame*
     ;Read the next element in the frame.
  ((vma-start-read) add vma (a-constant 1))
  (check-page-read)
  ((m-2) q-typed-pointer md)
  ((m-1) q-cdr-code md)
     ;If it doesn't point to the stack, we don't unshare it.
  (jump-less-than m-2 a-k closure-prepare-to-pop-already-unshared)
  (jump-greater-or-equal m-2 a-e closure-prepare-to-pop-already-unshared)
     ;Make up a pointer to the right location.
  ((m-2) sub vma a-a)
  ((m-2) add m-2 a-j)
     ;Write it back.
  ((md-start-write) dpb m-1 q-cdr-code a-2)
  (check-page-write)
  (gc-write-test)

1closure-prepare-to-pop-already-unshared*
     ;If we hit the cdr-nil, we are done.  If we don't have cdr-next,
     ;something is very wrong.
  (jump-equal m-1 (a-constant (eval cdr-nil))
		  closure-prepare-to-pop-unshare-all-frames)
  (jump-equal m-1 (a-constant (eval cdr-next))
	      closure-prepare-to-pop-unshare-one-frame)
  (call illop)

(end-pagable-ucode)

))