1.0.24.22: mudball of VOP updates for HPPA (0d74ed47) · Commits · Christophe Rhodes / sbcl

src/assembly/hppa/arith.lisp

+54 −23

Original line number	Diff line number	Diff line
		@@ -49,8 +49,6 @@
		(inst xor res sign res)
		(inst add res sign res))


		#+sb-assembling
		(define-assembly-routine
		(truncate)
		((:arg dividend signed-reg nl0-offset)
		@@ -58,7 +56,6 @@

		(:res quo signed-reg nl2-offset)
		(:res rem signed-reg nl3-offset))

		;; Move abs(divident) into quo.
		(inst move dividend quo :>=)
		(inst sub zero-tn quo quo)
		@@ -87,7 +84,6 @@
		(inst move dividend zero-tn :>=)
		(inst sub zero-tn rem rem))



		;;;; Generic arithmetic.

		@@ -99,26 +95,43 @@
		(: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 lip interior-reg lip-offset)
		(:temp temp non-descriptor-reg nl0-offset)
		(:temp temp1 non-descriptor-reg nl1-offset)
		(:temp temp2 non-descriptor-reg nl2-offset)
		(:temp lra descriptor-reg lra-offset)
		(:temp lip interior-reg lip-offset)
		(:temp nargs any-reg nargs-offset)
		(:temp ocfp any-reg ocfp-offset))
		(inst extru x 31 2 zero-tn :=)
		(inst b do-static-fun :nullify t)
		(inst extru y 31 2 zero-tn :=)
		(inst b do-static-fun :nullify t)
		(inst addo x y res)
		;; If either arg is not fixnum, use two-arg-+ to summarize
		(inst or x y temp)
		(inst extru temp 31 3 zero-tn :=)
		(inst b DO-STATIC-FUN :nullify t)
		;; check for overflow
		(inst add x y temp)
		(inst xor temp x temp1)
		(inst xor temp y temp2)
		(inst and temp1 temp2 temp1)
		(inst bc :< nil temp1 zero-tn DO-OVERFLOW)
		(inst move temp res)
		(lisp-return lra :offset 1)

		DO-OVERFLOW
		;; We did overflow, so do the bignum version
		(inst sra x n-fixnum-tag-bits temp1)
		(inst sra y n-fixnum-tag-bits temp2)
		(inst add temp1 temp2 temp)
		(with-fixed-allocation (res nil temp2 bignum-widetag
		(1+ bignum-digits-offset) nil)
		(storew temp res bignum-digits-offset other-pointer-lowtag))
		(lisp-return lra :offset 1)

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

		(define-assembly-routine (generic--
		(:cost 10)
		@@ -131,24 +144,42 @@

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

		(:temp lip interior-reg lip-offset)
		(:temp temp non-descriptor-reg nl0-offset)
		(:temp temp1 non-descriptor-reg nl1-offset)
		(:temp temp2 non-descriptor-reg nl2-offset)
		(:temp lra descriptor-reg lra-offset)
		(:temp lip interior-reg lip-offset)
		(:temp nargs any-reg nargs-offset)
		(:temp ocfp any-reg ocfp-offset))
		(inst extru x 31 2 zero-tn :=)
		(inst b do-static-fun :nullify t)
		(inst extru y 31 2 zero-tn :=)
		(inst b do-static-fun :nullify t)
		(inst subo x y res)
		;; If either arg is not fixnum, use two-arg-+ to summarize
		(inst or x y temp)
		(inst extru temp 31 3 zero-tn :=)
		(inst b DO-STATIC-FUN :nullify t)
		(inst sub x y temp)
		;; check for overflow
		(inst xor x y temp1)
		(inst xor x temp temp2)
		(inst and temp2 temp1 temp1)
		(inst bc :< nil temp1 zero-tn DO-OVERFLOW)
		(inst move temp res)
		(lisp-return lra :offset 1)

		DO-OVERFLOW
		;; We did overflow, so do the bignum version
		(inst sra x n-fixnum-tag-bits temp1)
		(inst sra y n-fixnum-tag-bits temp2)
		(inst sub temp1 temp2 temp)
		(with-fixed-allocation (res nil temp2 bignum-widetag
		(1+ bignum-digits-offset) nil)
		(storew temp res bignum-digits-offset other-pointer-lowtag))
		(lisp-return lra :offset 1)

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

		(move csp-tn cfp-tn t))


		;;;; Comparison routines.

