[prev in list] [next in list] [prev in thread] [next in thread]
List: sbcl-commits
Subject: [Sbcl-commits] CVS: sbcl/src/compiler early-c.lisp, 1.43,
From: Nikodemus Siivola <demoss () users ! sourceforge ! net>
Date: 2008-07-30 17:58:46
Message-ID: E1KOFwk-0005RC-UM () sc8-pr-cvs8 ! sourceforge ! net
[Download RAW message or body]
Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20769/src/compiler
Modified Files:
early-c.lisp ir1tran.lisp ir1util.lisp ir2tran.lisp
locall.lisp node.lisp physenvanal.lisp policies.lisp
Log Message:
1.0.19.7: refactor stack allocation decisions
* Remove SB-C::STACK-ALLOCATE-* policies.
* Obey DYNAMIC-EXTENT declarations if SB-EXT:*STACK-ALLOCATE-DYNAMIC-EXTENT*
is true (the default), with the following exceptions:
** Value cells are not stack allocated.
** Vectors that may be longer then a single page are stack
allocated only in SAFETY 0 policies.
* New declaration: SB-INT:TRULY-DYNAMIC-EXTENT. Always stack-allocates,
regardless of SB-EXT:*STACK-ALLOCATE-DYNAMIC-EXTENT*. Also causes stack
allocation of value cells and potentially large vectors.
Used exclusively inside SBCL.
* Move STACK-ALLOCATE-RESULT optimizers from backends to
src/compiler/generic/vm-ir2tran.lisp.
* Documentation.
Index: early-c.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/early-c.lisp,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -d -r1.43 -r1.44
--- early-c.lisp 11 Jul 2008 18:55:08 -0000 1.43
+++ early-c.lisp 30 Jul 2008 17:58:42 -0000 1.44
@@ -111,6 +111,13 @@
(defvar *warnings-p*)
(defvar *lambda-conversions*)
+(defvar *stack-allocate-dynamic-extent* t
+ "If true (the default), the compiler respects DYNAMIC-EXTENT declarations
+and stack allocates otherwise inaccessible parts of the object whenever
+possible. Potentially long (over one page in size) vectors are, however, not
+stack allocated except in zero SAFETY code, as such a vector could overflow
+the stack without triggering overflow protection.")
+
;;; This lock is seized in the compiler, and related areas: the
;;; compiler is not presently thread-safe
(defvar *big-compiler-lock*
Index: ir1tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran.lisp,v
retrieving revision 1.165
retrieving revision 1.166
diff -u -d -r1.165 -r1.166
--- ir1tran.lisp 19 Jul 2008 11:32:54 -0000 1.165
+++ ir1tran.lisp 30 Jul 2008 17:58:42 -0000 1.166
@@ -1318,54 +1318,59 @@
(setf (lambda-var-ignorep var) t)))))
(values))
-(defun process-dx-decl (names vars fvars)
+(defun process-dx-decl (names vars fvars kind)
(flet ((maybe-notify (control &rest args)
(when (policy *lexenv* (> speed inhibit-warnings))
(apply #'compiler-notify control args))))
- (if (policy *lexenv* (= stack-allocate-dynamic-extent 3))
- (dolist (name names)
- (cond
- ((symbolp name)
- (let* ((bound-var (find-in-bindings vars name))
- (var (or bound-var
- (lexenv-find name vars)
- (find-free-var name))))
- (etypecase var
- (leaf
- (if bound-var
- (setf (leaf-dynamic-extent var) t)
- (maybe-notify
- "ignoring DYNAMIC-EXTENT declaration for free ~S"
- name)))
- (cons
- (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name))
- (heap-alien-info
- (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S"
- name)))))
- ((and (consp name)
- (eq (car name) 'function)
- (null (cddr name))
- (valid-function-name-p (cadr name)))
- (let* ((fname (cadr name))
- (bound-fun (find fname fvars
- :key #'leaf-source-name
- :test #'equal)))
- (etypecase bound-fun
- (leaf
- #!+stack-allocatable-closures
- (setf (leaf-dynamic-extent bound-fun) t)
- #!-stack-allocatable-closures
- (maybe-notify
- "ignoring DYNAMIC-EXTENT declaration on a function ~S ~
+ (let ((dx (cond ((eq 'truly-dynamic-extent kind)
+ :truly)
+ ((and (eq 'dynamic-extent kind)
+ *stack-allocate-dynamic-extent*)
+ t))))
+ (if dx
+ (dolist (name names)
+ (cond
+ ((symbolp name)
+ (let* ((bound-var (find-in-bindings vars name))
+ (var (or bound-var
+ (lexenv-find name vars)
+ (find-free-var name))))
+ (etypecase var
+ (leaf
+ (if bound-var
+ (setf (leaf-dynamic-extent var) dx)
+ (maybe-notify
+ "ignoring DYNAMIC-EXTENT declaration for free ~S"
+ name)))
+ (cons
+ (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name))
+ (heap-alien-info
+ (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S"
+ name)))))
+ ((and (consp name)
+ (eq (car name) 'function)
+ (null (cddr name))
+ (valid-function-name-p (cadr name)))
+ (let* ((fname (cadr name))
+ (bound-fun (find fname fvars
+ :key #'leaf-source-name
+ :test #'equal)))
+ (etypecase bound-fun
+ (leaf
+ #!+stack-allocatable-closures
+ (setf (leaf-dynamic-extent bound-fun) dx)
+ #!-stack-allocatable-closures
+ (maybe-notify
+ "ignoring DYNAMIC-EXTENT declaration on a function ~S ~
(not supported on this platform)." fname))
- (cons
- (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname))
- (null
- (maybe-notify
- "ignoring DYNAMIC-EXTENT declaration for free ~S"
- fname)))))
- (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name))))
- (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names))))
+ (cons
+ (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname))
+ (null
+ (maybe-notify
+ "ignoring DYNAMIC-EXTENT declaration for free ~S"
+ fname)))))
+ (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name))))
+ (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names)))))
;;; FIXME: This is non-ANSI, so the default should be T, or it should
;;; go away, I think.
@@ -1418,8 +1423,8 @@
(car types)
`(values ,@types)))))
res))
- (dynamic-extent
- (process-dx-decl (cdr spec) vars fvars)
+ ((dynamic-extent truly-dynamic-extent)
+ (process-dx-decl (cdr spec) vars fvars (first spec))
res)
((disable-package-locks enable-package-locks)
(make-lexenv
Index: ir1util.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1util.lisp,v
retrieving revision 1.117
retrieving revision 1.118
diff -u -d -r1.117 -r1.118
--- ir1util.lisp 20 Jul 2008 07:52:08 -0000 1.117
+++ ir1util.lisp 30 Jul 2008 17:58:42 -0000 1.118
@@ -391,37 +391,35 @@
(awhen (node-lvar node)
(lvar-dynamic-extent it)))
-(declaim (ftype (sfunction (node &optional (or null component)) boolean)
- use-good-for-dx-p))
-(declaim (ftype (sfunction (lvar &optional (or null component)) boolean)
- lvar-good-for-dx-p))
-(defun use-good-for-dx-p (use &optional component)
+(declaim (ftype (sfunction (node (member nil t :truly) &optional (or null component))
+ boolean) use-good-for-dx-p))
+(declaim (ftype (sfunction (lvar (member nil t :truly) &optional (or null component))
+ boolean) lvar-good-for-dx-p))
+(defun use-good-for-dx-p (use dx &optional component)
;; FIXME: Can casts point to LVARs in other components?
- ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that
- ;; is, that the PRINCIPAL-LVAR is always in the same component
- ;; as the original one. It would be either good to have an
- ;; explanation of why casts don't point across components, or an
- ;; explanation of when they do it. ...in the meanwhile AVER that
- ;; our assumption holds true.
+ ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that is, that the
+ ;; PRINCIPAL-LVAR is always in the same component as the original one. It
+ ;; would be either good to have an explanation of why casts don't point
+ ;; across components, or an explanation of when they do it. ...in the
+ ;; meanwhile AVER that our assumption holds true.
(aver (or (not component) (eq component (node-component use))))
(or (and (combination-p use)
(eq (combination-kind use) :known)
- (awhen (fun-info-stack-allocate-result
- (combination-fun-info use))
- (funcall it use))
+ (awhen (fun-info-stack-allocate-result (combination-fun-info use))
+ (funcall it use dx))
t)
(and (cast-p use)
(not (cast-type-check use))
- (lvar-good-for-dx-p (cast-value use) component)
+ (lvar-good-for-dx-p (cast-value use) dx component)
t)))
-(defun lvar-good-for-dx-p (lvar &optional component)
+(defun lvar-good-for-dx-p (lvar dx &optional component)
(let ((uses (lvar-uses lvar)))
(if (listp uses)
(every (lambda (use)
- (use-good-for-dx-p use component))
+ (use-good-for-dx-p use dx component))
uses)
- (use-good-for-dx-p uses component))))
+ (use-good-for-dx-p uses dx component))))
(declaim (inline block-to-be-deleted-p))
(defun block-to-be-deleted-p (block)
Index: ir2tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir2tran.lisp,v
retrieving revision 1.75
retrieving revision 1.76
diff -u -d -r1.75 -r1.76
--- ir2tran.lisp 30 Jul 2008 13:51:56 -0000 1.75
+++ ir2tran.lisp 30 Jul 2008 17:58:42 -0000 1.76
@@ -58,9 +58,8 @@
(event make-value-cell-event node)
(let ((leaf (tn-leaf res)))
(vop make-value-cell node block value
- (and leaf (leaf-dynamic-extent leaf)
- ;; FIXME: See bug 419
- (policy node (> stack-allocate-value-cells 1)))
+ ;; FIXME: See bug 419
+ (and leaf (eq :truly (leaf-dynamic-extent leaf)))
res)))
;;;; leaf reference
Index: locall.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/locall.lisp,v
retrieving revision 1.89
retrieving revision 1.90
diff -u -d -r1.89 -r1.90
--- locall.lisp 20 Jul 2008 07:52:08 -0000 1.89
+++ locall.lisp 30 Jul 2008 17:58:42 -0000 1.90
@@ -43,7 +43,7 @@
(setf (car args) nil)))
(values))
-(defun handle-nested-dynamic-extent-lvars (lvar)
+(defun handle-nested-dynamic-extent-lvars (dx lvar)
(let ((uses (lvar-uses lvar)))
;; DX value generators must end their blocks: see UPDATE-UVL-LIVE-SETS.
;; Uses of mupltiple-use LVARs already end their blocks, so we just need
@@ -55,26 +55,26 @@
(flet ((recurse (use)
(etypecase use
(cast
- (handle-nested-dynamic-extent-lvars (cast-value use)))
+ (handle-nested-dynamic-extent-lvars dx (cast-value use)))
(combination
(loop for arg in (combination-args use)
- when (lvar-good-for-dx-p arg)
- append (handle-nested-dynamic-extent-lvars arg))))))
+ when (lvar-good-for-dx-p arg dx)
+ append (handle-nested-dynamic-extent-lvars dx arg))))))
(cons lvar
(if (listp uses)
(loop for use in uses
- when (use-good-for-dx-p use)
+ when (use-good-for-dx-p use dx)
nconc (recurse use))
- (when (use-good-for-dx-p uses)
+ (when (use-good-for-dx-p uses dx)
(recurse uses)))))))
(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 arg (lambda-var-dynamic-extent var)
- (not (lvar-dynamic-extent arg)))
- append (handle-nested-dynamic-extent-lvars arg) into dx-lvars
+ for var in (lambda-vars fun)
+ for dx = (lambda-var-dynamic-extent var)
+ when (and dx arg (not (lvar-dynamic-extent arg)))
+ append (handle-nested-dynamic-extent-lvars dx arg) into dx-lvars
finally (when dx-lvars
;; Stack analysis requires that the CALL ends the block, so
;; that MAP-BLOCK-NLXES sees the cleanup we insert here.
Index: node.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/node.lisp,v
retrieving revision 1.77
retrieving revision 1.78
diff -u -d -r1.77 -r1.78
--- node.lisp 16 Jul 2008 20:51:15 -0000 1.77
+++ node.lisp 30 Jul 2008 17:58:42 -0000 1.78
@@ -634,8 +634,8 @@
;; true if there was ever a REF or SET node for this leaf. This may
;; be true when REFS and SETS are null, since code can be deleted.
(ever-used nil :type boolean)
- ;; is it declared dynamic-extent?
- (dynamic-extent nil :type boolean)
+ ;; is it declared dynamic-extent, or truly-dynamic-extent?
+ (dynamic-extent nil :type (member nil t :truly))
;; some kind of info used by the back end
(info nil))
Index: physenvanal.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/physenvanal.lisp,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -d -r1.24 -r1.25
--- physenvanal.lisp 8 May 2008 11:52:06 -0000 1.24
+++ physenvanal.lisp 30 Jul 2008 17:58:42 -0000 1.25
@@ -334,7 +334,7 @@
(loop for what in (cleanup-info cleanup)
do (etypecase what
(lvar
- (if (lvar-good-for-dx-p what component)
+ (if (lvar-good-for-dx-p what t component)
(let ((real (principal-lvar what)))
(setf (lvar-dynamic-extent real) cleanup)
(real-dx-lvars real))
Index: policies.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/policies.lisp,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- policies.lisp 12 May 2008 14:12:43 -0000 1.21
+++ policies.lisp 30 Jul 2008 17:58:42 -0000 1.22
@@ -91,35 +91,6 @@
case of renaming described above, calls to FOO will not be recursive
and will refer to the new function, bound to FOO.")
-(define-optimization-quality stack-allocate-dynamic-extent
- (if (and (> (max speed space) (max debug safety))
- (< safety 3))
- 3
- 0)
- ("no" "maybe" "yes" "yes")
- "Control whether allocate objects, declared DYNAMIC-EXTENT, on
-stack.")
-
-(define-optimization-quality stack-allocate-value-cells
- ;; FIXME, see bug 419
- 0
- ("no" "maybe" "yes" "yes")
- "Control whether allocate closure variable storage, declared
-DYNAMIC-EXTENT, on stack.")
-
-(define-optimization-quality stack-allocate-vector
- (cond ((= stack-allocate-dynamic-extent 0) 0)
- ((= safety 0) 3)
- (t 2))
- ("no" "maybe" "one page" "yes")
- "Control what vectors, declared DYNAMIC-EXTENT, are allocated on stack:
-0: no vectors are allocated on stack;
-2: only short vectors (compiler knows them to fit on one page);
-3: every.
-
-This option has an effect only when STACK-ALLOCATE-DYNAMIC-EXTENT is
-set.")
-
(define-optimization-quality float-accuracy
3
("degraded" "full" "full" "full"))
-------------------------------------------------------------------------
This SF.Net email is sponsored by the Moblin Your Move Developer's challenge
Build the coolest Linux based applications with Moblin SDK & win great prizes
Grand prize is a trip for two to an Open Source event anywhere in the world
http://moblin-contest.org/redirect.php?banner_id=100&url=/
_______________________________________________
Sbcl-commits mailing list
Sbcl-commits@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-commits
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic