From: William Harold Newman Date: Thu, 3 Jan 2002 02:04:37 +0000 (+0000) Subject: 0.pre7.112: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f0f5d9fc9d493e6683852f947293855be46d4750;p=sbcl.git 0.pre7.112: more bug-138-related assertions and tweaking --- diff --git a/src/code/condition.lisp b/src/code/condition.lisp index bf840db..b0430b4 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -119,8 +119,8 @@ (reverse (reduce #'append (mapcar #'(lambda (x) - (condition-class-cpl - (sb!xc:find-class x))) + (condition-class-cpl + (sb!xc:find-class x))) parent-types))))) (cond-layout (info :type :compiler-layout 'condition)) (olayout (info :type :compiler-layout name)) diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index 0545ac7..91fde41 100644 --- a/src/cold/shared.lisp +++ b/src/cold/shared.lisp @@ -144,16 +144,16 @@ ignore-failure-p) (let* (;; KLUDGE: Note that this CONCATENATE 'STRING stuff is not The Common - ;; Lisp Way, although it works just fine for common UNIX environments. - ;; Should it come to pass that the system is ported to environments - ;; where version numbers and so forth become an issue, it might become - ;; urgent to rewrite this using the fancy Common Lisp PATHNAME - ;; machinery instead of just using strings. In the absence of such a - ;; port, it might or might be a good idea to do the rewrite. - ;; -- WHN 19990815 - (src (concatenate 'string src-prefix stem src-suffix)) - (obj (concatenate 'string obj-prefix stem obj-suffix)) - (tmp-obj (concatenate 'string obj tmp-obj-suffix-suffix))) + ;; Lisp Way, although it works just fine for common UNIX environments. + ;; Should it come to pass that the system is ported to environments + ;; where version numbers and so forth become an issue, it might become + ;; urgent to rewrite this using the fancy Common Lisp PATHNAME + ;; machinery instead of just using strings. In the absence of such a + ;; port, it might or might be a good idea to do the rewrite. + ;; -- WHN 19990815 + (src (concatenate 'string src-prefix stem src-suffix)) + (obj (concatenate 'string obj-prefix stem obj-suffix)) + (tmp-obj (concatenate 'string obj tmp-obj-suffix-suffix))) (ensure-directories-exist obj :verbose t) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 0634aeb..1ff1709 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -146,29 +146,40 @@ (move-continuation-result node block locs cont)) (values)) -;;; Emit code to load a function object representing LEAF into RES. -;;; This gets interesting when the referenced function is a closure: -;;; we must make the closure and move the closed-over values into it. +;;; Emit code to load a function object implementing FUN into +;;; RES. This gets interesting when the referenced function is a +;;; closure: we must make the closure and move the closed-over values +;;; into it. ;;; -;;; LEAF is either a :TOPLEVEL-XEP functional or the XEP lambda for -;;; the called function, since local call analysis converts all -;;; closure references. If a :TOPLEVEL-XEP, we know it is not a closure. +;;; FUN is either a :TOPLEVEL-XEP functional or the XEP lambda for the +;;; called function, since local call analysis converts all closure +;;; references. If a :TOPLEVEL-XEP, we know it is not a closure. ;;; ;;; If a closed-over LAMBDA-VAR has no refs (is deleted), then we ;;; don't initialize that slot. This can happen with closures over ;;; top level variables, where optimization of the closure deleted the ;;; variable. Since we committed to the closure format when we ;;; pre-analyzed the top level code, we just leave an empty slot. -(defun ir2-convert-closure (node block leaf res) - (declare (type ref node) (type ir2-block block) - (type functional leaf) (type tn res)) - (unless (leaf-info leaf) - (setf (leaf-info leaf) - (make-entry-info :name (functional-debug-name leaf)))) - (let ((entry (make-load-time-constant-tn :entry leaf)) - (closure (etypecase leaf +(defun ir2-convert-closure (ref ir2-block fun res) + (declare (type ref ref) (type ir2-block ir2-block) + (type functional fun) (type tn res)) + + (unless (leaf-info fun) + (setf (leaf-info fun) + (make-entry-info :name (functional-debug-name fun)))) + (let ((entry (make-load-time-constant-tn :entry fun)) + (closure (etypecase fun (clambda + ;; This assertion was sort of an experiment. It + ;; would be nice and sane and easier to understand + ;; things if it were *always* true, but + ;; experimentally I observe that it's only + ;; *almost* always true. -- WHN 2001-01-02 + #+nil + (aver (eql (lambda-component fun) + (block-component (ir2-block-block ir2-block)))) + ;; Check for some weirdness which came up in bug ;; 138, 2002-01-02. ;; @@ -187,26 +198,31 @@ ;; IR2-COMPONENT-ENTRIES record. That problem is ;; hard to debug when it's caught at dump time, so ;; this assertion tries to catch it here. - (aver (member leaf - (component-lambdas (lambda-component leaf)))) + (aver (member fun + (component-lambdas (lambda-component fun)))) + + ;; another bug-138-related issue: COMPONENT-NEW-FUNS + ;; is an IR1 temporary, and now that we're doing IR2 + ;; it should've been completely flushed (but wasn't). + (aver (null (component-new-funs (lambda-component fun)))) - (physenv-closure (get-lambda-physenv leaf))) + (physenv-closure (get-lambda-physenv fun))) (functional - (aver (eq (functional-kind leaf) :toplevel-xep)) + (aver (eq (functional-kind fun) :toplevel-xep)) nil)))) (cond (closure - (let ((this-env (node-physenv node))) - (vop make-closure node block entry (length closure) res) + (let ((this-env (node-physenv ref))) + (vop make-closure ref ir2-block entry (length closure) res) (loop for what in closure and n from 0 do (unless (and (lambda-var-p what) (null (leaf-refs what))) - (vop closure-init node block + (vop closure-init ref ir2-block res (find-in-physenv what this-env) n))))) (t - (emit-move node block entry res)))) + (emit-move ref ir2-block entry res)))) (values)) ;;; Convert a SET node. If the node's CONT is annotated, then we also diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp index 29d1a49..0b3a37e 100644 --- a/src/compiler/vop.lisp +++ b/src/compiler/vop.lisp @@ -108,7 +108,7 @@ (defstruct (ir2-block (:include block-annotation) (:constructor make-ir2-block (block)) (:copier nil)) - ;; the IR2-Block's number, which differs from Block's Block-Number + ;; the IR2-BLOCK's number, which differs from BLOCK's BLOCK-NUMBER ;; if any blocks are split. This is assigned by lifetime analysis. (number nil :type (or index null)) ;; information about unknown-values continuations that is used by @@ -169,7 +169,7 @@ ;; the assembler label that points to the beginning of the code for ;; this block, or NIL when we haven't assigned a label yet (%label nil) - ;; list of Location-Info structures describing all the interesting + ;; list of LOCATION-INFO structures describing all the interesting ;; (to the debugger) locations in this block (locations nil :type list)) diff --git a/version.lisp-expr b/version.lisp-expr index 6ca75f7..67a3ebe 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.111" +"0.pre7.112"