src/assembly/hppa/array.lisp

+0 −68

Original line number	Diff line number	Diff line
		(in-package "SB!VM")

		;;;; Hash primitives

		;;; FIXME: This looks kludgy bad and wrong.
		#+sb-assembling
		(defparameter sxhash-simple-substring-entry (gen-label))

		(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 accum non-descriptor-reg nl0-offset)
		(:temp data non-descriptor-reg nl1-offset)
		(:temp offset non-descriptor-reg nl2-offset))

		(declare (ignore result accum data offset))

		;; Save the return address.
		(inst b sxhash-simple-substring-entry)
		(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 accum non-descriptor-reg nl0-offset)
		(:temp data non-descriptor-reg nl1-offset)
		(:temp offset non-descriptor-reg nl2-offset))

		(emit-label sxhash-simple-substring-entry)

		(inst li (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) offset)
		(inst b test)
		(move zero-tn accum)

		LOOP
		(inst xor accum data accum)
		(inst shd accum accum 5 accum)

		TEST
		(inst ldwx offset string data)
		(inst addib :>= (fixnumize -4) length loop)
		(inst addi (fixnumize 1) offset offset)

		(inst addi (fixnumize 4) length length)
		(inst comb := zero-tn length done :nullify t)
		(inst sub zero-tn length length)
		(inst sll length 1 length)
		(inst mtctl length :sar)
		(inst shd zero-tn data :variable data)
		(inst xor accum data accum)

		DONE

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

src/assembly/hppa/assem-rtns.lisp

+87 −76

