X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fmain.lisp;h=39e1d69037d85aab3c66a7cd8e3ecbd5c5641cd7;hb=079ef9dad558ca07cb8178ef428bf738112174fa;hp=3a96c2bbdd024a97c09288615189b74641b68394;hpb=8375acd89ba695e2fc838fffd5211a5ddf9c3b0d;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 3a96c2b..39e1d69 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -28,7 +28,8 @@ #!+sb-show *compiler-trace-output* *last-source-context* *last-original-source* *last-source-form* *last-format-string* *last-format-args* - *last-message-count* *lexenv* *fun-names-in-this-file*)) + *last-message-count* *lexenv* *fun-names-in-this-file* + *allow-instrumenting*)) ;;; Whether call of a function which cannot be defined causes a full ;;; warning. @@ -37,6 +38,9 @@ (defvar *check-consistency* nil) (defvar *all-components*) +;;; Set to NIL to disable loop analysis for register allocation. +(defvar *loop-analyze* t) + ;;; Bind this to a stream to capture various internal debugging output. (defvar *compiler-trace-output* nil) @@ -116,12 +120,12 @@ is intended to be wrapped around the compilation of all files in the same system. These keywords are defined: :OVERRIDE Boolean-Form - One of the effects of this form is to delay undefined warnings - until the end of the form, instead of giving them at the end of each - compilation. If OVERRIDE is NIL (the default), then the outermost - WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying - OVERRIDE true causes that form to grab any enclosed warnings, even if - it is enclosed by another WITH-COMPILATION-UNIT." + One of the effects of this form is to delay undefined warnings + until the end of the form, instead of giving them at the end of each + compilation. If OVERRIDE is NIL (the default), then the outermost + WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying + OVERRIDE true causes that form to grab any enclosed warnings, even if + it is enclosed by another WITH-COMPILATION-UNIT." `(%with-compilation-unit (lambda () ,@body) ,@options)) (defun %with-compilation-unit (fn &key override) @@ -196,7 +200,7 @@ (t (compiler-warn "~@" kind name))) @@ -221,12 +225,12 @@ (when summary (if (eq kind :variable) (compiler-warn - "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~ - ~% ~{~<~% ~1:;~S~>~^ ~}" + "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~ + ~% ~{~<~% ~1:;~S~>~^ ~}" (cdr summary) kind summary) (compiler-style-warn - "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~ - ~% ~{~<~% ~1:;~S~>~^ ~}" + "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~ + ~% ~{~<~% ~1:;~S~>~^ ~}" (cdr summary) kind summary)))))))) (unless (and (not abort-p) @@ -283,17 +287,20 @@ (maybe-mumble "opt") (event ir1-optimize-until-done) (let ((count 0) - (cleared-reanalyze nil)) + (cleared-reanalyze nil) + (fastp nil)) (loop (when (component-reanalyze component) (setq count 0) (setq cleared-reanalyze t) (setf (component-reanalyze component) nil)) (setf (component-reoptimize component) nil) - (ir1-optimize component) + (ir1-optimize component fastp) (cond ((component-reoptimize component) (incf count) - (when (= count *max-optimize-iterations*) + (when (and (>= count *max-optimize-iterations*) + (not (component-reanalyze component)) + (eq (component-reoptimize component) :maybe)) (maybe-mumble "*") (cond ((retry-delayed-ir1-transforms :optimize) (maybe-mumble "+") @@ -310,7 +317,8 @@ (t (maybe-mumble " ") (return))) - (maybe-mumble ".")) + (setq fastp (>= count *max-optimize-iterations*)) + (maybe-mumble (if fastp "-" "."))) (when cleared-reanalyze (setf (component-reanalyze component) t))) (values)) @@ -398,7 +406,8 @@ (maybe-mumble "control ") (control-analyze component #'make-ir2-block) - (when (ir2-component-values-receivers (component-info component)) + (when (or (ir2-component-values-receivers (component-info component)) + (component-dx-lvars component)) (maybe-mumble "stack ") (stack-analyze component) ;; Assign BLOCK-NUMBER for any cleanup blocks introduced by @@ -521,6 +530,25 @@ (ir1-phases component) + (when *loop-analyze* + (dfo-as-needed component) + (find-dominators component) + (loop-analyze component)) + + #| + (when (and *loop-analyze* *compiler-trace-output*) + (labels ((print-blocks (block) + (format *compiler-trace-output* " ~A~%" block) + (when (block-loop-next block) + (print-blocks (block-loop-next block)))) + (print-loop (loop) + (format *compiler-trace-output* "loop=~A~%" loop) + (print-blocks (loop-blocks loop)) + (dolist (l (loop-inferiors loop)) + (print-loop l)))) + (print-loop (component-outer-loop component)))) + |# + ;; FIXME: What is MAYBE-MUMBLE for? Do we need it any more? (maybe-mumble "env ") (physenv-analyze component) @@ -641,7 +669,7 @@ (format t "~4TL~D: ~S~:[~; [closure]~]~%" (label-id (entry-info-offset entry)) (entry-info-name entry) - (entry-info-closure-p entry))) + (entry-info-closure-tn entry))) (terpri) (pre-pack-tn-stats component *standard-output*) (terpri) @@ -665,6 +693,8 @@ ;; If a file, the truename of the corresponding source file. If from ;; a Lisp form, :LISP. If from a stream, :STREAM. (name (missing-arg) :type (or pathname (member :lisp :stream))) + ;; the external format that we'll call OPEN with, if NAME is a file. + (external-format nil) ;; the defaulted, but not necessarily absolute file name (i.e. prior ;; to TRUENAME call.) Null if not a file. This is used to set ;; *COMPILE-FILE-PATHNAME*, and if absolute, is dumped in the @@ -698,9 +728,10 @@ (stream nil :type (or stream null))) ;;; Given a pathname, return a SOURCE-INFO structure. -(defun make-file-source-info (file) +(defun make-file-source-info (file external-format) (let ((file-info (make-file-info :name (truename file) :untruename file + :external-format external-format :write-date (file-write-date file)))) (make-source-info :file-info file-info))) @@ -727,7 +758,7 @@ (handler-case (read stream nil stream) (reader-error (condition) (error 'input-error-in-compile-file - :error condition + :condition condition ;; We don't need to supply :POSITION here because ;; READER-ERRORs already know their position in the file. )) @@ -736,7 +767,7 @@ ;; file in the middle of something it's trying to read. (end-of-file (condition) (error 'input-error-in-compile-file - :error condition + :condition condition ;; We need to supply :POSITION here because the END-OF-FILE ;; condition doesn't carry the position that the user ;; probably cares about, where the failed READ began. @@ -757,10 +788,13 @@ (declare (type source-info info)) (or (source-info-stream info) (let* ((file-info (source-info-file-info info)) - (name (file-info-name file-info))) + (name (file-info-name file-info)) + (external-format (file-info-external-format file-info))) (setf sb!xc:*compile-file-truename* name sb!xc:*compile-file-pathname* (file-info-untruename file-info) - (source-info-stream info) (open name :direction :input))))) + (source-info-stream info) + (open name :direction :input + :external-format external-format))))) ;;; Close the stream in INFO if it is open. (defun close-source-info (info) @@ -913,14 +947,11 @@ (setf (component-name component) (debug-namify "~S initial component" name)) (setf (component-kind component) :initial) - (let* ((locall-fun (ir1-convert-lambdalike - definition - :debug-name (debug-namify "top level local call " - name) - ;; KLUDGE: we do this so that we get to have - ;; nice debug returnness in functions defined - ;; from the REPL - :allow-debug-catch-tag t)) + (let* ((locall-fun (let ((*allow-instrumenting* t)) + (ir1-convert-lambdalike + definition + :debug-name (debug-namify "top level local call " + name)))) (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun) :source-name (or name '.anonymous.) :debug-name (unless name @@ -954,7 +985,8 @@ '(original-source-start 0 0))) (when name (legal-fun-name-or-type-error name)) - (let* ((*lexenv* (make-lexenv :policy *policy* + (let* ( + (*lexenv* (make-lexenv :policy *policy* :handled-conditions *handled-conditions* :disabled-package-locks *disabled-package-locks*)) (fun (make-functional-from-toplevel-lambda lambda-expression @@ -970,18 +1002,12 @@ ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..) (locall-analyze-clambdas-until-done (list fun)) - + (multiple-value-bind (components-from-dfo top-components hairy-top) (find-initial-dfo (list fun)) + (declare (ignore hairy-top)) (let ((*all-components* (append components-from-dfo top-components))) - ;; FIXME: This is more monkey see monkey do based on CMU CL - ;; code. If anyone figures out why to only prescan HAIRY-TOP - ;; and TOP-COMPONENTS here, instead of *ALL-COMPONENTS* or - ;; some other combination of results from FIND-INITIAL-VALUES, - ;; it'd be good to explain it. - (mapc #'preallocate-physenvs-for-toplevelish-lambdas hairy-top) - (mapc #'preallocate-physenvs-for-toplevelish-lambdas top-components) (dolist (component-from-dfo components-from-dfo) (compile-component component-from-dfo) (replace-toplevel-xeps component-from-dfo))) @@ -1402,6 +1428,7 @@ (*source-info* info) (*toplevel-lambdas* ()) (*fun-names-in-this-file* ()) + (*allow-instrumenting* nil) (*compiler-error-bailout* (lambda () (compiler-mumble "~2&; fatal error, aborting compilation~%") @@ -1438,9 +1465,10 @@ ;; Some errors are sufficiently bewildering that we just fail ;; immediately, without trying to recover and compile more of ;; the input file. - (input-error-in-compile-file (condition) + (fatal-compiler-error (condition) + (signal condition) (format *error-output* - "~@" + "~@" condition) (values nil t t))))) @@ -1511,7 +1539,7 @@ #!+sb-doc "Compile INPUT-FILE, producing a corresponding fasl file and returning its filename. Besides the ANSI &KEY arguments :OUTPUT-FILE, :VERBOSE, - :PRINT, and :EXTERNAL-FORMAT,the following extensions are supported: + :PRINT, and :EXTERNAL-FORMAT, the following extensions are supported: :TRACE-FILE If given, internal data structures are dumped to the specified file, or if a value of T is given, to a file of *.trace type @@ -1530,15 +1558,13 @@ optimization values, and the :BLOCK-COMPILE argument will probably become deprecated." - (unless (eq external-format :default) - (error "Non-:DEFAULT EXTERNAL-FORMAT values are not supported.")) (let* ((fasl-output nil) (output-file-name nil) (compile-won nil) (warnings-p nil) (failure-p t) ; T in case error keeps this from being set later (input-pathname (verify-source-file input-file)) - (source-info (make-file-source-info input-pathname)) + (source-info (make-file-source-info input-pathname external-format)) (*compiler-trace-output* nil)) ; might be modified below (unwind-protect