(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
- (and leaf (eq :truly (leaf-dynamic-extent leaf)))
+ (eq :truly dx)
res)))
\f
;;;; leaf reference
(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)))
- (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))))
+ (: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
(vop current-stack-pointer call 2block
(ir2-lvar-stack-pointer (lvar-info leaves))))
(dolist (leaf (lvar-value leaves))
- (binding* ((xep (functional-entry-fun leaf) :exit-if-null)
+ (binding* ((xep (awhen (functional-entry-fun leaf)
+ ;; if the xep's been deleted then we can skip it
+ (if (eq (functional-kind it) :deleted)
+ nil it))
+ :exit-if-null)
(nil (aver (xep-p xep)))
(entry-info (lambda-info xep) :exit-if-null)
(tn (entry-info-closure-tn entry-info) :exit-if-null)
(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)
- (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)))
(declare (type node node) (type ir2-block block)
(type template template) (type (or tn-ref null) args)
(list info-args) (type cif if) (type boolean not-p))
- (aver (= (template-info-arg-count template) (+ (length info-args) 2)))
(let ((consequent (if-consequent if))
- (alternative (if-alternative if)))
- (cond ((drop-thru-p if consequent)
+ (alternative (if-alternative if))
+ (flags (and (consp (template-result-types template))
+ (rest (template-result-types template)))))
+ (aver (= (template-info-arg-count template)
+ (+ (length info-args)
+ (if flags 0 2))))
+ (when not-p
+ (rotatef consequent alternative)
+ (setf not-p nil))
+ (when (drop-thru-p if consequent)
+ (rotatef consequent alternative)
+ (setf not-p t))
+ (cond ((not flags)
(emit-template node block template args nil
- (list* (block-label alternative) (not not-p)
- info-args)))
+ (list* (block-label consequent) not-p
+ info-args))
+ (unless (drop-thru-p if alternative)
+ (vop branch node block (block-label alternative))))
(t
- (emit-template node block template args nil
- (list* (block-label consequent) not-p info-args))
+ (emit-template node block template args nil info-args)
+ (vop branch-if node block (block-label consequent) flags not-p)
(unless (drop-thru-p if alternative)
(vop branch node block (block-label alternative)))))))
(multiple-value-bind (args info-args)
(reference-args call block (combination-args call) template)
(aver (not (template-more-results-type template)))
- (if (eq rtypes :conditional)
+ (if (template-conditional-p template)
(ir2-convert-conditional call block template args info-args
(lvar-dest lvar) nil)
(let* ((results (make-template-result-tns call lvar rtypes))
(multiple-value-bind (args info-args)
(reference-args call block (cddr (combination-args call)) template)
(aver (not (template-more-results-type template)))
- (aver (not (eq rtypes :conditional)))
+ (aver (not (template-conditional-p template)))
(aver (null info-args))
(if info
(values))
\f
;;;; debugger hooks
+;;;;
+;;;; These are used by the debugger to find the top function on the
+;;;; stack. They return the OLD-FP and RETURN-PC for the current
+;;;; function as multiple values.
-;;; This is used by the debugger to find the top function on the
-;;; stack. It returns the OLD-FP and RETURN-PC for the current
-;;; function as multiple values.
-(defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() node block)
+(defoptimizer (%caller-frame ir2-convert) (() node block)
(let ((ir2-physenv (physenv-info (node-physenv node))))
(move-lvar-result node block
- (list (ir2-physenv-old-fp ir2-physenv)
- (ir2-physenv-return-pc ir2-physenv))
+ (list (ir2-physenv-old-fp ir2-physenv))
+ (node-lvar node))))
+
+(defoptimizer (%caller-pc ir2-convert) (() node block)
+ (let ((ir2-physenv (physenv-info (node-physenv node))))
+ (move-lvar-result node block
+ (list (ir2-physenv-return-pc ir2-physenv))
(node-lvar node))))
\f
;;;; multiple values
(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)))
+ (declare (optimize (speed 2) (debug 0)
+ (insert-debug-catch 0)))
(cond ((null vars))
((null vals) (,unbind 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))
projects / sbcl.git / blobdiff