Original line number	Diff line number	Diff line
		(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 old-fp any-reg nl1-offset)
		(:temp ocfp any-reg nl1-offset)
		(:temp lra descriptor-reg lra-offset)

		;; These are just needed to facilitate the transfer
		(:temp count any-reg nl2-offset)
		(:temp src any-reg nl3-offset)
		(:temp dst any-reg nl4-offset)
		(:temp dst any-reg nl3-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)
		@@ -27,55 +22,48 @@
		(:temp a3 descriptor-reg a3-offset)
		(:temp a4 descriptor-reg a4-offset)
		(:temp a5 descriptor-reg a5-offset))

		(inst movb := nvals count default-a0-and-on :nullify t)
		(loadw a0 vals 0)
		(inst addib := (fixnumize -1) count default-a1-and-on :nullify t)
		(loadw a1 vals 1)
		(inst addib := (fixnumize -1) count default-a2-and-on :nullify t)
		(loadw a2 vals 2)
		(inst addib := (fixnumize -1) count default-a3-and-on :nullify t)
		(loadw a3 vals 3)
		(inst addib := (fixnumize -1) count default-a4-and-on :nullify t)
		(loadw a4 vals 4)
		(inst addib := (fixnumize -1) count default-a5-and-on :nullify t)
		(loadw a5 vals 5)
		(inst addib := (fixnumize -1) count done :nullify t)

		;; 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. ;FIX-lav: look at old hppa , replace comb+addi with addib
		(inst comb :<= nvals zero-tn DEFAULT-A0-AND-ON)
		(inst addi (- (fixnumize 2)) nvals count)
		(inst comb :<= count zero-tn DEFAULT-A2-AND-ON)
		(inst ldw (* 1 n-word-bytes) vals a1)
		(inst addib :<= (- (fixnumize 1)) count DEFAULT-A3-AND-ON)
		(inst ldw (* 2 n-word-bytes) vals a2)
		(inst addib :<= (- (fixnumize 1)) count DEFAULT-A4-AND-ON)
		(inst ldw (* 3 n-word-bytes) vals a3)
		(inst addib :<= (- (fixnumize 1)) count DEFAULT-A5-AND-ON)
		(inst ldw (* 4 n-word-bytes) vals a4)
		(inst addib :<= (- (fixnumize 1)) count done)
		(inst ldw (* 5 n-word-bytes) vals a5)
		;; Copy the remaining args to the top of the stack.
		(inst addi (* 6 n-word-bytes) vals src)
		(inst addi (* 6 n-word-bytes) cfp-tn dst)

		(inst addi (fixnumize register-arg-count) vals vals)
		(inst addi (fixnumize register-arg-count) cfp-tn dst)
		LOOP
		(inst ldwm 4 src temp)
		(inst addib :> (fixnumize -1) count loop)
		(inst stwm temp 4 dst)

		(inst b done :nullify t)
		(inst ldwm n-word-bytes vals temp)
		(inst addib :<> (- (fixnumize 1)) count LOOP)
		(inst stwm temp n-word-bytes dst)
		(inst b DONE :nullify t)

		DEFAULT-A0-AND-ON
		(inst move null-tn a0)
		DEFAULT-A1-AND-ON
		(inst move null-tn a1)
		(move null-tn a0)
		(move null-tn a1)
		DEFAULT-A2-AND-ON
		(inst move null-tn a2)
		(move null-tn a2)
		DEFAULT-A3-AND-ON
		(inst move null-tn a3)
		(move null-tn a3)
		DEFAULT-A4-AND-ON
		(inst move null-tn a4)
		(move null-tn a4)
		DEFAULT-A5-AND-ON
		(inst move null-tn a5)

		(move null-tn a5)
		DONE
		;; Clear the stack.
		(move cfp-tn ocfp-tn)
		(move old-fp cfp-tn)
		(move ocfp cfp-tn)
		(inst add ocfp-tn nvals csp-tn)

		;; Return.
		(lisp-return lra))



		;;;; tail-call-variable.

		@@ -83,20 +71,16 @@
		(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 nl3-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)
		@@ -104,11 +88,8 @@
		(:temp a3 descriptor-reg a3-offset)
		(:temp a4 descriptor-reg a4-offset)
		(:temp a5 descriptor-reg a5-offset))


		;; Calculate NARGS (as a fixnum)
		(inst sub csp-tn args nargs)

		;; Load the argument regs (must do this now, 'cause the blt might
		;; trash these locations)
		(loadw a0 args 0)
		@@ -117,35 +98,28 @@
		(loadw a3 args 3)
		(loadw a4 args 4)
		(loadw a5 args 5)

		;; Calc SRC, DST, and COUNT
		(inst addi (fixnumize (- register-arg-count)) nargs count)
		(inst comb :<= count zero-tn done :nullify t)
		(inst addi (* n-word-bytes register-arg-count) args src)
		(inst addi (* n-word-bytes register-arg-count) cfp-tn dst)

		(inst addi (- (fixnumize register-arg-count)) nargs count)
		(inst comb :<= count zero-tn done)
		(inst addi (fixnumize register-arg-count) args src)
		(inst addi (fixnumize register-arg-count) cfp-tn dst)
		LOOP
		;; Copy one arg.
		(inst ldwm 4 src temp)
		(inst addib :> (fixnumize -1) count loop)
		(inst stwm temp 4 dst)

		;; Copy one arg and increase src
		(inst ldwm n-word-bytes src temp)
		(inst addib :<> (- (fixnumize 1)) count LOOP)
		(inst stwm temp n-word-bytes dst)
		DONE
		;; We are done. Do the jump.
		(loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
		(lisp-jump temp))



		;;;; Non-local exit noise.

		;;; FIXME: Really?
		#+sb-assembling
		(defparameter unwind-entry-point (gen-label))

		(define-assembly-routine
		(unwind
		(:translate %continue-unwind)
		(:return-style :none)
		(:policy :fast-safe))
		((:arg block (any-reg descriptor-reg) a0-offset)
		(:arg start (any-reg descriptor-reg) ocfp-offset)
		@@ -156,38 +130,36 @@
		(:temp target-uwp any-reg nl2-offset))
		(declare (ignore start count))

		(emit-label unwind-entry-point)

		(let ((error (generate-error-code nil invalid-unwind-error)))
		(inst bc := nil block zero-tn error))

		(load-symbol-value cur-uwp current-unwind-protect-block)
		(loadw target-uwp block unwind-block-current-uwp-slot)
		(inst bc :<> nil cur-uwp target-uwp do-uwp)
		(inst bc :<> nil cur-uwp target-uwp DO-UWP)

		(move block cur-uwp)

		DO-EXIT

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

		DO-UWP

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


		(define-assembly-routine
		throw
		(throw
		(:return-style :none))
		((: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))
		(:temp tag descriptor-reg a2-offset)
		(:temp fix descriptor-reg nl0-offset))
		(declare (ignore start count)) ; We just need them in the registers.

		(load-symbol-value catch current-catch-block)
		@@ -196,11 +168,50 @@
		(let ((error (generate-error-code nil unseen-throw-tag-error target)))
		(inst bc := nil catch zero-tn error))
		(loadw tag catch catch-block-tag-slot)
		(inst comb :<> tag target loop :nullify t)
		(inst comb := tag target EXIT :nullify t)
		(inst b LOOP)
		(loadw catch catch catch-block-previous-catch-slot)
		EXIT
		(let ((fixup (make-fixup 'unwind :assembly-routine)))
		(inst ldil fixup fix)
		(inst ble fixup lisp-heap-space fix))
		(move catch target t))

		; we need closure-tramp and funcallable-instance-tramp in
		; same space as other lisp-code, because caller is doing
		; normal lisp-calls where we doesnt specify space.
		; if we doesnt have the lisp-function (code from defun, closure, lambda etc..)
		; machine-address, resolve it here and jump to it.
		(define-assembly-routine
		(closure-tramp (:return-style :none))
		((:temp lip interior-reg lip-offset)
		(:temp nl0 descriptor-reg nl0-offset))
		(inst ldw (- (* fdefn-fun-slot n-word-bytes)
		other-pointer-lowtag)
		fdefn-tn lexenv-tn)
		(inst ldw (- (* closure-fun-slot n-word-bytes)
		fun-pointer-lowtag)
		lexenv-tn nl0)
		(inst addi (- (* simple-fun-code-offset n-word-bytes)
		fun-pointer-lowtag)
		nl0 lip)
		(inst bv lip :nullify t))

		(inst b unwind-entry-point)
		(inst move catch target))
		(define-assembly-routine
		(funcallable-instance-tramp (:return-style :none))
		nil
		(inst nop)
		(inst nop)
		(inst nop)
		(inst nop)
		(inst nop)
		(inst ldw 3 lexenv-tn lexenv-tn)
		(inst ldw (- (* closure-fun-slot n-word-bytes)
		fun-pointer-lowtag)
		lexenv-tn code-tn)
		(inst addi (- (* simple-fun-code-offset n-word-bytes)
		fun-pointer-lowtag) code-tn lip-tn)
		(inst bv lip-tn :nullify t))

		#!+hpux
		(define-assembly-routine

src/assembly/hppa/support.lisp

+10 −17

Original line number	Diff line number	Diff line
		@@ -13,13 +13,12 @@

		(!def-vm-support-routine generate-call-sequence (name style vop)
		(ecase style
		(:raw
		((:raw :none)
		(with-unique-names (fixup)
		(values
		`((let ((fixup (make-fixup ',name :assembly-routine)))
		(inst ldil fixup ,fixup)
		(inst ble fixup lisp-heap-space ,fixup :nullify t))
		(inst nop))
		(inst ble fixup lisp-heap-space ,fixup :nullify t)))
		`((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1))
		,fixup)))))
		(:full-call
		@@ -32,13 +31,15 @@
		(when cur-nfp
		(store-stack-tn ,nfp-save cur-nfp))
		(inst compute-lra-from-code code-tn lra-label ,temp ,lra)
		(note-this-location ,vop :call-site)
		(note-next-instruction ,vop :call-site)
		(let ((fixup (make-fixup ',name :assembly-routine)))
		(inst ldil fixup ,temp)
		(inst be fixup lisp-heap-space ,temp :nullify t))
		(without-scheduling ()
		(emit-return-pc lra-label)
		(note-this-location ,vop :single-value-return)
		(move ocfp-tn csp-tn)
		(inst move ocfp-tn csp-tn)
		(inst nop)) ; this nop is here because of emit-return-pc align
		(inst compute-code-from-lra code-tn lra-label ,temp code-tn)
		(when cur-nfp
		(load-stack-tn cur-nfp ,nfp-save))))
		@@ -49,15 +50,7 @@
		,lra)
		(:temporary (:scs (control-stack) :offset nfp-save-offset)
		,nfp-save)
		(:save-p :compute-only)))))
		(:none
		(with-unique-names (fixup)
		(values
		`((let ((fixup (make-fixup ',name :assembly-routine)))
		(inst ldil fixup ,fixup)
		(inst be fixup lisp-heap-space ,fixup :nullify t)))
		`((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1))
		,fixup)))))))
		(:save-p t)))))))

		(!def-vm-support-routine generate-return-sequence (style)
		(ecase style

src/compiler/hppa/alloc.lisp

+60 −68

Original line number	Diff line number	Diff line
		@@ -10,10 +10,8 @@
		;;;; files for more information.

		(in-package "SB!VM")


		;;;; LIST and LIST*

		(define-vop (list-or-list*)
		(:args (things :more t))
		(:temporary (:scs (descriptor-reg) :type list) ptr)
		@@ -24,44 +22,47 @@
		(:results (result :scs (descriptor-reg)))
		(:variant-vars star)
		(:policy :safe)
		(:node-var node)
		(:generator 0
		(cond
		((zerop num)
		(cond ((zerop num)
		(move null-tn result))
		((and star (= num 1))
		(move (tn-ref-tn things) result))
		(t
		(macrolet
		((maybe-load (tn)
		(once-only ((tn tn))
		`(sc-case ,tn
		((any-reg descriptor-reg zero null)
		,tn)
		((store-car (tn list &optional (slot cons-car-slot))
		`(let ((reg (sc-case ,tn
		((any-reg descriptor-reg zero null) ,tn)
		(control-stack
		(load-stack-tn temp ,tn)
		temp)))))
		(let* ((cons-cells (if star (1- num) num))
		temp))))
		(storew reg ,list ,slot list-pointer-lowtag))))
		(let* ((dx-p (node-stack-allocate-p node))
		(cons-cells (if star (1- num) num))
		(alloc (* (pad-data-block cons-size) cons-cells)))
		(pseudo-atomic (:extra alloc)
		(move alloc-tn res)
		(inst dep list-pointer-lowtag 31 3 res)
		(pseudo-atomic (:extra (if dx-p 0 alloc))
		(when dx-p
		(align-csp res))
		(set-lowtag list-pointer-lowtag (if dx-p csp-tn alloc-tn) res)
		(when dx-p
		(inst addi alloc csp-tn csp-tn))
		(move res ptr)
		(dotimes (i (1- cons-cells))
		(storew (maybe-load (tn-ref-tn things)) ptr
		cons-car-slot list-pointer-lowtag)
		(store-car (tn-ref-tn things) ptr)
		(setf things (tn-ref-across things))
		(inst addi (pad-data-block cons-size) ptr ptr)
		(storew ptr ptr
		(- cons-cdr-slot cons-size)
		list-pointer-lowtag))
		(storew (maybe-load (tn-ref-tn things)) ptr
		cons-car-slot list-pointer-lowtag)
		(storew (if star
		(maybe-load (tn-ref-tn (tn-ref-across things)))
		null-tn)
		ptr cons-cdr-slot list-pointer-lowtag))
		(move res result)))))))

		(store-car (tn-ref-tn things) ptr)
		(cond (star
		(setf things (tn-ref-across things))
		(store-car (tn-ref-tn things) ptr cons-cdr-slot))
		(t
		(storew null-tn ptr
		cons-cdr-slot list-pointer-lowtag)))
		(aver (null (tn-ref-across things)))
		(move res result))))))))

		(define-vop (list list-or-list*)
		(:variant nil))
		@@ -128,33 +129,29 @@
		(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
		(:generator 100
		(inst addi (fixnumize (1+ code-trace-table-offset-slot)) boxed-arg boxed)
		(inst dep 0 31 3 boxed)
		(inst dep 0 31 n-lowtag-bits boxed)
		(inst srl unboxed-arg word-shift unboxed)
		(inst addi lowtag-mask unboxed unboxed)
		(inst dep 0 31 3 unboxed)
		(inst dep 0 31 n-lowtag-bits unboxed)
		(inst sll boxed (- n-widetag-bits word-shift) ndescr)
		(inst addi code-header-widetag ndescr ndescr)
		(pseudo-atomic ()
		;; Note: we don't have to subtract off the 4 that was added by
		;; pseudo-atomic, because depositing other-pointer-lowtag just adds
		;; it right back.
		(inst move alloc-tn result)
		(inst dep other-pointer-lowtag 31 3 result)
		(set-lowtag other-pointer-lowtag alloc-tn result)
		(inst add alloc-tn boxed alloc-tn)
		(inst add alloc-tn unboxed alloc-tn)
		(inst sll boxed (- n-widetag-bits word-shift) ndescr)
		(inst addi code-header-widetag ndescr ndescr)
		(storew ndescr result 0 other-pointer-lowtag)
		(storew unboxed result code-code-size-slot other-pointer-lowtag)
		(storew null-tn result code-entry-points-slot other-pointer-lowtag)
		(storew null-tn result code-debug-info-slot other-pointer-lowtag))))

		(define-vop (make-fdefn)
		(:translate make-fdefn)
		(:policy :fast-safe)
		(:args (name :scs (descriptor-reg) :to :eval))
		(:temporary (:scs (non-descriptor-reg)) temp)
		(:results (result :scs (descriptor-reg) :from :argument))
		(:policy :fast-safe)
		(:translate make-fdefn)
		(:generator 37
		(with-fixed-allocation (result temp fdefn-widetag fdefn-size)
		(with-fixed-allocation (result nil temp fdefn-widetag fdefn-size nil)
		(inst li (make-fixup "undefined_tramp" :foreign) temp)
		(storew name result fdefn-name-slot other-pointer-lowtag)
		(storew null-tn result fdefn-fun-slot other-pointer-lowtag)
		@@ -163,17 +160,14 @@
		(define-vop (make-closure)
		(:args (function :to :save :scs (descriptor-reg)))
		(:info length stack-allocate-p)
		(:ignore stack-allocate-p)
		(:temporary (:scs (non-descriptor-reg)) temp)
		(:results (result :scs (descriptor-reg)))
		(:generator 10
		(let ((size (+ length closure-info-offset)))
		(pseudo-atomic (:extra (pad-data-block size))
		(inst move alloc-tn result)
		(inst dep fun-pointer-lowtag 31 3 result)
		(inst li (logior (ash (1- size) n-widetag-bits) closure-header-widetag) temp)
		(storew temp result 0 fun-pointer-lowtag)
		(storew function result closure-fun-slot fun-pointer-lowtag)))))
		(with-fixed-allocation
		(result nil temp closure-header-widetag
		(+ length closure-info-offset)
		stack-allocate-p :lowtag fun-pointer-lowtag)
		(storew function result closure-fun-slot fun-pointer-lowtag))))

		;;; The compiler likes to be able to directly make value cells.
		(define-vop (make-value-cell)
		@@ -181,13 +175,10 @@
		(:temporary (:scs (non-descriptor-reg)) temp)
		(:results (result :scs (descriptor-reg)))
		(:info stack-allocate-p)
		(:ignore stack-allocate-p)
		(:generator 10
		(with-fixed-allocation
		(result temp value-cell-header-widetag value-cell-size))
		(storew value result value-cell-value-slot other-pointer-lowtag)))


		(result nil temp value-cell-header-widetag value-cell-size stack-allocate-p)
		(storew value result value-cell-value-slot other-pointer-lowtag))))

		;;;; Automatic allocators for primitive objects.

		@@ -201,7 +192,8 @@
		(:args)
		(:results (result :scs (any-reg)))
		(:generator 1
		(inst li (make-fixup "funcallable_instance_tramp" :foreign) result)))
		(inst li (make-fixup 'funcallable-instance-tramp :assembly-routine)
		result)))

		(define-vop (fixed-alloc)
		(:args)
		@@ -226,9 +218,9 @@
		(inst addi (* (1+ words) n-word-bytes) extra bytes)
		(inst sll bytes (- n-widetag-bits 2) header)
		(inst addi (+ (ash -2 n-widetag-bits) type) header header)
		(inst dep 0 31 3 bytes)
		(inst dep 0 31 n-lowtag-bits bytes)
		(pseudo-atomic ()
		(inst move alloc-tn result)
		(inst dep lowtag 31 3 result)
		(set-lowtag lowtag alloc-tn result)
		(storew header result 0 lowtag)
		(inst add alloc-tn bytes alloc-tn))))