projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
1.0.28.75: documentation work related to move to Launchpad
[sbcl.git]
/
src
/
compiler
/
ir2tran.lisp
diff --git
a/src/compiler/ir2tran.lisp
b/src/compiler/ir2tran.lisp
index
ea5e1d9
..
cb1126a
100644
(file)
--- a/
src/compiler/ir2tran.lisp
+++ b/
src/compiler/ir2tran.lisp
@@
-56,10
+56,13
@@
(defevent make-value-cell-event "Allocate heap value cell for lexical var.")
(defun emit-make-value-cell (node block value res)
(event make-value-cell-event node)
(defevent make-value-cell-event "Allocate heap value cell for lexical var.")
(defun emit-make-value-cell (node block value res)
(event make-value-cell-event node)
- (let ((leaf (tn-leaf res)))
+ (let* ((leaf (tn-leaf res))
+ (dx (when leaf (leaf-dynamic-extent leaf))))
+ (when (and dx (neq :truly dx) (leaf-has-source-name-p leaf))
+ (compiler-notify "cannot stack allocate value cell for ~S" (leaf-source-name leaf)))
(vop make-value-cell node block value
;; FIXME: See bug 419
(vop make-value-cell node block value
;; FIXME: See bug 419
- (and leaf (eq :truly (leaf-dynamic-extent leaf)))
+ (eq :truly dx)
res)))
\f
;;;; leaf reference
res)))
\f
;;;; leaf reference
@@
-141,12
+144,18
@@
(let ((unsafe (policy node (zerop safety)))
(name (leaf-source-name leaf)))
(ecase (global-var-kind leaf)
(let ((unsafe (policy node (zerop safety)))
(name (leaf-source-name leaf)))
(ecase (global-var-kind leaf)
- ((:special :global)
+ ((:special :unknown)
(aver (symbolp name))
(let ((name-tn (emit-constant name)))
(aver (symbolp name))
(let ((name-tn (emit-constant name)))
- (if unsafe
+ (if (or unsafe (info :variable :always-bound name))
(vop fast-symbol-value node block name-tn res)
(vop symbol-value node block name-tn res))))
(vop fast-symbol-value node block name-tn res)
(vop symbol-value node block name-tn res))))
+ (:global
+ (aver (symbolp name))
+ (let ((name-tn (emit-constant name)))
+ (if (or unsafe (info :variable :always-bound name))
+ (vop fast-symbol-global-value node block name-tn res)
+ (vop symbol-global-value node block name-tn res))))
(:global-function
(let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
(if unsafe
(:global-function
(let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
(if unsafe
@@
-298,10
+307,13
@@
(vop value-cell-set node block tn val)
(emit-move node block val tn)))))
(global-var
(vop value-cell-set node block tn val)
(emit-move node block val tn)))))
(global-var
+ (aver (symbolp (leaf-source-name leaf)))
(ecase (global-var-kind leaf)
((:special)
(ecase (global-var-kind leaf)
((:special)
- (aver (symbolp (leaf-source-name leaf)))
- (vop set node block (emit-constant (leaf-source-name leaf)) val)))))
+ (vop set node block (emit-constant (leaf-source-name leaf)) val))
+ ((:global)
+ (vop %set-symbol-global-value node
+ block (emit-constant (leaf-source-name leaf)) val)))))
(when locs
(emit-move node block val (first locs))
(move-lvar-result node block locs lvar)))
(when locs
(emit-move node block val (first locs))
(move-lvar-result node block locs lvar)))
@@
-1452,7
+1464,7
@@
(dolist (var vars)
;; CLHS says "bound and then made to have no value" -- user
;; should not be able to tell the difference between that and this.
(dolist (var vars)
;; CLHS says "bound and then made to have no value" -- user
;; should not be able to tell the difference between that and this.
- (about-to-modify-symbol-value var "bind ~S")
+ (about-to-modify-symbol-value var 'progv)
(%primitive bind unbound-marker var))))
(,bind (vars vals)
(declare (optimize (speed 2) (debug 0)
(%primitive bind unbound-marker var))))
(,bind (vars vals)
(declare (optimize (speed 2) (debug 0)
@@
-1462,7
+1474,7
@@
(t
(let ((val (car vals))
(var (car vars)))
(t
(let ((val (car vals))
(var (car vars)))
- (about-to-modify-symbol-value var "bind ~S" val)
+ (about-to-modify-symbol-value var 'progv val t)
(%primitive bind val var))
(,bind (cdr vars) (cdr vals))))))
(,bind ,vars ,vals))
(%primitive bind val var))
(,bind (cdr vars) (cdr vals))))))
(,bind ,vars ,vals))