[Sbcl-commits] CVS: sbcl/src/assembly/mips alloc.lisp,NONE,1.1 arith.lisp,NONE,1.1 array.lisp,NONE,1.1 assem-rtns.lisp,NONE,1.1 support.lisp,NONE,1.1

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/assembly/mips
In directory usw-pr-cvs1:/tmp/cvs-serv9122/src/assembly/mips

Added Files:
	alloc.lisp arith.lisp array.lisp assem-rtns.lisp support.lisp 
Log Message:
0.7.7.9:
	Commit MIPS backend
	... one or two modifications to extant code, as per CSR sbcl-devel
		2002-08-31
	... lots of new files


--- NEW FILE: alloc.lisp ---
(in-package "SB!VM")



--- NEW FILE: arith.lisp ---
(in-package "SB!VM")


(define-assembly-routine (generic-+
			  (:cost 10)
			  (:return-style :full-call)
			  (:translate +)
			  (:policy :safe)
			  (:save-p t))
			 ((:arg x (descriptor-reg any-reg) a0-offset)
			  (:arg y (descriptor-reg any-reg) a1-offset)

			  (:res res (descriptor-reg any-reg) a0-offset)

			  (:temp temp non-descriptor-reg nl0-offset)
			  (:temp lip interior-reg lip-offset)
			  (:temp lra descriptor-reg lra-offset)
			  (:temp nargs any-reg nargs-offset)
			  (:temp ocfp any-reg ocfp-offset))
  (inst b DO-STATIC-FUN)
  (inst nop)
  #+nil
  (progn
    (inst and temp x 3)
    (inst bne temp DO-STATIC-FUN)
    (inst and temp y 3)
    (inst bne temp DO-STATIC-FUN)
    (inst nop)
    (inst add res x y)
    (lisp-return lra lip :offset 2))

  DO-STATIC-FUN
  (inst lw lip null-tn (static-fun-offset 'two-arg-+))
  (inst li nargs (fixnumize 2))
  (inst move ocfp cfp-tn)
  (inst j lip)
  (inst move cfp-tn csp-tn))


(define-assembly-routine (generic--
			  (:cost 10)
			  (:return-style :full-call)
			  (:translate -)
			  (:policy :safe)
			  (:save-p t))
			 ((:arg x (descriptor-reg any-reg) a0-offset)
			  (:arg y (descriptor-reg any-reg) a1-offset)

			  (:res res (descriptor-reg any-reg) a0-offset)

			  (:temp temp non-descriptor-reg nl0-offset)
			  (:temp lip interior-reg lip-offset)
			  (:temp lra descriptor-reg lra-offset)
			  (:temp nargs any-reg nargs-offset)
			  (:temp ocfp any-reg ocfp-offset))
  (inst b DO-STATIC-FUN)
  (inst nop)
  #+nil
  (progn
    (inst and temp x 3)
    (inst bne temp DO-STATIC-FUN)
    (inst and temp y 3)
    (inst bne temp DO-STATIC-FUN)
    (inst nop)
    (inst sub res x y)
    (lisp-return lra lip :offset 2))

  DO-STATIC-FUN
  (inst lw lip null-tn (static-fun-offset 'two-arg--))
  (inst li nargs (fixnumize 2))
  (inst move ocfp cfp-tn)
  (inst j lip)
  (inst move cfp-tn csp-tn))


(define-assembly-routine (generic-*
			  (:cost 25)
			  (:return-style :full-call)
			  (:translate *)
			  (:policy :safe)
			  (:save-p t))
			 ((:arg x (descriptor-reg any-reg) a0-offset)
			  (:arg y (descriptor-reg any-reg) a1-offset)

			  (:res res (descriptor-reg any-reg) a0-offset)

			  (:temp temp non-descriptor-reg nl0-offset)
			  (:temp lo non-descriptor-reg nl1-offset)
			  (:temp hi non-descriptor-reg nl2-offset)
			  (:temp pa-flag non-descriptor-reg nl4-offset)
			  (:temp lip interior-reg lip-offset)
			  (:temp lra descriptor-reg lra-offset)
			  (:temp nargs any-reg nargs-offset)
			  (:temp ocfp any-reg ocfp-offset))
  ;; If either arg is not a fixnum, call the static function.
  (inst and temp x 3)
  (inst bne temp DO-STATIC-FUN)
  (inst and temp y 3)
  (inst bne temp DO-STATIC-FUN)
  (inst nop)

  ;; Remove the tag from one arg so that the result will have the correct
  ;; fixnum tag.
  (inst sra temp x 2)
  (inst mult temp y)
  (inst mflo res)
  (inst mfhi hi)
  ;; Check to see if the result will fit in a fixnum.  (I.e. the high word
  ;; is just 32 copies of the sign bit of the low word).
  (inst sra temp res 31)
  (inst xor temp hi)
  (inst beq temp DONE)
  ;; Shift the double word hi:res down two bits into hi:low to get rid of the
  ;; fixnum tag.
  (inst srl lo res 2)
  (inst sll temp hi 30)
  (inst or lo temp)
  (inst sra hi 2)

  ;; Do we need one word or two?  Assume two.
  (inst sra temp lo 31)
  (inst xor temp hi)
  (inst bne temp two-words)
  ;; Assume a two word header.
  (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))

  ;; Only need one word, fix the header.
  (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))

  (pseudo-atomic (pa-flag :extra (pad-data-block (+ 1 bignum-digits-offset)))
    (inst or res alloc-tn other-pointer-lowtag)
    (storew temp res 0 other-pointer-lowtag))

  (storew lo res bignum-digits-offset other-pointer-lowtag)

  ;; Out of here
  (lisp-return lra lip :offset 2)


  TWO-WORDS
  (pseudo-atomic (pa-flag :extra (pad-data-block (+ 2 bignum-digits-offset)))
    (inst or res alloc-tn other-pointer-lowtag)
    (storew temp res 0 other-pointer-lowtag))

  (storew lo res bignum-digits-offset other-pointer-lowtag)
  (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)

  ;; Out of here
  (lisp-return lra lip :offset 2)


  DO-STATIC-FUN
  (inst lw lip null-tn (static-fun-offset 'two-arg-*))
  (inst li nargs (fixnumize 2))
  (inst move ocfp cfp-tn)
  (inst j lip)
  (inst move cfp-tn csp-tn)

  DONE)



;;;; Comparison routines.

(macrolet
    ((define-cond-assem-rtn (name translate static-fn cmp not-p)
       `(define-assembly-routine (,name
				  (:cost 10)
				  (:return-style :full-call)
				  (:policy :safe)
				  (:translate ,translate)
				  (:save-p t))
				 ((:arg x (descriptor-reg any-reg) a0-offset)
				  (:arg y (descriptor-reg any-reg) a1-offset)
				  
				  (:res res descriptor-reg a0-offset)
				  
				  (:temp temp non-descriptor-reg nl0-offset)
				  (:temp lip interior-reg lip-offset)
				  (:temp nargs any-reg nargs-offset)
				  (:temp ocfp any-reg ocfp-offset))
	  (inst and temp x 3)
	  (inst bne temp DO-STATIC-FN)
	  (inst and temp y 3)
	  (inst beq temp DO-COMPARE)
	  ,cmp
	  
	  DO-STATIC-FN
	  (inst lw lip null-tn (static-fun-offset ',static-fn))
	  (inst li nargs (fixnumize 2))
	  (inst move ocfp cfp-tn)
	  (inst j lip)
	  (inst move cfp-tn csp-tn)
	  
	  DO-COMPARE
	  (inst ,(if not-p 'bne 'beq) temp done)
	  (inst move res null-tn)
	  (load-symbol res t)
	  DONE)))

  (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y) nil)
  (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x) nil))


(define-assembly-routine (generic-eql
			  (:cost 10)
			  (:return-style :full-call)
			  (:policy :safe)
			  (:translate eql)
			  (:save-p t))
			 ((:arg x (descriptor-reg any-reg) a0-offset)
			  (:arg y (descriptor-reg any-reg) a1-offset)
			  
			  (:res res descriptor-reg a0-offset)
			  
			  (:temp temp non-descriptor-reg nl0-offset)
			  (:temp lip interior-reg lip-offset)
			  (:temp lra descriptor-reg lra-offset)
			  (:temp nargs any-reg nargs-offset)
			  (:temp ocfp any-reg ocfp-offset))
  (inst beq x y RETURN-T)
  (inst and temp x 3)
  (inst beq temp RETURN-NIL)
  (inst and temp y 3)
  (inst bne temp DO-STATIC-FN)
  (inst nop)

  RETURN-NIL
  (inst move res null-tn)
  (lisp-return lra lip :offset 2)

  DO-STATIC-FN
  (inst lw lip null-tn (static-fun-offset 'eql))
  (inst li nargs (fixnumize 2))
  (inst move ocfp cfp-tn)
  (inst j lip)
  (inst move cfp-tn csp-tn)

  RETURN-T
  (load-symbol res t))

(define-assembly-routine (generic-=
			  (:cost 10)
			  (:return-style :full-call)
			  (:policy :safe)
			  (:translate =)
			  (:save-p t))
			 ((:arg x (descriptor-reg any-reg) a0-offset)
			  (:arg y (descriptor-reg any-reg) a1-offset)
			  
			  (:res res descriptor-reg a0-offset)
			  
			  (:temp temp non-descriptor-reg nl0-offset)
			  (:temp lip interior-reg lip-offset)
			  (:temp lra descriptor-reg lra-offset)
			  (:temp nargs any-reg nargs-offset)
			  (:temp ocfp any-reg ocfp-offset))
  (inst and temp x 3)
  (inst bne temp DO-STATIC-FN)
  (inst and temp y 3)
  (inst bne temp DO-STATIC-FN)
  (inst nop)
  (inst beq x y RETURN-T)

  (inst move res null-tn)
  (lisp-return lra lip :offset 2)

  DO-STATIC-FN
  (inst lw lip null-tn (static-fun-offset 'two-arg-=))
  (inst li nargs (fixnumize 2))
  (inst move ocfp cfp-tn)
  (inst j lip)
  (inst move cfp-tn csp-tn)

  RETURN-T
  (load-symbol res t))

(define-assembly-routine (generic-/=
			  (:cost 10)
			  (:return-style :full-call)
			  (:policy :safe)
			  (:translate /=)
			  (:save-p t))
			 ((:arg x (descriptor-reg any-reg) a0-offset)
			  (:arg y (descriptor-reg any-reg) a1-offset)
			  
			  (:res res descriptor-reg a0-offset)
			  
			  (:temp temp non-descriptor-reg nl0-offset)
			  (:temp lip interior-reg lip-offset)
			  (:temp lra descriptor-reg lra-offset)
			  (:temp nargs any-reg nargs-offset)
			  (:temp ocfp any-reg ocfp-offset))
  (inst and temp x 3)
  (inst bne temp DO-STATIC-FN)
  (inst and temp y 3)
  (inst bne temp DO-STATIC-FN)
  (inst nop)
  (inst beq x y RETURN-NIL)

  (load-symbol res t)
  (lisp-return lra lip :offset 2)

  DO-STATIC-FN
  (inst lw lip null-tn (static-fun-offset 'two-arg-=))
  (inst li nargs (fixnumize 2))
  (inst move ocfp cfp-tn)
  (inst j lip)
  (inst move cfp-tn csp-tn)

  RETURN-NIL
  (inst move res null-tn))

--- NEW FILE: array.lisp ---
(in-package "SB!VM")

(define-assembly-routine (allocate-vector
			  (:policy :fast-safe)
			  (:translate allocate-vector)
			  (:arg-types positive-fixnum
				      positive-fixnum
				      positive-fixnum))
			 ((:arg type any-reg a0-offset)
			  (:arg length any-reg a1-offset)
			  (:arg words any-reg a2-offset)
			  (:res result descriptor-reg a0-offset)

			  (:temp ndescr non-descriptor-reg nl0-offset)
			  (:temp pa-flag non-descriptor-reg nl4-offset))
  ;; This is kinda sleezy, changing words like this.  But we can because
  ;; the vop thinks it is temporary.
  (inst addu words (+ (1- (ash 1 n-lowtag-bits))
		      (* vector-data-offset n-word-bytes)))
  (inst li ndescr (lognot lowtag-mask))
  (inst and words ndescr)
  (inst srl ndescr type word-shift)

  (pseudo-atomic (pa-flag)
    (inst or result alloc-tn other-pointer-lowtag)
    (inst addu alloc-tn words)
    (storew ndescr result 0 other-pointer-lowtag)
    (storew length result vector-length-slot other-pointer-lowtag)))


;;;; Hash primitives

(define-assembly-routine (sxhash-simple-string
			  (:translate %sxhash-simple-string)
			  (:policy :fast-safe)
			  (:result-types positive-fixnum))
			 ((:arg string descriptor-reg a0-offset)
			  (:res result any-reg a0-offset)

			  (:temp length any-reg a1-offset)

			  (:temp lip interior-reg lip-offset)
			  (:temp accum non-descriptor-reg nl0-offset)
			  (:temp data non-descriptor-reg nl1-offset)
			  (:temp byte non-descriptor-reg nl2-offset)
			  (:temp retaddr non-descriptor-reg nl3-offset))

  ;; These are needed after we jump into sxhash-simple-substring.
  ;;
  ;; FIXME: *BOGGLE* -- CSR, 2002-08-22
  (progn result lip accum data byte retaddr)

  (inst j (make-fixup 'sxhash-simple-substring :assembly-routine))
  (loadw length string vector-length-slot other-pointer-lowtag))

(define-assembly-routine (sxhash-simple-substring
			  (:translate %sxhash-simple-substring)
			  (:policy :fast-safe)
			  (:arg-types * positive-fixnum)
			  (:result-types positive-fixnum))
			 ((:arg string descriptor-reg a0-offset)
			  (:arg length any-reg a1-offset)
			  (:res result any-reg a0-offset)

			  (:temp lip interior-reg lip-offset)
			  (:temp accum non-descriptor-reg nl0-offset)
			  (:temp data non-descriptor-reg nl1-offset)
			  (:temp byte non-descriptor-reg nl2-offset)
			  (:temp retaddr non-descriptor-reg nl3-offset))

  ;; Save the return address
  (inst subu retaddr lip code-tn)

  ;; Get a pointer to the data.
  (inst addu lip string
	(- (* vector-data-offset n-word-bytes) other-pointer-lowtag))
  (inst b test)
  (move accum zero-tn)

  loop

  (inst and byte data #xff)
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  (inst srl byte data 8)
  (inst and byte byte #xff)
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  (inst srl byte data 16)
  (inst and byte byte #xff)
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  (inst srl byte data 24)
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  (inst addu lip lip 4)

  test

  (inst addu length length (fixnumize -4))
  (inst lw data lip 0)
  (inst bgez length loop)
  (inst nop)

  (inst addu length length (fixnumize 3))
  (inst beq length zero-tn one-more)
  (inst addu length length (fixnumize -1))
  (inst beq length zero-tn two-more)
  (inst addu length length (fixnumize -1))
  (inst bne length zero-tn done)
  (inst nop)

  (ecase *backend-byte-order*
    (:big-endian (inst srl byte data 8))
    (:little-endian (inst srl byte data 16)))
  (inst and byte byte #xff)
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  two-more

  (ecase *backend-byte-order*
    (:big-endian (inst srl byte data 16))
    (:little-endian (inst srl byte data 8)))
  (inst and byte byte #xff)
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  one-more

  (when (eq *backend-byte-order* :big-endian)
    (inst srl data data 24))
  (inst and byte data #xff)
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  done

  (inst sll result accum 5)
  (inst srl result result 3)

  ;; Restore the return address.
  (inst addu lip code-tn retaddr))

--- NEW FILE: assem-rtns.lisp ---
(in-package "SB!VM")


;;;; Return-multiple with other than one value

#+sb-assembling ;; we don't want a vop for this one.
(define-assembly-routine
    (return-multiple
     (:return-style :none))

     ;; These four are really arguments.
    ((:temp nvals any-reg nargs-offset)
     (:temp vals any-reg nl0-offset)
     (:temp ocfp any-reg nl1-offset)
     (:temp lra descriptor-reg lra-offset)

     ;; These are just needed to facilitate the transfer
     (:temp lip interior-reg lip-offset)
     (:temp count any-reg nl2-offset)
     (:temp dst any-reg nl4-offset)
     (:temp temp descriptor-reg l0-offset)

     ;; These are needed so we can get at the register args.
     (:temp a0 descriptor-reg a0-offset)
     (:temp a1 descriptor-reg a1-offset)
     (:temp a2 descriptor-reg a2-offset)
     (:temp a3 descriptor-reg a3-offset)
     (:temp a4 descriptor-reg a4-offset)
     (:temp a5 descriptor-reg a5-offset))

  ;; Note, because of the way the return-multiple vop is written, we can
  ;; assume that we are never called with nvals == 1 and that a0 has already
  ;; been loaded.
  (inst blez nvals default-a0-and-on)
  (inst subu count nvals (fixnumize 2))
  (inst blez count default-a2-and-on)
  (inst lw a1 vals (* 1 n-word-bytes))
  (inst subu count (fixnumize 1))
  (inst blez count default-a3-and-on)
  (inst lw a2 vals (* 2 n-word-bytes))
  (inst subu count (fixnumize 1))
  (inst blez count default-a4-and-on)
  (inst lw a3 vals (* 3 n-word-bytes))
  (inst subu count (fixnumize 1))
  (inst blez count default-a5-and-on)
  (inst lw a4 vals (* 4 n-word-bytes))
  (inst subu count (fixnumize 1))
  (inst blez count done)
  (inst lw a5 vals (* 5 n-word-bytes))

  ;; Copy the remaining args to the top of the stack.
  (inst addu vals vals (* 6 n-word-bytes))
  (inst addu dst cfp-tn (* 6 n-word-bytes))

  LOOP
  (inst lw temp vals)
  (inst addu vals n-word-bytes)
  (inst sw temp dst)
  (inst subu count (fixnumize 1))
  (inst bne count zero-tn loop)
  (inst addu dst n-word-bytes)
		
  (inst b done)
  (inst nop)

  DEFAULT-A0-AND-ON
  (inst move a0 null-tn)
  (inst move a1 null-tn)
  DEFAULT-A2-AND-ON
  (inst move a2 null-tn)
  DEFAULT-A3-AND-ON
  (inst move a3 null-tn)
  DEFAULT-A4-AND-ON
  (inst move a4 null-tn)
  DEFAULT-A5-AND-ON
  (inst move a5 null-tn)
  DONE
  
  ;; Clear the stack.
  (move ocfp-tn cfp-tn)
  (move cfp-tn ocfp)
  (inst addu csp-tn ocfp-tn nvals)
  
  ;; Return.
  (lisp-return lra lip))


;;;; tail-call-variable.

#+sb-assembling ;; no vop for this one either.
(define-assembly-routine
    (tail-call-variable
     (:return-style :none))

    ;; These are really args.
    ((:temp args any-reg nl0-offset)
     (:temp lexenv descriptor-reg lexenv-offset)

     ;; We need to compute this
     (:temp nargs any-reg nargs-offset)

     ;; These are needed by the blitting code.
     (:temp src any-reg nl1-offset)
     (:temp dst any-reg nl2-offset)
     (:temp count any-reg cfunc-offset)
     (:temp temp descriptor-reg l0-offset)

     ;; Needed for the jump
     (:temp lip interior-reg lip-offset)

     ;; These are needed so we can get at the register args.
     (:temp a0 descriptor-reg a0-offset)
     (:temp a1 descriptor-reg a1-offset)
     (:temp a2 descriptor-reg a2-offset)
     (:temp a3 descriptor-reg a3-offset)
     (:temp a4 descriptor-reg a4-offset)
     (:temp a5 descriptor-reg a5-offset))


  ;; Calculate NARGS (as a fixnum)
  (inst subu nargs csp-tn args)
     
  ;; Load the argument regs (must do this now, 'cause the blt might
  ;; trash these locations)
  (inst lw a0 args (* 0 n-word-bytes))
  (inst lw a1 args (* 1 n-word-bytes))
  (inst lw a2 args (* 2 n-word-bytes))
  (inst lw a3 args (* 3 n-word-bytes))
  (inst lw a4 args (* 4 n-word-bytes))
  (inst lw a5 args (* 5 n-word-bytes))

  ;; Calc SRC, DST, and COUNT
  (inst addu count nargs (fixnumize (- register-arg-count)))
  (inst blez count done)
  (inst addu src args (* n-word-bytes register-arg-count))
  (inst addu dst cfp-tn (* n-word-bytes register-arg-count))
	
  LOOP
  ;; Copy one arg.
  (inst lw temp src)
  (inst addu src src n-word-bytes)
  (inst sw temp dst)
  (inst addu count (fixnumize -1))
  (inst bgtz count loop)
  (inst addu dst dst n-word-bytes)
	
  DONE
  ;; We are done.  Do the jump.
  (progn
    (loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
    (lisp-jump temp lip)))


;;;; Non-local exit noise.

(define-assembly-routine
    (unwind
     (:translate %continue-unwind)
     (:policy :fast-safe))
    ((:arg block (any-reg descriptor-reg) a0-offset)
     (:arg start (any-reg descriptor-reg) ocfp-offset)
     (:arg count (any-reg descriptor-reg) nargs-offset)
     (:temp lip interior-reg lip-offset)
     (:temp lra descriptor-reg lra-offset)
     (:temp cur-uwp any-reg nl0-offset)
     (:temp next-uwp any-reg nl1-offset)
     (:temp target-uwp any-reg nl2-offset))
  (declare (ignore start count))

  (let ((error (generate-error-code nil invalid-unwind-error)))
    (inst beq block zero-tn error))
  
  (load-symbol-value cur-uwp *current-unwind-protect-block*)
  (loadw target-uwp block unwind-block-current-uwp-slot)
  (inst bne cur-uwp target-uwp do-uwp)
  (inst nop)
      
  (move cur-uwp block)

  do-exit
      
  (loadw cfp-tn cur-uwp unwind-block-current-cont-slot)
  (loadw code-tn cur-uwp unwind-block-current-code-slot)
  (progn
    (loadw lra cur-uwp unwind-block-entry-pc-slot)
    (lisp-return lra lip :frob-code nil))

  do-uwp

  (loadw next-uwp cur-uwp unwind-block-current-uwp-slot)
  (inst b do-exit)
  (store-symbol-value next-uwp *current-unwind-protect-block*))

(define-assembly-routine
    throw
    ((:arg target descriptor-reg a0-offset)
     (:arg start any-reg ocfp-offset)
     (:arg count any-reg nargs-offset)
     (:temp catch any-reg a1-offset)
     (:temp tag descriptor-reg a2-offset))
  
  (progn start count) ; We just need them in the registers.

  (load-symbol-value catch *current-catch-block*)
  
  loop
  
  (let ((error (generate-error-code nil unseen-throw-tag-error target)))
    (inst beq catch zero-tn error)
    (inst nop))
  
  (loadw tag catch catch-block-tag-slot)
  (inst beq tag target exit)
  (inst nop)
  (loadw catch catch catch-block-previous-catch-slot)
  (inst b loop)
  (inst nop)
  
  exit
  
  (move target catch)
  (inst j (make-fixup 'unwind :assembly-routine))
  (inst nop))

--- NEW FILE: support.lisp ---
(in-package "SB!VM")

(!def-vm-support-routine generate-call-sequence (name style vop)
  (ecase style
    (:raw
     (values
      `((inst jal (make-fixup ',name :assembly-routine))
	(inst nop))
      `()))
    (:full-call
     (let ((temp (make-symbol "TEMP"))
	   (nfp-save (make-symbol "NFP-SAVE"))
	   (lra (make-symbol "LRA")))
       (values
	`((let ((lra-label (gen-label))
		(cur-nfp (current-nfp-tn ,vop)))
	    (when cur-nfp
	      (store-stack-tn ,nfp-save cur-nfp))
	    (inst compute-lra-from-code ,lra code-tn lra-label ,temp)
	    (note-next-instruction ,vop :call-site)
	    (inst j (make-fixup ',name :assembly-routine))
	    (inst nop)
	    (emit-return-pc lra-label)
	    (note-this-location ,vop :single-value-return)
	    (without-scheduling ()
	      (move csp-tn ocfp-tn)
	      (inst nop))
	    (inst compute-code-from-lra code-tn code-tn
		  lra-label ,temp)
	    (when cur-nfp
	      (load-stack-tn cur-nfp ,nfp-save))))
	`((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
		      ,temp)
	  (:temporary (:sc descriptor-reg :offset lra-offset
		       :from (:eval 0) :to (:eval 1))
		      ,lra)
	  (:temporary (:scs (control-stack) :offset nfp-save-offset)
		      ,nfp-save)
	  (:save-p t)))))
    (:none
     (values
      `((inst j (make-fixup ',name :assembly-routine))
	(inst nop))
      nil))))


(!def-vm-support-routine generate-return-sequence (style)
  (ecase style
    (:raw
     `((inst j lip-tn)
       (inst nop)))
    (:full-call
     `((lisp-return (make-random-tn :kind :normal
				    :sc (sc-or-lose
					 'descriptor-reg)
				    :offset lra-offset)
		    lip-tn :offset 2)))
    (:none)))