(+ x 2)))
(foo 1d0 5) => segmentation violation
-234:
- (fixed in sbcl-0.7.10.36)
-
235: "type system and inline expansion"
a.
(declaim (ftype (function (cons) number) acc))
;;; possible to do this starting from debug names as well as source
;;; names, but as of sbcl-0.7.1.5, there was no need for this
;;; generality, since source names are always known to our callers.)
-(defun transform-call (node res source-name)
- (declare (type combination node) (list res))
+(defun transform-call (call res source-name)
+ (declare (type combination call) (list res))
(aver (and (legal-fun-name-p source-name)
(not (eql source-name '.anonymous.))))
- (with-ir1-environment-from-node node
+ (node-ends-block call)
+ (with-ir1-environment-from-node call
+ (with-component-last-block (*current-component*
+ (block-next (node-block call)))
(let ((new-fun (ir1-convert-inline-lambda
res
:debug-name (debug-namify "LAMBDA-inlined ~A"
(as-debug-name
source-name
"<unknown function>"))))
- (ref (continuation-use (combination-fun node))))
+ (ref (continuation-use (combination-fun call))))
(change-ref-leaf ref new-fun)
- (setf (combination-kind node) :full)
- (locall-analyze-component *current-component*)))
+ (setf (combination-kind call) :full)
+ (locall-analyze-component *current-component*))))
(values))
;;; Replace a call to a foldable function of constant arguments with
(type (or cleanup null) cleanup))
(setf (component-reanalyze (block-component block1)) t)
(with-ir1-environment-from-node node
- (let* ((start (make-continuation))
- (block (continuation-starts-block start))
- (cont (make-continuation))
- (*lexenv* (if cleanup
- (make-lexenv :cleanup cleanup)
- *lexenv*)))
- (change-block-successor block1 block2 block)
- (link-blocks block block2)
- (ir1-convert start cont form)
- (setf (block-last block) (continuation-use cont))
- block)))
+ (with-component-last-block (*current-component*
+ (block-next (component-head *current-component*)))
+ (let* ((start (make-continuation))
+ (block (continuation-starts-block start))
+ (cont (make-continuation))
+ (*lexenv* (if cleanup
+ (make-lexenv :cleanup cleanup)
+ *lexenv*)))
+ (change-block-successor block1 block2 block)
+ (link-blocks block block2)
+ (ir1-convert start cont form)
+ (setf (block-last block) (continuation-use cont))
+ block))))
\f
;;;; continuation use hacking
(ecase (continuation-kind cont)
(:unused
(aver (not (continuation-block cont)))
- (let* ((head (component-head *current-component*))
- (next (block-next head))
- (new-block (make-block cont)))
+ (let* ((next (component-last-block *current-component*))
+ (prev (block-prev next))
+ (new-block (make-block cont)))
(setf (block-next new-block) next
- (block-prev new-block) head
- (block-prev next) new-block
- (block-next head) new-block
- (continuation-block cont) new-block
- (continuation-use cont) nil
- (continuation-kind cont) :block-start)
+ (block-prev new-block) prev
+ (block-prev next) new-block
+ (block-next prev) new-block
+ (continuation-block cont) new-block
+ (continuation-use cont) nil
+ (continuation-kind cont) :block-start)
new-block))
(:block-start
(continuation-block cont))))
(defun make-empty-component ()
(let* ((head (make-block-key :start nil :component nil))
(tail (make-block-key :start nil :component nil))
- (res (make-component :head head :tail tail)))
+ (res (make-component head tail)))
(setf (block-flag head) t)
(setf (block-flag tail) t)
(setf (block-component head) res)
(defmacro with-continuation-type-assertion ((cont ctype context) &body body)
`(let ((*lexenv* (ir1ize-the-or-values ,ctype ,cont *lexenv* ,context)))
,@body))
+
+(defmacro with-component-last-block ((component block) &body body)
+ (let ((old-last-block (gensym "OLD-LAST-BLOCK")))
+ (once-only ((component component)
+ (block block))
+ `(let ((,old-last-block (component-last-block ,component)))
+ (unwind-protect
+ (progn (setf (component-last-block ,component)
+ ,block)
+ ,@body)
+ (setf (component-last-block ,component)
+ ,old-last-block))))))
+
\f
;;;; the EVENT statistics/trace utility
;;; size of flow analysis problems, this allows back-end data
;;; structures to be reclaimed after the compilation of each
;;; component.
-(defstruct (component (:copier nil))
+(defstruct (component (:copier nil)
+ (:constructor
+ make-component (head tail &aux (last-block tail))))
;; unique ID for debugging
#!+sb-show (id (new-object-id) :read-only t)
;; the kind of component
;; the blocks that are the dummy head and tail of the DFO
;;
;; Entry/exit points have these blocks as their
- ;; predecessors/successors. Null temporarily. The start and return
- ;; from each non-deleted function is linked to the component head
- ;; and tail. Until physical environment analysis links NLX entry
- ;; stubs to the component head, every successor of the head is a
- ;; function start (i.e. begins with a BIND node.)
- (head nil :type (or null cblock))
- (tail nil :type (or null cblock))
+ ;; predecessors/successors. The start and return from each
+ ;; non-deleted function is linked to the component head and
+ ;; tail. Until physical environment analysis links NLX entry stubs
+ ;; to the component head, every successor of the head is a function
+ ;; start (i.e. begins with a BIND node.)
+ (head (missing-arg) :type cblock)
+ (tail (missing-arg) :type cblock)
+ ;; New blocks are inserted before this.
+ (last-block (missing-arg) :type cblock)
;; This becomes a list of the CLAMBDA structures for all functions
;; in this component. OPTIONAL-DISPATCHes are represented only by
;; their XEP and other associated lambdas. This doesn't contain any
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.13.13"
+"0.7.13.14"
projects / sbcl.git / commitdiff