X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=b5ad7f1dc679308cb878d0dd282edb08ded2ee83;hb=75f29fee61a19b3607bd8fafa8a31184c998c5b0;hp=17a2539e421192bcb623df0cabada4bc26255cd5;hpb=b05f52060838600d14b5d8ad4604a61351dd7017;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 17a2539..b5ad7f1 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -14,10 +14,10 @@ (in-package "SB!C") ;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp? -(declaim (special *constants* *free-variables* *component-being-compiled* +(declaim (special *constants* *free-vars* *component-being-compiled* *code-vector* *next-location* *result-fixups* - *free-functions* *source-paths* - *seen-blocks* *seen-functions* *list-conflicts-table* + *free-funs* *source-paths* + *seen-blocks* *seen-funs* *list-conflicts-table* *continuation-number* *continuation-numbers* *number-continuations* *tn-id* *tn-ids* *id-tns* *label-ids* *label-id* *id-labels* @@ -40,13 +40,11 @@ ;;; :BLOCK-COMPILE and :ENTRY-POINTS arguments that COMPILE-FILE was ;;; called with. ;;; -;;; *BLOCK-COMPILE-ARGUMENT* holds the original value of the -;;; :BLOCK-COMPILE argument, which overrides any internal -;;; declarations. +;;; *BLOCK-COMPILE-ARG* holds the original value of the :BLOCK-COMPILE +;;; argument, which overrides any internal declarations. (defvar *block-compile*) -(defvar *block-compile-argument*) -(declaim (type (member nil t :specified) - *block-compile* *block-compile-argument*)) +(defvar *block-compile-arg*) +(declaim (type (member nil t :specified) *block-compile* *block-compile-arg*)) (defvar *entry-points*) (declaim (list *entry-points*)) @@ -163,22 +161,22 @@ (warning #'compiler-warning-handler)) (let ((undefs (sort *undefined-warnings* #'string< - :key #'(lambda (x) - (let ((x (undefined-warning-name x))) - (if (symbolp x) - (symbol-name x) - (prin1-to-string x))))))) + :key (lambda (x) + (let ((x (undefined-warning-name x))) + (if (symbolp x) + (symbol-name x) + (prin1-to-string x))))))) (dolist (undef undefs) (let ((name (undefined-warning-name undef)) (kind (undefined-warning-kind undef)) (warnings (undefined-warning-warnings undef)) (undefined-warning-count (undefined-warning-count undef))) (dolist (*compiler-error-context* warnings) - (compiler-style-warning "undefined ~(~A~): ~S" kind name)) + (compiler-style-warn "undefined ~(~A~): ~S" kind name)) (let ((warn-count (length warnings))) (when (and warnings (> undefined-warning-count warn-count)) (let ((more (- undefined-warning-count warn-count))) - (compiler-style-warning + (compiler-style-warn "~W more use~:P of undefined ~(~A~) ~S" more kind name)))))) @@ -187,7 +185,7 @@ (remove kind undefs :test-not #'eq :key #'undefined-warning-kind)))) (when summary - (compiler-style-warning + (compiler-style-warn "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~ ~% ~{~<~% ~1:;~S~>~^ ~}" (cdr summary) kind summary))))))) @@ -310,14 +308,15 @@ ;;; Do all the IR1 phases for a non-top-level component. (defun ir1-phases (component) (declare (type component component)) + (aver-live-component component) (let ((*constraint-number* 0) (loop-count 1) (*delayed-ir1-transforms* nil)) (declare (special *constraint-number* *delayed-ir1-transforms*)) (loop (ir1-optimize-until-done component) - (when (or (component-new-funs component) - (component-reanalyze-funs component)) + (when (or (component-new-functionals component) + (component-reanalyze-functionals component)) (maybe-mumble "locall ") (locall-analyze-component component)) (dfo-as-needed component) @@ -326,21 +325,20 @@ (constraint-propagate component)) (when (retry-delayed-ir1-transforms :constraint) (maybe-mumble "Rtran ")) - ;; Delay the generation of type checks until the type - ;; constraints have had time to propagate, else the compiler can - ;; confuse itself. - (unless (and (or (component-reoptimize component) - (component-reanalyze component) - (component-new-funs component) - (component-reanalyze-funs component)) - (< loop-count (- *reoptimize-after-type-check-max* 4))) - (maybe-mumble "type ") - (generate-type-checks component) - (unless (or (component-reoptimize component) - (component-reanalyze component) - (component-new-funs component) - (component-reanalyze-funs component)) - (return))) + (flet ((want-reoptimization-p () + (or (component-reoptimize component) + (component-reanalyze component) + (component-new-functionals component) + (component-reanalyze-functionals component)))) + (unless (and (want-reoptimization-p) + ;; We delay the generation of type checks until + ;; the type constraints have had time to + ;; propagate, else the compiler can confuse itself. + (< loop-count (- *reoptimize-after-type-check-max* 4))) + (maybe-mumble "type ") + (generate-type-checks component) + (unless (want-reoptimization-p) + (return)))) (when (>= loop-count *reoptimize-after-type-check-max*) (maybe-mumble "[reoptimize limit]") (event reoptimize-maxed-out) @@ -440,7 +438,7 @@ (null)))))) ;; We're done, so don't bother keeping anything around. - (setf (component-info component) nil) + (setf (component-info component) :dead) (values)) @@ -456,12 +454,27 @@ (:toplevel (return)) (:external (unless (every (lambda (ref) - (eq (block-component (node-block ref)) - component)) + (eq (node-component ref) component)) (leaf-refs fun)) (return)))))) (defun compile-component (component) + + ;; miscellaneous sanity checks + ;; + ;; FIXME: These are basically pretty wimpy compared to the checks done + ;; by the old CHECK-IR1-CONSISTENCY code. It would be really nice to + ;; make those internal consistency checks work again and use them. + (aver-live-component component) + (do-blocks (block component) + (aver (eql (block-component block) component))) + (dolist (lambda (component-lambdas component)) + ;; sanity check to prevent weirdness from propagating insidiously as + ;; far from its root cause as it did in bug 138: Make sure that + ;; thing-to-COMPONENT links are consistent. + (aver (eql (lambda-component lambda) component)) + (aver (eql (node-component (lambda-bind lambda)) component))) + (let* ((*component-being-compiled* component)) (when sb!xc:*compile-print* (compiler-mumble "~&; compiling ~A: " (component-name component))) @@ -492,22 +505,22 @@ ;;;; global data structures entirely when possible and consing up the ;;;; others from scratch instead of clearing and reusing them? -;;; Clear the INFO in constants in the *FREE-VARIABLES*, etc. In +;;; Clear the INFO in constants in the *FREE-VARS*, etc. In ;;; addition to allowing stuff to be reclaimed, this is required for ;;; correct assignment of constant offsets, since we need to assign a ;;; new offset for each component. We don't clear the FUNCTIONAL-INFO ;;; slots, since they are used to keep track of functions across ;;; component boundaries. (defun clear-constant-info () - (maphash #'(lambda (k v) - (declare (ignore k)) - (setf (leaf-info v) nil)) + (maphash (lambda (k v) + (declare (ignore k)) + (setf (leaf-info v) nil)) *constants*) - (maphash #'(lambda (k v) - (declare (ignore k)) - (when (constant-p v) - (setf (leaf-info v) nil))) - *free-variables*) + (maphash (lambda (k v) + (declare (ignore k)) + (when (constant-p v) + (setf (leaf-info v) nil))) + *free-vars*) (values)) ;;; Blow away the REFS for all global variables, and let COMPONENT @@ -515,19 +528,19 @@ (defun clear-ir1-info (component) (declare (type component component)) (labels ((blast (x) - (maphash #'(lambda (k v) - (declare (ignore k)) - (when (leaf-p v) - (setf (leaf-refs v) - (delete-if #'here-p (leaf-refs v))) - (when (basic-var-p v) - (setf (basic-var-sets v) - (delete-if #'here-p (basic-var-sets v)))))) + (maphash (lambda (k v) + (declare (ignore k)) + (when (leaf-p v) + (setf (leaf-refs v) + (delete-if #'here-p (leaf-refs v))) + (when (basic-var-p v) + (setf (basic-var-sets v) + (delete-if #'here-p (basic-var-sets v)))))) x)) (here-p (x) - (eq (block-component (node-block x)) component))) - (blast *free-variables*) - (blast *free-functions*) + (eq (node-component x) component))) + (blast *free-vars*) + (blast *free-funs*) (blast *constants*)) (values)) @@ -540,14 +553,14 @@ (defun clear-stuff (&optional (debug-too t)) ;; Clear global tables. - (when (boundp '*free-functions*) - (clrhash *free-functions*) - (clrhash *free-variables*) + (when (boundp '*free-funs*) + (clrhash *free-funs*) + (clrhash *free-vars*) (clrhash *constants*)) ;; Clear debug counters and tables. (clrhash *seen-blocks*) - (clrhash *seen-functions*) + (clrhash *seen-funs*) (clrhash *list-conflicts-table*) (when debug-too @@ -580,7 +593,7 @@ ;;;; trace output -;;; Print out some useful info about Component to Stream. +;;; Print out some useful info about COMPONENT to STREAM. (defun describe-component (component *standard-output*) (declare (type component component)) (format t "~|~%;;;; component: ~S~2%" (component-name component)) @@ -609,7 +622,7 @@ ;;;; the error context and for recovering from errors. ;;;; ;;;; The interface we provide to this stuff is the stream-oid -;;;; Source-Info structure. The bookkeeping is done as a side-effect +;;;; SOURCE-INFO structure. The bookkeeping is done as a side effect ;;;; of getting the next source form. ;;; A FILE-INFO structure holds all the source information for a @@ -1102,15 +1115,8 @@ ;;; Compile FORM and arrange for it to be called at load-time. Return ;;; the dumper handle and our best guess at the type of the object. -(defun compile-load-time-value - (form &optional - (name (let ((*print-level* 2) (*print-length* 3)) - (format nil "load time value of ~S" - (if (and (listp form) - (eq (car form) 'make-value-cell)) - (second form) - form))))) - (let ((lambda (compile-load-time-stuff form name t))) +(defun compile-load-time-value (form) + (let ((lambda (compile-load-time-stuff form t))) (values (fasl-dump-load-time-value-lambda lambda *compile-object*) (let ((type (leaf-type lambda))) @@ -1120,13 +1126,13 @@ ;;; Compile the FORMS and arrange for them to be called (for effect, ;;; not value) at load time. -(defun compile-make-load-form-init-forms (forms name) - (let ((lambda (compile-load-time-stuff `(progn ,@forms) name nil))) +(defun compile-make-load-form-init-forms (forms) + (let ((lambda (compile-load-time-stuff `(progn ,@forms) nil))) (fasl-dump-toplevel-lambda-call lambda *compile-object*))) -;;; Does the actual work of COMPILE-LOAD-TIME-VALUE or -;;; COMPILE-MAKE-LOAD-FORM- INIT-FORMS. -(defun compile-load-time-stuff (form name for-value) +;;; Do the actual work of COMPILE-LOAD-TIME-VALUE or +;;; COMPILE-MAKE-LOAD-FORM-INIT-FORMS. +(defun compile-load-time-stuff (form for-value) (with-ir1-namespace (let* ((*lexenv* (make-null-lexenv)) (lambda (ir1-toplevel form *current-path* for-value))) @@ -1216,9 +1222,7 @@ (flet ((loser (start) (or (position-if (lambda (x) (not (eq (component-kind - (block-component - (node-block - (lambda-bind x)))) + (node-component (lambda-bind x))) :toplevel))) lambdas :start start) @@ -1289,7 +1293,7 @@ ;;; Return (VALUES NIL WARNINGS-P FAILURE-P). (defun sub-compile-file (info) (declare (type source-info info)) - (let* ((*block-compile* *block-compile-argument*) + (let* ((*block-compile* *block-compile-arg*) (*package* (sane-package)) (*policy* *policy*) (*lexenv* (make-null-lexenv)) @@ -1402,7 +1406,7 @@ ;; extensions (trace-file nil) - ((:block-compile *block-compile-argument*) nil)) + ((:block-compile *block-compile-arg*) nil)) #!+sb-doc "Compile INPUT-FILE, producing a corresponding fasl file and returning @@ -1571,7 +1575,7 @@ ;;; deal with it. (defvar *constants-being-created* nil) (defvar *constants-created-since-last-init* nil) -;;; FIXME: Shouldn't these^ variables be bound in LET forms? +;;; FIXME: Shouldn't these^ variables be unbound outside LET forms? (defun emit-make-load-form (constant) (aver (fasl-output-p *compile-object*)) (unless (or (fasl-constant-already-dumped-p constant *compile-object*) @@ -1619,8 +1623,7 @@ (fasl-note-handle-for-constant constant (compile-load-time-value - creation-form - (format nil "creation form for ~A" name)) + creation-form) *compile-object*) nil) (compiler-error "circular references in creation form for ~S" @@ -1632,11 +1635,7 @@ (loop for (name form) on (cdr info) by #'cddr collect name into names collect form into forms - finally - (compile-make-load-form-init-forms - forms - (format nil "init form~:[~;s~] for ~{~A~^, ~}" - (cdr forms) names))) + finally (compile-make-load-form-init-forms forms)) nil))) (when circular-ref (setf (cdr circular-ref)