Actually implement stack allocatable closures.
# cross-compilers!
#
# FIXME: integrate to grovel-features, mayhaps
# cross-compilers!
#
# FIXME: integrate to grovel-features, mayhaps
+ printf ' :stack-allocatable-closures' >> $ltf
$GNUMAKE -C tools-for-build determine-endianness -I src/runtime
tools-for-build/determine-endianness >> $ltf
elif [ "$sbcl_arch" = "ppc" -a "$sbcl_os" = "linux" ]; then
$GNUMAKE -C tools-for-build determine-endianness -I src/runtime
tools-for-build/determine-endianness >> $ltf
elif [ "$sbcl_arch" = "ppc" -a "$sbcl_os" = "linux" ]; then
+(defoptimizer (list stack-allocate-result) ((&rest args))
+ (not (null args)))
+(defoptimizer (list* stack-allocate-result) ((&rest args))
+ (not (null (rest args))))
(define-vop (list-or-list*)
(:args (things :more t))
(define-vop (list-or-list*)
(:args (things :more t))
(:results (result :scs (descriptor-reg)))
(:variant-vars star)
(:policy :safe)
(:results (result :scs (descriptor-reg)))
(:variant-vars star)
(:policy :safe)
(:generator 0
(cond ((zerop num)
(move result null-tn))
(:generator 0
(cond ((zerop num)
(move result null-tn))
((store-car (tn list &optional (slot cons-car-slot))
`(let ((reg
(sc-case ,tn
((store-car (tn list &optional (slot cons-car-slot))
`(let ((reg
(sc-case ,tn
- ((any-reg descriptor-reg) ,tn)
- (zero zero-tn)
- (null null-tn)
+ ((any-reg descriptor-reg zero null)
+ ,tn)
(control-stack
(load-stack-tn temp ,tn)
temp))))
(storew reg ,list ,slot list-pointer-lowtag))))
(control-stack
(load-stack-tn temp ,tn)
temp))))
(storew reg ,list ,slot list-pointer-lowtag))))
- (let ((cons-cells (if star (1- num) num)))
- (pseudo-atomic (pa-flag
- :extra (* (pad-data-block cons-size)
- cons-cells))
- (inst or res alloc-tn 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 (pa-flag :extra (if dx-p 0 alloc))
+ (when dx-p
+ (align-csp res))
+ (inst srl res (if dx-p csp-tn alloc-tn) n-lowtag-bits)
+ (inst sll res n-lowtag-bits)
+ (inst or res list-pointer-lowtag)
+ (when dx-p
+ (inst addu csp-tn alloc))
(move ptr res)
(dotimes (i (1- cons-cells))
(store-car (tn-ref-tn things) ptr)
(move ptr res)
(dotimes (i (1- cons-cells))
(store-car (tn-ref-tn things) ptr)
(:ignore args save)
(:vop-var vop)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:ignore args save)
(:vop-var vop)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+ (:temporary (:scs (non-descriptor-reg)) temp)
(:generator 20
(let ((label (gen-label))
(cur-nfp (current-nfp-tn vop)))
(:generator 20
(let ((label (gen-label))
(cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(inst addu nsp-tn cur-nfp
(bytes-needed-for-non-descriptor-stack-frame))))
(when cur-nfp
(inst addu nsp-tn cur-nfp
(bytes-needed-for-non-descriptor-stack-frame))))
- ;; Establish the values pointer and values count.
- (move val-ptr cfp-tn)
- (inst li nargs (fixnumize nvals))
- ;; restore the frame pointer and clear as much of the control
- ;; stack as possible.
- (move cfp-tn ocfp)
- (inst addu csp-tn val-ptr (* nvals n-word-bytes))
- ;; pre-default any argument register that need it.
- (when (< nvals register-arg-count)
- (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
- (move reg null-tn)))
- ;; And away we go.
- (lisp-return return-pc lip)
+ (cond ((= nvals 1)
+ ;; Clear the control stack, and restore the frame pointer.
+ (move csp-tn cfp-tn)
+ (move cfp-tn ocfp)
+ ;; Out of here.
+ (lisp-return return-pc lip :offset 2))
+ (t
+ ;; Establish the values pointer and values count.
+ (move val-ptr cfp-tn)
+ (inst li nargs (fixnumize nvals))
+ ;; restore the frame pointer and clear as much of the control
+ ;; stack as possible.
+ (move cfp-tn ocfp)
+ (inst addu csp-tn val-ptr (* nvals n-word-bytes))
+ ;; pre-default any argument register that need it.
+ (when (< nvals register-arg-count)
+ (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
+ (move reg null-tn)))
+ ;; And away we go.
+ (lisp-return return-pc lip)))
(trace-table-entry trace-table-normal)))
;;; Do unknown-values return of an arbitrary number of values (passed on the
(trace-table-entry trace-table-normal)))
;;; Do unknown-values return of an arbitrary number of values (passed on the
-;;; More args are stored consequtively on the stack, starting immediately at
-;;; the context pointer. The context pointer is not typed, so the lowtag is 0.
-;;;
+;;; More args are stored consecutively on the stack, starting
+;;; immediately at the context pointer. The context pointer is not
+;;; typed, so the lowtag is 0.
(define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg)
(define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg)
;;; Turn more arg (context, count) into a list.
;;; Turn more arg (context, count) into a list.
+(defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args))
+ t)
+
(define-vop (listify-rest-args)
(:args (context-arg :target context :scs (descriptor-reg))
(count-arg :target count :scs (any-reg)))
(define-vop (listify-rest-args)
(:args (context-arg :target context :scs (descriptor-reg))
(count-arg :target count :scs (any-reg)))
(:results (result :scs (descriptor-reg)))
(:translate %listify-rest-args)
(:policy :safe)
(:results (result :scs (descriptor-reg)))
(:translate %listify-rest-args)
(:policy :safe)
- (let ((enter (gen-label))
- (loop (gen-label))
- (done (gen-label)))
+ (let* ((enter (gen-label))
+ (loop (gen-label))
+ (done (gen-label))
+ (dx-p (node-stack-allocate-p node))
+ (alloc-area-tn (if dx-p csp-tn alloc-tn)))
(move context context-arg)
(move count count-arg)
;; Check to see if there are any arguments.
(move context context-arg)
(move count count-arg)
;; Check to see if there are any arguments.
;; We need to do this atomically.
(pseudo-atomic (pa-flag)
;; We need to do this atomically.
(pseudo-atomic (pa-flag)
+ (when dx-p
+ (align-csp temp))
;; Allocate a cons (2 words) for each item.
;; Allocate a cons (2 words) for each item.
- (inst or result alloc-tn list-pointer-lowtag)
+ (inst srl result alloc-area-tn n-lowtag-bits)
+ (inst sll result n-lowtag-bits)
+ (inst or result list-pointer-lowtag)
(move dst result)
(inst sll temp count 1)
(inst b enter)
(move dst result)
(inst sll temp count 1)
(inst b enter)
- (inst addu alloc-tn alloc-tn temp)
+ (inst addu alloc-area-tn temp)
;; Store the current cons in the cdr of the previous cons.
(emit-label loop)
;; Store the current cons in the cdr of the previous cons.
(emit-label loop)
(emit-label enter)
;; Grab one value.
(loadw temp context)
(emit-label enter)
;; Grab one value.
(loadw temp context)
- (inst addu context context n-word-bytes)
+ (inst addu context n-word-bytes)
;; Dec count, and if != zero, go back for more.
(inst addu count count (fixnumize -1))
;; Dec count, and if != zero, go back for more.
(inst addu count count (fixnumize -1))
(storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
,@body)))
(storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
,@body)))
+(defun align-csp (temp)
+ ;; is used for stack allocation of dynamic-extent objects
+ (let ((aligned (gen-label)))
+ (inst and temp csp-tn lowtag-mask)
+ (inst beq temp aligned)
+ (inst nop)
+ (inst addu csp-tn n-word-bytes)
+ (storew zero-tn csp-tn -1)
+ (emit-label aligned)))
+
\f
;;;; Three Way Comparison
(defun three-way-comparison (x y condition flavor not-p target temp)
\f
;;;; Three Way Comparison
(defun three-way-comparison (x y condition flavor not-p target temp)
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)