From: Alexey Dejneka Date: Mon, 13 Sep 2004 05:40:27 +0000 (+0000) Subject: sbcl-0.8.14.11: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=8902b8b6bd2e9285749dd39d313b33b6c69c5213;p=sbcl.git sbcl-0.8.14.11: * Merge DX sbcl-0-8-13-dx branch. * Out-of-line VALUES does not cons. * Forbid loading of initialization files in foreign.test.sh. --- diff --git a/NEWS b/NEWS index 54d76b0..095aec7 100644 --- a/NEWS +++ b/NEWS @@ -13,6 +13,9 @@ changes in sbcl-0.8.15 relative to sbcl-0.8.14: Sean Champ and Raymond Toy) * bug fix: incorrect expansion of defgeneric that caused a style warning. (thanks for Zach Beane) + * on x86 compiler supports stack allocation of results of LIST and + LIST*, bound to variables, declared DYNAMIC-EXTENT. (based on + CMUCL implementation by Gerd Moellmann) changes in sbcl-0.8.14 relative to sbcl-0.8.13: * incompatible change: the internal functions diff --git a/OPTIMIZATIONS b/OPTIMIZATIONS index 1f8746f..b0c8f47 100644 --- a/OPTIMIZATIONS +++ b/OPTIMIZATIONS @@ -190,3 +190,44 @@ through TYPEP UNBOXED-ARRAY, within the compiler itself. rather than either constant-folding or manipulating NIL-VALUE or NULL-TN directly. -------------------------------------------------------------------------------- +#19 + (let ((dx (if (foo) + (list x) + (list y z)))) + (declare (dynamic-extent dx)) + ...) + +DX is not allocated on stack. +-------------------------------------------------------------------------------- +#20 +(defun-with-dx foo (x) + (flet ((make (x) + (let ((l (list nil nil))) + (setf (first l) x) + (setf (second l) (1- x)) + l))) + (let ((l (make x))) + (declare (dynamic-extent l)) + (mapc #'print l)))) + +Result of MAKE is not stack allocated, which means that +stack-allocation of structures is impossible. +-------------------------------------------------------------------------------- +#21 +(defun-with-dx foo () + (let ((dx (list (list 1 2) (list 3 4) + (declare (dynamic-extent dx)) + ...))))) + +External list in DX is allocated on stack, but internal are not. +-------------------------------------------------------------------------------- +#22 +IR2 does not perform unused code flushing. +-------------------------------------------------------------------------------- +#23 +Python does not know that &REST lists are LISTs (and cannot derive it). +-------------------------------------------------------------------------------- +#24 +a. Iterations on &REST lists, returning them as VALUES could be + rewritten with &MORE vectors. +b. Implement local unknown-values mv-call (useful for fast type checking). diff --git a/doc/manual/efficiency.texinfo b/doc/manual/efficiency.texinfo index 4643f90..20ab991 100644 --- a/doc/manual/efficiency.texinfo +++ b/doc/manual/efficiency.texinfo @@ -162,15 +162,36 @@ it would not be in the following situation: because both the allocation of the @code{&rest} list and the variable binding are outside the scope of the @code{optimize} declaration. -There are many cases when dynamic-extent declarations could be useful. -At present, SBCL implements +There are many cases when @code{dynamic-extent} declarations could be +useful. At present, SBCL implements -@itemize +@itemize @item Stack allocation of @code{&rest} lists, where these are declared @code{dynamic-extent}. +@item +Stack allocation of @code{list} and @code{list*}, whose result is +bound to a variable, declared @code{dynamic-extent}, such as + +@lisp +(let ((list (list 1 2 3))) + (declare (dynamic-extent list) + ...)) +@end lisp + +or + +@lisp +(flet ((f (x) + (declare (dynamic-extent x)) + ...)) + ... + (f (list 1 2 3)) + ...) +@end lisp + @end itemize Future plans include diff --git a/make-host-2.sh b/make-host-2.sh index c359595..6f7faef 100644 --- a/make-host-2.sh +++ b/make-host-2.sh @@ -70,7 +70,8 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 ;; stuff (e.g. %DETECT-STACK-EXHAUSTION in sbcl-0.7.2). (safety 2) (space 1) - (speed 2))))) + (speed 2) + (sb!c::stack-allocate-dynamic-extent 3))))) (compile 'proclaim-target-optimization) (defun in-target-cross-compilation-mode (fun) "Call FUN with everything set up appropriately for cross-compiling diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 28ee3c8..2bbeed6 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -278,12 +278,15 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "MORE-ARG-CONTEXT" "MOVABLE" "MOVE" "MULTIPLE-CALL" "MULTIPLE-CALL-LOCAL" "MULTIPLE-CALL-NAMED" "MULTIPLE-CALL-VARIABLE" - "%%NIP-VALUES" + "%%NIP-DX" "%%NIP-VALUES" "NLX-ENTRY" "NLX-ENTRY-MULTIPLE" + "NODE-STACK-ALLOCATE-P" "NON-DESCRIPTOR-STACK" "NOTE-ENVIRONMENT-START" "NOTE-THIS-LOCATION" "OPTIMIZER" "PACK-TRACE-TABLE" "PARSE-EVAL-WHEN-SITUATIONS" - "POLICY" "PREDICATE" "PRIMITIVE-TYPE" "PRIMITIVE-TYPE-OF" + "POLICY" + "%%POP-DX" + "PREDICATE" "PRIMITIVE-TYPE" "PRIMITIVE-TYPE-OF" "PRIMITIVE-TYPE-OR-LOSE" "PRIMITIVE-TYPE-VOP" "PRIMITIVE-TYPE-NAME" "PUSH-VALUES" "READ-PACKED-BIT-VECTOR" "READ-VAR-INTEGER" "READ-VAR-STRING" diff --git a/src/code/eval.lisp b/src/code/eval.lisp index 7b3764e..24f0eee 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -245,6 +245,7 @@ (defun values (&rest values) #!+sb-doc "Return all arguments, in order, as values." + (declare (dynamic-extent values)) (values-list values)) (defun values-list (list) diff --git a/src/compiler/alpha/call.lisp b/src/compiler/alpha/call.lisp index 538853b..efbf2f2 100644 --- a/src/compiler/alpha/call.lisp +++ b/src/compiler/alpha/call.lisp @@ -1109,8 +1109,6 @@ default-value-8 (define-vop (listify-rest-args) (:args (context-arg :target context :scs (descriptor-reg)) (count-arg :target count :scs (any-reg))) - (:info dx) - (:ignore dx) (:arg-types * tagged-num (:constant t)) (:temporary (:scs (any-reg) :from (:argument 0)) context) (:temporary (:scs (any-reg) :from (:argument 1)) count) diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 7e6244a..84c120d 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -941,6 +941,11 @@ (format t "v~D " (cont-num cont)) (values)) +(defun print-lvar-stack (stack &optional (stream *standard-output*)) + (loop for (lvar . rest) on stack + do (format stream "~:[u~;d~]v~D~@[ ~]" + (lvar-dynamic-extent lvar) (cont-num lvar) rest))) + ;;; Print out the nodes in BLOCK in a format oriented toward ;;; representing what the code does. (defun print-nodes (block) @@ -953,8 +958,8 @@ (pprint-newline :mandatory) (awhen (block-info block) - (format t "start stack:~{ v~D~}" - (mapcar #'cont-num (ir2-block-start-stack it))) + (format t "start stack: ") + (print-lvar-stack (ir2-block-start-stack it)) (pprint-newline :mandatory)) (do ((ctran (block-start block) (node-next (ctran-next ctran)))) ((not ctran)) @@ -996,7 +1001,13 @@ (print-lvar (return-result node)) (print-leaf (return-lambda node))) (entry - (format t "entry ~S" (entry-exits node))) + (let ((cleanup (entry-cleanup node))) + (case (cleanup-kind cleanup) + ((:dynamic-extent) + (format t "entry DX~{ v~D~}" + (mapcar #'cont-num (cleanup-info cleanup)))) + (t + (format t "entry ~S" (entry-exits node)))))) (exit (let ((value (exit-value node))) (cond (value @@ -1015,8 +1026,8 @@ (pprint-newline :mandatory))) (awhen (block-info block) - (format t "end stack:~{ v~D~}" - (mapcar #'cont-num (ir2-block-end-stack it))) + (format t "end stack: ") + (print-lvar-stack (ir2-block-end-stack it)) (pprint-newline :mandatory)) (let ((succ (block-succ block))) (format t "successors~{ c~D~}~%" diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 1f39e62..8ab1e06 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1363,9 +1363,7 @@ (defknown %cleanup-point () t) (defknown %special-bind (t t) t) (defknown %special-unbind (t) t) -(defknown %dynamic-extent-start () t) -(defknown %dynamic-extent-end () t) -(defknown %listify-rest-args (t index t) list (flushable)) +(defknown %listify-rest-args (t index) list (flushable)) (defknown %more-arg-context (t t) (values t index) (flushable)) (defknown %more-arg (t index) t) (defknown %more-arg-values (t index index) * (flushable)) diff --git a/src/compiler/hppa/call.lisp b/src/compiler/hppa/call.lisp index 58191b4..25303d4 100644 --- a/src/compiler/hppa/call.lisp +++ b/src/compiler/hppa/call.lisp @@ -1078,8 +1078,6 @@ default-value-8 (define-vop (listify-rest-args) (:args (context-arg :target context :scs (descriptor-reg)) (count-arg :target count :scs (any-reg))) - (:info dx) - (:ignore dx) (:arg-types * tagged-num (:constant t)) (:temporary (:scs (any-reg) :from (:argument 0)) context) (:temporary (:scs (any-reg) :from (:argument 1)) count) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index b538652..55c8829 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -336,12 +336,16 @@ ;; thus the control transfer is a non-local exit. (not (eq (block-home-lambda block) (block-home-lambda next))) - ;; Stack analysis phase wants ENTRY to start a block. + ;; Stack analysis phase wants ENTRY to start a block... (entry-p (block-start-node next)) (let ((last (block-last block))) (and (valued-node-p last) (awhen (node-lvar last) - (consp (lvar-uses it)))))) + (or + ;; ... and a DX-allocator to end a block. + (lvar-dynamic-extent it) + ;; FIXME: This is a partial workaround for bug 303. + (consp (lvar-uses it))))))) nil) (t (join-blocks block next) @@ -1310,7 +1314,8 @@ (dest (lvar-dest lvar))) (when (and ;; Think about (LET ((A ...)) (IF ... A ...)): two - ;; LVAR-USEs should not be met on one path. + ;; LVAR-USEs should not be met on one path. Another problem + ;; is with dynamic-extent. (eq (lvar-uses lvar) ref) (typecase dest ;; we should not change lifetime of unknown values lvars @@ -1335,7 +1340,9 @@ (eq (node-home-lambda ref) (lambda-home (lambda-var-home var)))) (setf (node-derived-type ref) *wild-type*) - (substitute-lvar-uses lvar arg) + (substitute-lvar-uses lvar arg + ;; Really it is (EQ (LVAR-USES LVAR) REF): + t) (delete-lvar-use ref) (change-ref-leaf ref (find-constant nil)) (delete-ref ref) diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index c107a93..651128d 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -255,25 +255,6 @@ (rest svars)))))) (values)) -;;; FIXME: this is the interface of the CMUCL WITH-DYNAMIC-EXTENT -;;; macro. It is slightly confusing, in that START and BODY-START are -;;; already-existing CTRANs (and FIXME: probably deserve a ONCE-ONLY), -;;; whereas NEXT is a variable naming a CTRAN in the body. -- CSR, -;;; 2004-03-30. -(defmacro with-dynamic-extent ((start body-start next kind) &body body) - (declare (ignore kind)) - (with-unique-names (cleanup next-ctran) - `(progn - (ctran-starts-block ,body-start) - (let ((,cleanup (make-cleanup :kind :dynamic-extent)) - (,next-ctran (make-ctran)) - (,next (make-ctran))) - (ir1-convert ,start ,next-ctran nil '(%dynamic-extent-start)) - (setf (cleanup-mess-up ,cleanup) (ctran-use ,next-ctran)) - (let ((*lexenv* (make-lexenv :cleanup ,cleanup))) - (ir1-convert ,next-ctran ,next nil '(%cleanup-point)) - (locally ,@body)))))) - ;;; Create a lambda node out of some code, returning the result. The ;;; bindings are specified by the list of VAR structures VARS. We deal ;;; with adding the names to the LEXENV-VARS for the conversion. The @@ -310,8 +291,7 @@ :%source-name source-name :%debug-name debug-name)) (result-ctran (make-ctran)) - (result-lvar (make-lvar)) - (dx-rest nil)) + (result-lvar (make-lvar))) (awhen (lexenv-lambda *lexenv*) (push lambda (lambda-children it)) @@ -341,12 +321,7 @@ (t (when note-lexical-bindings (note-lexical-binding (leaf-source-name var))) - (new-venv (cons (leaf-source-name var) var))))) - (let ((info (lambda-var-arg-info var))) - (when (and info - (eq (arg-info-kind info) :rest) - (leaf-dynamic-extent var)) - (setq dx-rest t)))) + (new-venv (cons (leaf-source-name var) var)))))) (let ((*lexenv* (make-lexenv :vars (new-venv) :lambda lambda @@ -371,14 +346,9 @@ (ctran-starts-block prebind-ctran) (link-node-to-previous-ctran bind prebind-ctran) (use-ctran bind postbind-ctran) - (if dx-rest - (with-dynamic-extent (postbind-ctran result-ctran dx :rest) - (ir1-convert-special-bindings dx result-ctran result-lvar - body aux-vars aux-vals - (svars))) - (ir1-convert-special-bindings postbind-ctran result-ctran - result-lvar body - aux-vars aux-vals (svars))))))) + (ir1-convert-special-bindings postbind-ctran result-ctran + result-lvar body + aux-vars aux-vals (svars)))))) (link-blocks (component-head *current-component*) (node-block bind)) (push lambda (component-new-functionals *current-component*)) @@ -545,7 +515,7 @@ (when rest (arg-vals `(%listify-rest-args - ,n-context ,n-count ,(leaf-dynamic-extent rest)))) + ,n-context ,n-count))) (when morep (arg-vals n-context) (arg-vals n-count)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 7600eeb..4e4b031 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -164,16 +164,27 @@ (values)) ;;; Replace all uses of OLD with uses of NEW, where NEW has an -;;; arbitary number of uses. -(defun substitute-lvar-uses (new old) +;;; arbitary number of uses. NEW is supposed to be "later" than OLD. +(defun substitute-lvar-uses (new old propagate-dx) (declare (type lvar old) - (type (or lvar null) new)) - - (cond (new (do-uses (node old) - (%delete-lvar-use node) - (add-lvar-use node new)) - (reoptimize-lvar new)) + (type (or lvar null) new) + (type boolean propagate-dx)) + + (cond (new + (do-uses (node old) + (%delete-lvar-use node) + (add-lvar-use node new)) + (reoptimize-lvar new) + (awhen (and propagate-dx (lvar-dynamic-extent old)) + (setf (lvar-dynamic-extent old) nil) + (unless (lvar-dynamic-extent new) + (setf (lvar-dynamic-extent new) it) + (setf (cleanup-info it) (substitute new old (cleanup-info it))))) + (when (lvar-dynamic-extent new) + (do-uses (node new) + (node-ends-block node)))) (t (flush-dest old))) + (values)) ;;;; block starting/creation @@ -305,8 +316,9 @@ (when (and (basic-combination-p use) (eq (basic-combination-kind use) :local)) (merges use)))) + (substitute-lvar-uses lvar value + (and lvar (eq (lvar-uses lvar) node))) (%delete-lvar-use node) - (substitute-lvar-uses lvar value) (prog1 (unlink-node node) (dolist (merge (merges)) @@ -342,6 +354,11 @@ (defun node-dest (node) (awhen (node-lvar node) (lvar-dest it))) +#!-sb-fluid (declaim (inline node-stack-allocate-p)) +(defun node-stack-allocate-p (node) + (awhen (node-lvar node) + (lvar-dynamic-extent it))) + (declaim (inline block-to-be-deleted-p)) (defun block-to-be-deleted-p (block) (or (block-delete-p block) @@ -694,7 +711,7 @@ ;;; end. The tricky thing is a special cleanup block; all its nodes ;;; have the same cleanup info, corresponding to the start, so the ;;; same approach returns safe result. -(defun map-block-nlxes (fun block) +(defun map-block-nlxes (fun block &optional dx-cleanup-fun) (loop for cleanup = (block-end-cleanup block) then (node-enclosing-cleanup (cleanup-mess-up cleanup)) while cleanup @@ -709,7 +726,10 @@ (aver (combination-p mess-up)) (let* ((arg-lvar (first (basic-combination-args mess-up))) (nlx-info (constant-value (ref-leaf (lvar-use arg-lvar))))) - (funcall fun nlx-info))))))) + (funcall fun nlx-info))) + ((:dynamic-extent) + (when dx-cleanup-fun + (funcall dx-cleanup-fun cleanup))))))) ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for ;;; the head and tail which are set to T. diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index cf611d4..afa0fb6 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -623,6 +623,10 @@ (r-refs (reference-tn-list results t))) (aver (= (length info-args) (template-info-arg-count template))) + #!+stack-grows-downward-not-upward + (when (and lvar (lvar-dynamic-extent lvar)) + (vop current-stack-pointer call block + (ir2-lvar-stack-pointer (lvar-info lvar)))) (if info-args (emit-template call block template args r-refs info-args) (emit-template call block template args r-refs)) @@ -1276,32 +1280,68 @@ ;;; Reset the stack pointer to the start of the specified ;;; unknown-values lvar (discarding it and all values globs on top of ;;; it.) -(defoptimizer (%pop-values ir2-convert) ((lvar) node block) - (let ((2lvar (lvar-info (lvar-value lvar)))) - (aver (eq (ir2-lvar-kind 2lvar) :unknown)) - (vop reset-stack-pointer node block - (first (ir2-lvar-locs 2lvar))))) - -(defoptimizer (%nip-values ir2-convert) ((last-nipped last-preserved +(defoptimizer (%pop-values ir2-convert) ((%lvar) node block) + (let* ((lvar (lvar-value %lvar)) + (2lvar (lvar-info lvar))) + (cond ((eq (ir2-lvar-kind 2lvar) :unknown) + (vop reset-stack-pointer node block + (first (ir2-lvar-locs 2lvar)))) + ((lvar-dynamic-extent lvar) + #!+stack-grows-downward-not-upward + (vop reset-stack-pointer node block + (ir2-lvar-stack-pointer 2lvar)) + #!-stack-grows-downward-not-upward + (vop %%pop-dx node block + (first (ir2-lvar-locs 2lvar)))) + (t (bug "Trying to pop a not stack-allocated LVAR ~S." + lvar))))) + +(locally (declare (optimize (debug 3))) +(defoptimizer (%nip-values ir2-convert) ((last-nipped last-preserved &rest moved) node block) - (let (;; pointer immediately after the nipped block - (2after (lvar-info (lvar-value last-nipped))) - ;; pointer to the first nipped word - (2first (lvar-info (lvar-value last-preserved))) - - (moved-tns (loop for lvar-ref in moved - for lvar = (lvar-value lvar-ref) - for 2lvar = (lvar-info lvar) - ;when 2lvar - collect (first (ir2-lvar-locs 2lvar))))) - (aver (eq (ir2-lvar-kind 2after) :unknown)) + (let* ( ;; pointer immediately after the nipped block + (after (lvar-value last-nipped)) + (2after (lvar-info after)) + ;; pointer to the first nipped word + (first (lvar-value last-preserved)) + (2first (lvar-info first)) + + (moved-tns (loop for lvar-ref in moved + for lvar = (lvar-value lvar-ref) + for 2lvar = (lvar-info lvar) + ;when 2lvar + collect (first (ir2-lvar-locs 2lvar))))) + (aver (or (eq (ir2-lvar-kind 2after) :unknown) + (lvar-dynamic-extent after))) (aver (eq (ir2-lvar-kind 2first) :unknown)) - (vop* %%nip-values node block - ((first (ir2-lvar-locs 2after)) - (first (ir2-lvar-locs 2first)) - (reference-tn-list moved-tns nil)) - ((reference-tn-list moved-tns t))))) + (when *check-consistency* + ;; we cannot move stack-allocated DX objects + (dolist (moved-lvar moved) + (aver (eq (ir2-lvar-kind (lvar-info (lvar-value moved-lvar))) + :unknown)))) + (flet ((nip-aligned (nipped) + (vop* %%nip-values node block + (nipped + (first (ir2-lvar-locs 2first)) + (reference-tn-list moved-tns nil)) + ((reference-tn-list moved-tns t)))) + #!-stack-grows-downward-not-upward + (nip-unaligned (nipped) + (vop* %%nip-dx node block + (nipped + (first (ir2-lvar-locs 2first)) + (reference-tn-list moved-tns nil)) + ((reference-tn-list moved-tns t))))) + (cond ((eq (ir2-lvar-kind 2after) :unknown) + (nip-aligned (first (ir2-lvar-locs 2after)))) + ((lvar-dynamic-extent after) + #!+stack-grows-downward-not-upward + (nip-aligned (ir2-lvar-stack-pointer 2after)) + #!-stack-grows-downward-not-upward + (nip-unaligned (ir2-lvar-stack-pointer 2after))) + (t + (bug "Trying to nip a not stack-allocated LVAR ~S." after))))))) ;;; Deliver the values TNs to LVAR using MOVE-LVAR-RESULT. (defoptimizer (values ir2-convert) ((&rest values) node block) @@ -1354,9 +1394,6 @@ (defoptimizer (%special-unbind ir2-convert) ((var) node block) (vop unbind node block)) -(defoptimizer (%dynamic-extent-start ir2-convert) (() node block) node block) -(defoptimizer (%dynamic-extent-end ir2-convert) (() node block) node block) - ;;; ### It's not clear that this really belongs in this file, or ;;; should really be done this way, but this is the least violation of ;;; abstraction in the current setup. We don't want to wire @@ -1562,11 +1599,16 @@ (res (lvar-result-tns lvar (list (primitive-type (specifier-type 'list)))))) + #!+stack-grows-downward-not-upward + (when (and lvar (lvar-dynamic-extent lvar)) + (vop current-stack-pointer node block + (ir2-lvar-stack-pointer (lvar-info lvar)))) (vop* ,name node block (refs) ((first res) nil) (length args)) (move-lvar-result node block res lvar))))) (def list) (def list*)) + ;;; Convert the code in a component into VOPs. (defun ir2-convert (component) diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp index 640b393..ec49454 100644 --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@ -108,9 +108,12 @@ (ltn-annotate nil :type (or function null)) ;; If true, the special-case IR2 conversion method for this ;; function. This deals with funny functions, and anything else that - ;; can't be handled using the template mechanism. The Combination + ;; can't be handled using the template mechanism. The COMBINATION ;; node and the IR2-BLOCK are passed as arguments. (ir2-convert nil :type (or function null)) + ;; If true, the function can stack-allocate the result. The + ;; COMBINATION node is passed as an argument. + (stack-allocate-result nil :type (or function null)) ;; all the templates that could be used to translate this function ;; into IR2, sorted by increasing cost. (templates nil :type list) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 8ebe63a..107e9ae 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -43,6 +43,45 @@ (setf (car args) nil))) (values)) +(defun recognize-dynamic-extent-lvars (call fun) + (declare (type combination call) (type clambda fun)) + (loop for arg in (basic-combination-args call) + and var in (lambda-vars fun) + when (and (lambda-var-dynamic-extent var) + (not (lvar-dynamic-extent arg))) + collect arg into dx-lvars + and do (let ((use (lvar-uses arg))) + ;; Stack analysis wants DX value generators to end + ;; their blocks. Uses of mupltiple used LVARs already + ;; end their blocks, so we just need to process + ;; used-once LVARs. + (when (node-p use) + (node-ends-block use))) + finally (when dx-lvars + (binding* ((before-ctran (node-prev call)) + (nil (ensure-block-start before-ctran)) + (block (ctran-block before-ctran)) + (new-call-ctran (make-ctran :kind :inside-block + :next call + :block block)) + (entry (with-ir1-environment-from-node call + (make-entry :prev before-ctran + :next new-call-ctran))) + (cleanup (make-cleanup :kind :dynamic-extent + :mess-up entry + :info dx-lvars))) + (setf (node-prev call) new-call-ctran) + (setf (ctran-next before-ctran) entry) + (setf (ctran-use new-call-ctran) entry) + (setf (entry-cleanup entry) cleanup) + (setf (node-lexenv call) + (make-lexenv :default (node-lexenv call) + :cleanup cleanup)) + (push entry (lambda-entries (node-home-lambda entry))) + (dolist (lvar dx-lvars) + (setf (lvar-dynamic-extent lvar) cleanup))))) + (values)) + ;;; This function handles merging the tail sets if CALL is potentially ;;; tail-recursive, and is a call to a function with a different ;;; TAIL-SET than CALL's FUN. This must be called whenever we alter @@ -92,6 +131,7 @@ (when arg (flush-lvar-externally-checkable-type arg)))) (pushnew fun (lambda-calls-or-closes (node-home-lambda call))) + (recognize-dynamic-extent-lvars call fun) (merge-tail-sets call fun) (change-ref-leaf ref fun) (values)) @@ -846,7 +886,8 @@ ;; FIXME: Replace the call with unsafe CAST. -- APD, 2003-01-26 (do-uses (use result) (derive-node-type use call-type))) - (substitute-lvar-uses lvar result))) + (substitute-lvar-uses lvar result + (and lvar (eq (lvar-uses lvar) call))))) (values)) ;;; We are converting FUN to be a LET when the call is in a non-tail diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index bbdb87a..9dce8b5 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -98,8 +98,12 @@ (cond ((lvar-delayed-leaf lvar) (setf (ir2-lvar-kind info) :delayed)) - (t (setf (ir2-lvar-locs info) - (list (make-normal-tn (ir2-lvar-primitive-type info))))))) + (t (let ((tn (make-normal-tn (ir2-lvar-primitive-type info)))) + (setf (ir2-lvar-locs info) (list tn)) + #!+stack-grows-downward-not-upward + (when (lvar-dynamic-extent lvar) + (setf (ir2-lvar-stack-pointer info) + (make-stack-pointer-tn))))))) (ltn-annotate-casts lvar) (values)) @@ -118,6 +122,7 @@ ;;; reference, otherwise we annotate for a single value. (defun annotate-fun-lvar (lvar &optional (delay t)) (declare (type lvar lvar)) + (aver (not (lvar-dynamic-extent lvar))) (let* ((tn-ptype (primitive-type (lvar-type lvar))) (info (make-ir2-lvar tn-ptype))) (setf (lvar-info lvar) info) @@ -195,6 +200,7 @@ (defun annotate-unknown-values-lvar (lvar) (declare (type lvar lvar)) + (aver (not (lvar-dynamic-extent lvar))) (let ((2lvar (make-ir2-lvar nil))) (setf (ir2-lvar-kind 2lvar) :unknown) (setf (ir2-lvar-locs 2lvar) (make-unknown-values-locations)) @@ -219,6 +225,7 @@ ;;; specified primitive TYPES. (defun annotate-fixed-values-lvar (lvar types) (declare (type lvar lvar) (list types)) + (aver (not (lvar-dynamic-extent lvar))) ; XXX (let ((res (make-ir2-lvar nil))) (setf (ir2-lvar-locs res) (mapcar #'make-normal-tn types)) (setf (lvar-info lvar) res)) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 4378621..7d8bab0 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -508,7 +508,8 @@ ,(parse-deftransform lambda-list body n-args `(return-from ,name nil)))) ,@(when (consp what) - `((setf (,(symbolicate "FUN-INFO-" (second what)) + `((setf (,(let ((*package* (symbol-package 'sb!c::fun-info))) + (symbolicate "FUN-INFO-" (second what))) (fun-info-or-lose ',(first what))) #',name))))))) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 33637bf..77daf4d 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -398,7 +398,8 @@ (maybe-mumble "control ") (control-analyze component #'make-ir2-block) - (when (ir2-component-values-receivers (component-info component)) + (when (or (ir2-component-values-receivers (component-info component)) + (component-dx-lvars component)) (maybe-mumble "stack ") (stack-analyze component) ;; Assign BLOCK-NUMBER for any cleanup blocks introduced by diff --git a/src/compiler/mips/call.lisp b/src/compiler/mips/call.lisp index d3d11ef..3fe73f7 100644 --- a/src/compiler/mips/call.lisp +++ b/src/compiler/mips/call.lisp @@ -1109,8 +1109,6 @@ default-value-8 (define-vop (listify-rest-args) (:args (context-arg :target context :scs (descriptor-reg)) (count-arg :target count :scs (any-reg))) - (:info dx) - (:ignore dx) (:arg-types * tagged-num (:constant t)) (:temporary (:scs (any-reg) :from (:argument 0)) context) (:temporary (:scs (any-reg) :from (:argument 1)) count) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 24243aa..d9ff1eb 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -76,6 +76,8 @@ ;; Cached type which is checked by DEST. If NIL, then this must be ;; recomputed: see LVAR-EXTERNALLY-CHECKABLE-TYPE. (%externally-checkable-type nil :type (or null ctype)) + ;; if the LVAR value is DYNAMIC-EXTENT, CLEANUP protecting it. + (dynamic-extent nil :type (or null cleanup)) ;; something or other that the back end annotates this lvar with (info nil)) @@ -374,7 +376,9 @@ ;; from COMPONENT-LAMBDAS. (reanalyze-functionals nil :type list) (delete-blocks nil :type list) - (nlx-info-generated-p nil :type boolean)) + (nlx-info-generated-p nil :type boolean) + ;; this is filled by physical environment analysis + (dx-lvars nil :type list)) (defprinter (component :identity t) name #!+sb-show id @@ -430,13 +434,21 @@ ;; non-messed-up environment. Null only temporarily. This could be ;; deleted due to unreachability. (mess-up nil :type (or node null)) - ;; a list of all the NLX-INFO structures whose NLX-INFO-CLEANUP is - ;; this cleanup. This is filled in by physical environment analysis. - (nlx-info nil :type list)) + ;; For all kinds, except :DYNAMIC-EXTENT: a list of all the NLX-INFO + ;; structures whose NLX-INFO-CLEANUP is this cleanup. This is filled + ;; in by physical environment analysis. + ;; + ;; For :DYNAMIC-EXTENT: a list of all DX LVARs, preserved by this + ;; cleanup. This is filled when the cleanup is created (now by + ;; locall call analysis) and is rechecked by physical environment + ;; analysis. + (info nil :type list)) (defprinter (cleanup :identity t) kind mess-up - (nlx-info :test nlx-info)) + (info :test info)) +(defmacro cleanup-nlx-info (cleanup) + `(cleanup-info ,cleanup)) ;;; A PHYSENV represents the result of physical environment analysis. ;;; diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index 022442e..037060d 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -38,6 +38,7 @@ (component-lambdas component)) (find-non-local-exits component) + (recheck-dynamic-extent-lvars component) (find-cleanup-points component) (tail-annotate component) @@ -327,6 +328,28 @@ (note-non-local-exit target-physenv exit)))))) (values)) +;;;; final decision on stack allocation of dynamic-extent structores +(defun recheck-dynamic-extent-lvars (component) + (declare (type component component)) + (dolist (lambda (component-lambdas component)) + (loop for entry in (lambda-entries lambda) + for cleanup = (entry-cleanup entry) + do (when (eq (cleanup-kind cleanup) :dynamic-extent) + (collect ((real-dx-lvars)) + (loop for lvar in (cleanup-info cleanup) + do (let ((use (lvar-uses lvar))) + (if (and (combination-p use) + (eq (basic-combination-kind use) :known) + (awhen (fun-info-stack-allocate-result + (basic-combination-fun-info use)) + (funcall it use))) + (real-dx-lvars lvar) + (setf (lvar-dynamic-extent lvar) nil)))) + (setf (cleanup-info cleanup) (real-dx-lvars)) + (setf (component-dx-lvars component) + (append (real-dx-lvars) (component-dx-lvars component))))))) + (values)) + ;;;; cleanup emission ;;; Zoom up the cleanup nesting until we hit CLEANUP1, accumulating @@ -370,7 +393,8 @@ (dolist (nlx (cleanup-nlx-info cleanup)) (code `(%lexical-exit-breakup ',nlx)))) (:dynamic-extent - (code `(%dynamic-extent-end)))))) + (when (not (null (cleanup-info cleanup))) + (code `(%cleanup-point))))))) (when (code) (aver (not (node-tail-p (block-last block1)))) diff --git a/src/compiler/ppc/call.lisp b/src/compiler/ppc/call.lisp index 0a19d72..3e40b52 100644 --- a/src/compiler/ppc/call.lisp +++ b/src/compiler/ppc/call.lisp @@ -1100,8 +1100,6 @@ default-value-8 (define-vop (listify-rest-args) (:args (context-arg :target context :scs (descriptor-reg)) (count-arg :target count :scs (any-reg))) - (:info dx) - (:ignore dx) (:arg-types * tagged-num (:constant t)) (:temporary (:scs (any-reg) :from (:argument 0)) context) (:temporary (:scs (any-reg) :from (:argument 1)) count) diff --git a/src/compiler/sparc/call.lisp b/src/compiler/sparc/call.lisp index 4fdc31f..2c8ecf5 100644 --- a/src/compiler/sparc/call.lisp +++ b/src/compiler/sparc/call.lisp @@ -1073,8 +1073,6 @@ default-value-8 (define-vop (listify-rest-args) (:args (context-arg :target context :scs (descriptor-reg)) (count-arg :target count :scs (any-reg))) - (:info dx) - (:ignore dx) (:arg-types * tagged-num (:constant t)) (:temporary (:scs (any-reg) :from (:argument 0)) context) (:temporary (:scs (any-reg) :from (:argument 1)) count) diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp index 121f98b..fccf4f8 100644 --- a/src/compiler/stack.lisp +++ b/src/compiler/stack.lisp @@ -1,7 +1,10 @@ ;;;; This file implements the stack analysis phase in the compiler. We -;;;; do a graph walk to determine which unknown-values lvars are on -;;;; the stack at each point in the program, and then we insert -;;;; cleanup code to remove unused values. +;;;; analyse lifetime of dynamically allocated object packets on stack +;;;; and insert cleanups where necessary. +;;;; +;;;; Currently there are two kinds of interesting stack packets: UVLs, +;;;; whose use and destination lie in different blocks, and LVARs of +;;;; constructors of dynamic-extent objects. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -29,14 +32,15 @@ (when (eq node last-pop) (setq saw-last t)) - (when lvar - (let ((dest (lvar-dest lvar)) - (2lvar (lvar-info lvar))) - (when (and (not (eq (node-block dest) block)) - 2lvar - (eq (ir2-lvar-kind 2lvar) :unknown)) - (aver (or saw-last (not last-pop))) - (pushed lvar)))))) + (when (and lvar + (or (lvar-dynamic-extent lvar) + (let ((dest (lvar-dest lvar)) + (2lvar (lvar-info lvar))) + (and (not (eq (node-block dest) block)) + 2lvar + (eq (ir2-lvar-kind 2lvar) :unknown))))) + (aver (or saw-last (not last-pop))) + (pushed lvar)))) (setf (ir2-block-pushed 2block) (pushed)))) (values)) @@ -86,7 +90,25 @@ nle-start-stack))) (setq new-end (merge-uvl-live-sets new-end next-stack)))) - block) + block + (lambda (dx-cleanup) + (dolist (lvar (cleanup-info dx-cleanup)) + (let* ((generator (lvar-use lvar)) + (block (node-block generator)) + (2block (block-info block))) + (aver (eq generator (block-last block))) + ;; DX objects, living in the LVAR, are + ;; alive in the environment, protected by + ;; the CLEANUP. We also cannot move them + ;; (because, in general, we cannot track + ;; all references to them). Therefore, + ;; everything, allocated deeper than a DX + ;; object, should be kept alive until the + ;; object is deallocated. + (setq new-end (merge-uvl-live-sets + new-end (ir2-block-end-stack 2block))) + (setq new-end (merge-uvl-live-sets + new-end (ir2-block-pushed 2block))))))) (setf (ir2-block-end-stack 2block) new-end) @@ -249,33 +271,37 @@ ;;;; stack analysis ;;; Return a list of all the blocks containing genuine uses of one of -;;; the RECEIVERS. Exits are excluded, since they don't drop through -;;; to the receiver. -(defun find-values-generators (receivers) - (declare (list receivers)) +;;; the RECEIVERS (blocks) and DX-LVARS. Exits are excluded, since +;;; they don't drop through to the receiver. +(defun find-pushing-blocks (receivers dx-lvars) + (declare (list receivers dx-lvars)) (collect ((res nil adjoin)) (dolist (rec receivers) (dolist (pop (ir2-block-popped (block-info rec))) (do-uses (use pop) (unless (exit-p use) (res (node-block use)))))) + (dolist (dx-lvar dx-lvars) + (do-uses (use dx-lvar) + (res (node-block use)))) (res))) -;;; Analyze the use of unknown-values lvars in COMPONENT, inserting -;;; cleanup code to discard values that are generated but never -;;; received. This phase doesn't need to be run when Values-Receivers -;;; is null, i.e. there are no unknown-values lvars used across block -;;; boundaries. +;;; Analyze the use of unknown-values and DX lvars in COMPONENT, +;;; inserting cleanup code to discard values that are generated but +;;; never received. This phase doesn't need to be run when +;;; Values-Receivers and Dx-Lvars are null, i.e. there are no +;;; unknown-values lvars used across block boundaries and no DX LVARs. (defun stack-analyze (component) (declare (type component component)) (let* ((2comp (component-info component)) (receivers (ir2-component-values-receivers 2comp)) - (generators (find-values-generators receivers))) + (generators (find-pushing-blocks receivers + (component-dx-lvars component)))) (dolist (block generators) (find-pushed-lvars block)) - ;;; Compute sets of live UVLs + ;;; Compute sets of live UVLs and DX LVARs (loop for did-something = nil do (do-blocks-backwards (block component) (when (update-uvl-live-sets block) diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp index 1d2c031..4570b36 100644 --- a/src/compiler/vop.lisp +++ b/src/compiler/vop.lisp @@ -214,7 +214,14 @@ ;; since type checking is the responsibility of the values receiver, ;; these TNs primitive type is only based on the proven type ;; information. - (locs nil :type list)) + (locs nil :type list) + #!+stack-grows-downward-not-upward + (stack-pointer nil :type (or tn null))) +;; For upward growing stack start of stack block and start of object +;; differ only by lowtag. +#!-stack-grows-downward-not-upward +(defmacro ir2-lvar-stack-pointer (2lvar) + `(first (ir2-lvar-locs ,2lvar))) (defprinter (ir2-lvar) kind diff --git a/src/compiler/x86/alloc.lisp b/src/compiler/x86/alloc.lisp index a0ec28b..1278d10 100644 --- a/src/compiler/x86/alloc.lisp +++ b/src/compiler/x86/alloc.lisp @@ -12,6 +12,10 @@ (in-package "SB!VM") ;;;; LIST and LIST* +(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)) @@ -40,7 +44,8 @@ (storew reg ,list ,slot list-pointer-lowtag)))) (let ((cons-cells (if star (1- num) num))) (pseudo-atomic - (allocation res (* (pad-data-block cons-size) cons-cells) node) + (allocation res (* (pad-data-block cons-size) cons-cells) node + (awhen (sb!c::node-lvar node) (sb!c::lvar-dynamic-extent it))) (inst lea res (make-ea :byte :base res :disp list-pointer-lowtag)) (move ptr res) diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 42c8c85..00e4572 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -1260,13 +1260,15 @@ ;;; Turn more arg (context, count) into a list. +(defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args)) + t) + (define-vop (listify-rest-args) (:translate %listify-rest-args) (:policy :safe) (:args (context :scs (descriptor-reg) :target src) (count :scs (any-reg) :target ecx)) - (:info *dynamic-extent*) - (:arg-types * tagged-num (:constant t)) + (:arg-types * tagged-num) (:temporary (:sc unsigned-reg :offset esi-offset :from (:argument 0)) src) (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx) (:temporary (:sc unsigned-reg :offset eax-offset) eax) @@ -1276,15 +1278,16 @@ (:generator 20 (let ((enter (gen-label)) (loop (gen-label)) - (done (gen-label))) + (done (gen-label)) + (stack-allocate-p (node-stack-allocate-p node))) (move src context) (move ecx count) ;; Check to see whether there are no args, and just return NIL if so. (inst mov result nil-value) (inst jecxz done) (inst lea dst (make-ea :dword :index ecx :scale 2)) - (pseudo-atomic - (allocation dst dst node *dynamic-extent*) + (maybe-pseudo-atomic stack-allocate-p + (allocation dst dst node stack-allocate-p) (inst lea dst (make-ea :byte :base dst :disp list-pointer-lowtag)) ;; Convert the count into a raw value, so that we can use the ;; LOOP instruction. diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index 028d6b7..a054404 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -313,79 +313,78 @@ ;;; does not matter whether a signal occurs during construction of a ;;; dynamic-extent object, as the half-finished construction of the ;;; object will not cause any difficulty. We can therefore elide -(defvar *dynamic-extent* nil) +(defmacro maybe-pseudo-atomic (really-p &body forms) + `(if ,really-p + (progn ,@forms) + (pseudo-atomic ,@forms))) #!+sb-thread (defmacro pseudo-atomic (&rest forms) (with-unique-names (label) - `(if *dynamic-extent* ; I will burn in hell - (progn ,@forms) - (let ((,label (gen-label))) - (inst fs-segment-prefix) - (inst mov (make-ea :byte - :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0) - (inst fs-segment-prefix) - (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 1) - ,@forms - (inst fs-segment-prefix) - (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 0) - (inst fs-segment-prefix) - (inst cmp (make-ea :byte - :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0) - (inst jmp :eq ,label) - ;; if PAI was set, interrupts were disabled at the same - ;; time using the process signal mask. - (inst break pending-interrupt-trap) - (emit-label ,label))))) + `(let ((,label (gen-label))) + (inst fs-segment-prefix) + (inst mov (make-ea :byte + :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0) + (inst fs-segment-prefix) + (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 1) + ,@forms + (inst fs-segment-prefix) + (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 0) + (inst fs-segment-prefix) + (inst cmp (make-ea :byte + :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0) + (inst jmp :eq ,label) + ;; if PAI was set, interrupts were disabled at the same + ;; time using the process signal mask. + (inst break pending-interrupt-trap) + (emit-label ,label)))) #!-sb-thread (defmacro pseudo-atomic (&rest forms) (with-unique-names (label) - `(if *dynamic-extent* - (progn ,@forms) - (let ((,label (gen-label))) - ;; FIXME: The MAKE-EA noise should become a MACROLET macro - ;; or something. (perhaps SVLB, for static variable low - ;; byte) - (inst mov (make-ea :byte :disp (+ nil-value - (static-symbol-offset - '*pseudo-atomic-interrupted*) - (ash symbol-value-slot word-shift) - ;; FIXME: Use mask, not minus, to - ;; take out type bits. - (- other-pointer-lowtag))) - 0) - (inst mov (make-ea :byte :disp (+ nil-value - (static-symbol-offset - '*pseudo-atomic-atomic*) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) - (fixnumize 1)) - ,@forms - (inst mov (make-ea :byte :disp (+ nil-value - (static-symbol-offset - '*pseudo-atomic-atomic*) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) - 0) - ;; KLUDGE: Is there any requirement for interrupts to be - ;; handled in order? It seems as though an interrupt coming - ;; in at this point will be executed before any pending - ;; interrupts. Or do incoming interrupts check to see - ;; whether any interrupts are pending? I wish I could find - ;; the documentation for pseudo-atomics.. -- WHN 19991130 - (inst cmp (make-ea :byte - :disp (+ nil-value - (static-symbol-offset - '*pseudo-atomic-interrupted*) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) - 0) - (inst jmp :eq ,label) - ;; if PAI was set, interrupts were disabled at the same - ;; time using the process signal mask. - (inst break pending-interrupt-trap) - (emit-label ,label))))) + `(let ((,label (gen-label))) + ;; FIXME: The MAKE-EA noise should become a MACROLET macro + ;; or something. (perhaps SVLB, for static variable low + ;; byte) + (inst mov (make-ea :byte :disp (+ nil-value + (static-symbol-offset + '*pseudo-atomic-interrupted*) + (ash symbol-value-slot word-shift) + ;; FIXME: Use mask, not minus, to + ;; take out type bits. + (- other-pointer-lowtag))) + 0) + (inst mov (make-ea :byte :disp (+ nil-value + (static-symbol-offset + '*pseudo-atomic-atomic*) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag))) + (fixnumize 1)) + ,@forms + (inst mov (make-ea :byte :disp (+ nil-value + (static-symbol-offset + '*pseudo-atomic-atomic*) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag))) + 0) + ;; KLUDGE: Is there any requirement for interrupts to be + ;; handled in order? It seems as though an interrupt coming + ;; in at this point will be executed before any pending + ;; interrupts. Or do incoming interrupts check to see + ;; whether any interrupts are pending? I wish I could find + ;; the documentation for pseudo-atomics.. -- WHN 19991130 + (inst cmp (make-ea :byte + :disp (+ nil-value + (static-symbol-offset + '*pseudo-atomic-interrupted*) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag))) + 0) + (inst jmp :eq ,label) + ;; if PAI was set, interrupts were disabled at the same + ;; time using the process signal mask. + (inst break pending-interrupt-trap) + (emit-label ,label)))) ;;;; indexed references diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 339759d..5bdd4ad 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -11,13 +11,19 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. -;;; &REST lists +(setq sb-c::*check-consistency* t) + (defmacro defun-with-dx (name arglist &body body) `(locally (declare (optimize sb-c::stack-allocate-dynamic-extent)) (defun ,name ,arglist ,@body))) +(declaim (notinline opaque-identity)) +(defun opaque-identity (x) + x) + +;;; &REST lists (defun-with-dx dxlength (&rest rest) (declare (dynamic-extent rest)) (length rest)) @@ -35,5 +41,76 @@ (callee rest)) (assert (= (dxcaller 1 2 3 4 5 6 7) 22)) + +;;; %NIP-VALUES +(defun-with-dx test-nip-values () + (flet ((bar (x &rest y) + (declare (dynamic-extent y)) + (if (> x 0) + (values x (length y)) + (values (car y))))) + (multiple-value-call #'values + (bar 1 2 3 4 5 6) + (bar -1 'a 'b)))) + +(assert (equal (multiple-value-list (test-nip-values)) '(1 5 a))) + +;;; LET-variable substitution +(defun-with-dx test-let-var-subst1 (x) + (let ((y (list x (1- x)))) + (opaque-identity :foo) + (let ((z (the list y))) + (declare (dynamic-extent z)) + (length z)))) +(assert (eql (test-let-var-subst1 17) 2)) + +(defun-with-dx test-let-var-subst2 (x) + (let ((y (list x (1- x)))) + (declare (dynamic-extent y)) + (opaque-identity :foo) + (let ((z (the list y))) + (length z)))) +(assert (eql (test-let-var-subst2 17) 2)) + +;;; DX propagation through LET-return. +(defun-with-dx test-lvar-subst (x) + (let ((y (list x (1- x)))) + (declare (dynamic-extent y)) + (second (let ((z (the list y))) + (opaque-identity :foo) + z)))) +(assert (eql (test-lvar-subst 11) 10)) + +;;; this code is incorrect, but the compiler should not fail +(defun-with-dx test-let-var-subst-incorrect (x) + (let ((y (list x (1- x)))) + (opaque-identity :foo) + (let ((z (the list y))) + (declare (dynamic-extent z)) + (opaque-identity :bar) + z))) + +(defmacro assert-no-consing (form &optional times) + `(%assert-no-consing (lambda () ,form ,times))) +(defun %assert-no-consing (thunk &optional times) + (let ((before (get-bytes-consed)) + (times (or times 10000))) + (declare (type (integer 1 *) times)) + (dotimes (i times) + (funcall thunk)) + (assert (< (- (get-bytes-consed) before) times)))) + +#+x86 +(progn + (assert-no-consing (dxlength 1 2 3)) + (assert-no-consing (dxlength t t t t t t)) + (assert-no-consing (dxlength)) + (assert-no-consing (dxcaller 1 2 3 4 5 6 7)) + (assert-no-consing (test-nip-values)) + (assert-no-consing (test-let-var-subst1 17)) + (assert-no-consing (test-let-var-subst2 17)) + (assert-no-consing (test-lvar-subst 11)) + ) + (sb-ext:quit :unix-status 104) \ No newline at end of file diff --git a/tests/foreign.test.sh b/tests/foreign.test.sh index ac7ebcc..593412a 100644 --- a/tests/foreign.test.sh +++ b/tests/foreign.test.sh @@ -83,7 +83,7 @@ if [ $? = 22 ]; then exit $PUNT # success -- linkage-table not available fi -$SBCL_ALLOWING_CORE --core $testfilestem.core --load $testfilestem.testlisp +$SBCL_ALLOWING_CORE --core $testfilestem.core --sysinit /dev/null --userinit /dev/null --load $testfilestem.testlisp if [ $? != 52 ]; then rm $testfilestem.* echo test failed: $? diff --git a/version.lisp-expr b/version.lisp-expr index 3da2fce..6b47397 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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".) -"0.8.14.10" +"0.8.14.11"