X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=871a27c46b52561f301fb73ef5913512efea35ef;hb=dfa55a883f94470267b626dae77ce7e7dfac3df6;hp=e3a1b9bc1f6eed1d2a63e53a5c3f9258291197e4;hpb=71173fc4590389c52ac0e1abd75f79e417dad361;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index e3a1b9b..871a27c 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1,4 +1,6 @@ -;;;; the top-level interfaces to the compiler +;;;; the top-level interfaces to the compiler, plus some other +;;;; compiler-related stuff (e.g. CL:CALL-ARGUMENTS-LIMIT) which +;;;; doesn't obviously belong anywhere else ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -11,6 +13,20 @@ (in-package "SB!C") +(defconstant sb!xc:call-arguments-limit most-positive-fixnum + #!+sb-doc + "The exclusive upper bound on the number of arguments which may be passed + to a function, including &REST args.") +(defconstant sb!xc:lambda-parameters-limit most-positive-fixnum + #!+sb-doc + "The exclusive upper bound on the number of parameters which may be specifed + in a given lambda list. This is actually the limit on required and &OPTIONAL + parameters. With &KEY and &AUX you can get more.") +(defconstant sb!xc:multiple-values-limit most-positive-fixnum + #!+sb-doc + "The exclusive upper bound on the number of multiple VALUES that you can + return.") + ;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp? (declaim (special *constants* *free-variables* *component-being-compiled* *code-vector* *next-location* *result-fixups* @@ -40,7 +56,8 @@ forms (evaluated at load-time) when the :BYTE-COMPILE argument is :MAYBE (the default.) When true, we decide to byte-compile.") -;;; default value of the :BYTE-COMPILE argument to the compiler +;;; the value of the :BYTE-COMPILE argument which was passed to the +;;; compiler (defvar *byte-compile* :maybe) ;;; Bound by COMPILE-COMPONENT to T when byte-compiling, and NIL when @@ -101,18 +118,13 @@ sb!xc:*compile-file-pathname* sb!xc:*compile-file-truename*)) -;;; the values of *PACKAGE* and policy when compilation started -(defvar *initial-package*) -(defvar *initial-cookie*) -(defvar *initial-interface-cookie*) - -;;; The source-info structure for the current compilation. This is null -;;; globally to indicate that we aren't currently in any identifiable -;;; compilation. +;;; the SOURCE-INFO structure for the current compilation. This is +;;; null globally to indicate that we aren't currently in any +;;; identifiable compilation. (defvar *source-info* nil) -;;; True if we are within a WITH-COMPILATION-UNIT form (which normally -;;; causes nested uses to be no-ops). +;;; This is true if we are within a WITH-COMPILATION-UNIT form (which +;;; normally causes nested uses to be no-ops). (defvar *in-compilation-unit* nil) ;;; Count of the number of compilation units dynamically enclosed by @@ -229,19 +241,19 @@ (zerop *compiler-note-count*))) (format *error-output* "~&") (pprint-logical-block (*error-output* nil :per-line-prefix "; ") - (compiler-mumble - "compilation unit ~:[finished~;aborted~]~ - ~[~:;~:*~& caught ~D fatal ERROR condition~:P~]~ - ~[~:;~:*~& caught ~D ERROR condition~:P~]~ - ~[~:;~:*~& caught ~D WARNING condition~:P~]~ - ~[~:;~:*~& caught ~D STYLE-WARNING condition~:P~]~ - ~[~:;~:*~& printed ~D note~:P~]" - abort-p - *aborted-compilation-unit-count* - *compiler-error-count* - *compiler-warning-count* - *compiler-style-warning-count* - *compiler-note-count*)))) + (compiler-mumble "compilation unit ~:[finished~;aborted~]~ + ~[~:;~:*~& caught ~D fatal ERROR condition~:P~]~ + ~[~:;~:*~& caught ~D ERROR condition~:P~]~ + ~[~:;~:*~& caught ~D WARNING condition~:P~]~ + ~[~:;~:*~& caught ~D STYLE-WARNING condition~:P~]~ + ~[~:;~:*~& printed ~D note~:P~]" + abort-p + *aborted-compilation-unit-count* + *compiler-error-count* + *compiler-warning-count* + *compiler-style-warning-count* + *compiler-note-count*))) + (format *error-output* "~&")) ;;; Evaluate BODY, then return (VALUES BODY-VALUE WARNINGS-P ;;; FAILURE-P), where BODY-VALUE is the first value of the body, and @@ -283,24 +295,42 @@ (setf (component-reanalyze component) nil)) (setf (component-reoptimize component) nil) (ir1-optimize component) - (unless (component-reoptimize component) - (maybe-mumble " ") - (return)) - (incf count) - (when (= count *max-optimize-iterations*) - (event ir1-optimize-maxed-out) - (maybe-mumble "* ") - (setf (component-reoptimize component) nil) - (do-blocks (block component) - (setf (block-reoptimize block) nil)) - (return)) + (cond ((component-reoptimize component) + (incf count) + (when (= count *max-optimize-iterations*) + (maybe-mumble "*") + (cond ((retry-delayed-ir1-transforms :optimize) + (maybe-mumble "+") + (setq count 0)) + (t + (event ir1-optimize-maxed-out) + (setf (component-reoptimize component) nil) + (do-blocks (block component) + (setf (block-reoptimize block) nil)) + (return))))) + ((retry-delayed-ir1-transforms :optimize) + (setf count 0) + (maybe-mumble "+")) + (t + (maybe-mumble " ") + (return))) (maybe-mumble ".")) (when cleared-reanalyze (setf (component-reanalyze component) t))) (values)) (defparameter *constraint-propagate* t) -(defparameter *reoptimize-after-type-check-max* 5) + +;;; KLUDGE: This was bumped from 5 to 10 in a DTC patch ported by MNA +;;; from CMU CL into sbcl-0.6.11.44, the same one which allowed IR1 +;;; transforms to be delayed. Either DTC or MNA or both didn't explain +;;; why, and I don't know what the rationale was. -- WHN 2001-04-28 +;;; +;;; FIXME: It would be good to document why it's important to have a +;;; large value here, and what the drawbacks of an excessively large +;;; value are; and it might also be good to make it depend on +;;; optimization policy. +(defparameter *reoptimize-after-type-check-max* 10) (defevent reoptimize-maxed-out "*REOPTIMIZE-AFTER-TYPE-CHECK-MAX* exceeded.") @@ -322,8 +352,9 @@ (defun ir1-phases (component) (declare (type component component)) (let ((*constraint-number* 0) - (loop-count 1)) - (declare (special *constraint-number*)) + (loop-count 1) + (*delayed-ir1-transforms* nil)) + (declare (special *constraint-number* *delayed-ir1-transforms*)) (loop (ir1-optimize-until-done component) (when (or (component-new-functions component) @@ -334,7 +365,8 @@ (when *constraint-propagate* (maybe-mumble "constraint ") (constraint-propagate component)) - (maybe-mumble "type ") + (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. @@ -342,7 +374,8 @@ (component-reanalyze component) (component-new-functions component) (component-reanalyze-functions component)) - (< loop-count (- *reoptimize-after-type-check-max* 2))) + (< loop-count (- *reoptimize-after-type-check-max* 4))) + (maybe-mumble "type ") (generate-type-checks component) (unless (or (component-reoptimize component) (component-reanalyze component) @@ -384,7 +417,7 @@ (entry-analyze component) (ir2-convert component) - (when (policy nil (>= speed cspeed)) + (when (policy *lexenv* (>= speed compilation-speed)) (maybe-mumble "copy ") (copy-propagate component)) @@ -449,11 +482,16 @@ *compile-object*)) (null)))))) - ;; We are done, so don't bother keeping anything around. + ;; We're done, so don't bother keeping anything around. (setf (component-info component) nil) (values)) +(defun policy-byte-compile-p (thing) + (policy thing + (and (zerop speed) + (<= debug 1)))) + ;;; Return our best guess for whether we will byte compile code ;;; currently being IR1 converted. This is only a guess because the ;;; decision is made on a per-component basis. @@ -463,37 +501,38 @@ (defun byte-compiling () (if (eq *byte-compiling* :maybe) (or (eq *byte-compile* t) - (policy nil (zerop speed) (<= debug 1))) + (policy-byte-compile-p *lexenv*)) (and *byte-compile* *byte-compiling*))) ;;; Delete components with no external entry points before we try to -;;; generate code. Unreachable closures can cause IR2 conversion to puke on -;;; itself, since it is the reference to the closure which normally causes the -;;; components to be combined. This doesn't really cover all cases... +;;; generate code. Unreachable closures can cause IR2 conversion to +;;; puke on itself, since it is the reference to the closure which +;;; normally causes the components to be combined. +;;; +;;; FIXME: The original CMU CL comment said "This doesn't really cover +;;; all cases..." That's a little scary. (defun delete-if-no-entries (component) (dolist (fun (component-lambdas component) (delete-component component)) (case (functional-kind fun) (:top-level (return)) (:external - (unless (every #'(lambda (ref) - (eq (block-component (node-block ref)) - component)) + (unless (every (lambda (ref) + (eq (block-component (node-block ref)) + component)) (leaf-refs fun)) (return)))))) +(defun byte-compile-this-component-p (component) + (ecase *byte-compile* + ((t) t) + ((nil) nil) + ((:maybe) + (every #'policy-byte-compile-p (component-lambdas component))))) + (defun compile-component (component) (let* ((*component-being-compiled* component) - (*byte-compiling* - (ecase *byte-compile* - ((t) t) - ((nil) nil) - (:maybe - (dolist (fun (component-lambdas component) t) - (unless (policy (lambda-bind fun) - (zerop speed) (<= debug 1)) - (return nil))))))) - + (*byte-compiling* (byte-compile-this-component-p component))) (when sb!xc:*compile-print* (compiler-mumble "~&; ~:[~;byte ~]compiling ~A: " *byte-compiling* @@ -596,8 +635,8 @@ (clrhash *id-labels*) (setq *label-id* 0) - ;; Clear some Pack data structures (for GC purposes only). - (assert (not *in-pack*)) + ;; Clear some PACK data structures (for GC purposes only). + (aver (not *in-pack*)) (dolist (sb *backend-sb-list*) (when (finite-sb-p sb) (fill (finite-sb-live-tns sb) nil)))) @@ -647,24 +686,26 @@ ;;;; Source-Info structure. The bookkeeping is done as a side-effect ;;;; of getting the next source form. -;;; The File-Info structure holds all the source information for a +;;; A FILE-INFO structure holds all the source information for a ;;; given file. -(defstruct file-info - ;; If a file, the truename of the corresponding source file. If from a Lisp - ;; form, :LISP, if from a stream, :STREAM. +(defstruct (file-info (:copier nil)) + ;; If a file, the truename of the corresponding source file. If from + ;; a Lisp form, :LISP. If from a stream, :STREAM. (name (required-argument) :type (or pathname (member :lisp :stream))) - ;; 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 debug-info. + ;; 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 + ;; debug-info. (untruename nil :type (or pathname null)) - ;; The file's write date (if relevant.) + ;; the file's write date (if relevant) (write-date nil :type (or unsigned-byte null)) - ;; The source path root number of the first form in this file (i.e. the - ;; total number of forms converted previously in this compilation.) + ;; the source path root number of the first form in this file (i.e. + ;; the total number of forms converted previously in this + ;; compilation) (source-root 0 :type unsigned-byte) - ;; Parallel vectors containing the forms read out of the file and the file - ;; positions that reading of each form started at (i.e. the end of the - ;; previous form.) + ;; parallel vectors containing the forms read out of the file and + ;; the file positions that reading of each form started at (i.e. the + ;; end of the previous form) (forms (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t)) (positions (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t))) @@ -673,7 +714,8 @@ (defstruct (source-info #-no-ansi-print-object (:print-object (lambda (s stream) - (print-unreadable-object (s stream :type t))))) + (print-unreadable-object (s stream :type t)))) + (:copier nil)) ;; the UT that compilation started at (start-time (get-universal-time) :type unsigned-byte) ;; a list of the FILE-INFO structures for this compilation @@ -797,22 +839,19 @@ '(cerror "Skip this form." "compile-time read error")))) -;;; If Stream is present, return it, otherwise open a stream to the +;;; If STREAM is present, return it, otherwise open a stream to the ;;; current file. There must be a current file. When we open a new ;;; file, we also reset *PACKAGE* and policy. This gives the effect of ;;; rebinding around each file. ;;; ;;; FIXME: Since we now do the standard ANSI thing of only one file -;;; per compile (unlike the CMU CL extended COMPILE-FILE) can't this -;;; complexity (including ADVANCE-SOURCE-FILE) go away? +;;; per compile (unlike the CMU CL extended COMPILE-FILE) this code is +;;; becoming stale, and the remaining bits of it (and the related code +;;; in ADVANCE-SOURCE-FILE) can go away. (defun get-source-stream (info) (declare (type source-info info)) (cond ((source-info-stream info)) (t - (setq *package* *initial-package*) - (setq *default-cookie* (copy-cookie *initial-cookie*)) - (setq *default-interface-cookie* - (copy-cookie *initial-interface-cookie*)) (let* ((finfo (first (source-info-current-file info))) (name (file-info-name finfo))) (setq sb!xc:*compile-file-truename* name) @@ -890,8 +929,7 @@ ;;; *TOP-LEVEL-LAMBDAS* instead. (defun convert-and-maybe-compile (form path) (declare (list path)) - (let* ((*lexenv* (make-lexenv :cookie *default-cookie* - :interface-cookie *default-interface-cookie*)) + (let* ((*lexenv* (make-lexenv :policy *policy*)) (tll (ir1-top-level form path nil))) (cond ((eq *block-compile* t) (push tll *top-level-lambdas*)) (t (compile-top-level (list tll) nil))))) @@ -913,20 +951,21 @@ ;;; Process a top-level use of LOCALLY. We parse declarations and then ;;; recursively process the body. -;;; -;;; Binding *DEFAULT-xxx-COOKIE* is pretty much of a hack, since it -;;; causes LOCALLY to "capture" enclosed proclamations. It is -;;; necessary because CONVERT-AND-MAYBE-COMPILE uses the value of -;;; *DEFAULT-COOKIE* as the policy. The need for this hack is due to -;;; the quirk that there is no way to represent in a cookie that an -;;; optimize quality came from the default. (defun process-top-level-locally (form path) (declare (list path)) (multiple-value-bind (forms decls) (sb!sys:parse-body (cdr form) nil) (let* ((*lexenv* (process-decls decls nil nil (make-continuation))) - (*default-cookie* (lexenv-cookie *lexenv*)) - (*default-interface-cookie* (lexenv-interface-cookie *lexenv*))) + ;; Binding *POLICY* is pretty much of a hack, since it + ;; causes LOCALLY to "capture" enclosed proclamations. It + ;; is necessary because CONVERT-AND-MAYBE-COMPILE uses the + ;; value of *POLICY* as the policy. The need for this hack + ;; is due to the quirk that there is no way to represent in + ;; a POLICY that an optimize quality came from the default. + ;; FIXME: Ideally, something should be done so that DECLAIM + ;; inside LOCALLY works OK. Failing that, at least we could + ;; issue a warning instead of silently screwing up. + (*policy* (lexenv-policy *lexenv*))) (process-top-level-progn forms path)))) ;;; Force any pending top-level forms to be compiled and dumped so @@ -1058,7 +1097,7 @@ ;;; the name. If not in a :TOP-LEVEL component, then don't bother ;;; compiling, because it was merged with a run-time component. (defun compile-load-time-value-lambda (lambdas) - (assert (null (cdr lambdas))) + (aver (null (cdr lambdas))) (let* ((lambda (car lambdas)) (component (block-component (node-block (lambda-bind lambda))))) (when (eq (component-kind component) :top-level) @@ -1116,7 +1155,7 @@ (defvar *constants-created-since-last-init* nil) ;;; FIXME: Shouldn't these^ variables be bound in LET forms? (defun emit-make-load-form (constant) - (assert (fasl-file-p *compile-object*)) + (aver (fasl-file-p *compile-object*)) (unless (or (fasl-constant-already-dumped constant *compile-object*) ;; KLUDGE: This special hack is because I was too lazy ;; to rework DEF!STRUCT so that the MAKE-LOAD-FORM @@ -1351,12 +1390,7 @@ #+nil (*compiler-note-count* 0) (*block-compile* *block-compile-argument*) (*package* (sane-package)) - (*initial-package* (sane-package)) - (*initial-cookie* *default-cookie*) - (*initial-interface-cookie* *default-interface-cookie*) - (*default-cookie* (copy-cookie *initial-cookie*)) - (*default-interface-cookie* - (copy-cookie *initial-interface-cookie*)) + (*policy* *policy*) (*lexenv* (make-null-lexenv)) (*converting-for-interpreter* nil) (*source-info* info) @@ -1448,9 +1482,9 @@ ;;; out of the compile, then abort the writing of the output file, so ;;; we don't overwrite it with known garbage. (defun sb!xc:compile-file - (source + (input-file &key - (output-file t) ; FIXME: ANSI says this should be a pathname designator. + (output-file (cfp-output-file-default input-file)) ;; FIXME: ANSI doesn't seem to say anything about ;; *COMPILE-VERBOSE* and *COMPILE-PRINT* being rebound by this ;; function.. @@ -1461,9 +1495,9 @@ ((:entry-points *entry-points*) nil) ((:byte-compile *byte-compile*) *byte-compile-default*)) #!+sb-doc - "Compile SOURCE, producing a corresponding FASL file. + "Compile INPUT-FILE, producing a corresponding fasl file. :Output-File - The name of the fasl to output, NIL for none, T for the default. + The name of the fasl to output. :Block-Compile Determines whether multiple functions are compiled together as a unit, resolving function references at compile time. NIL means that global @@ -1486,7 +1520,6 @@ (compile-won nil) (warnings-p nil) (failure-p t) ; T in case error keeps this from being set later - ;; KLUDGE: The listifying and unlistifying in the next calls ;; is to interface to old CMU CL code which accepted and ;; returned lists of multiple source files. It would be @@ -1494,18 +1527,17 @@ ;; VERIFY-SOURCE-FILE, accepting a single source file, and ;; do a similar transformation on MAKE-FILE-SOURCE-INFO too. ;; -- WHN 20000201 - (source (first (verify-source-files (list source)))) - (source-info (make-file-source-info (list source)))) + (input-pathname (first (verify-source-files (list input-file)))) + (source-info (make-file-source-info (list input-pathname)))) (unwind-protect (progn (when output-file (setq output-file-name - (sb!xc:compile-file-pathname source - :output-file output-file - :byte-compile *byte-compile*)) + (sb!xc:compile-file-pathname input-file + :output-file output-file)) (setq fasl-file (open-fasl-file output-file-name - (namestring source) + (namestring input-pathname) (eq *byte-compile* t)))) (when sb!xc:*compile-verbose* @@ -1534,22 +1566,36 @@ warnings-p failure-p))) -(defun sb!xc:compile-file-pathname (file-path - &key (output-file t) byte-compile +;;; a helper function for COMPILE-FILE-PATHNAME: the default for +;;; the OUTPUT-FILE argument +;;; +;;; ANSI: The defaults for the OUTPUT-FILE are taken from the pathname +;;; that results from merging the INPUT-FILE with the value of +;;; *DEFAULT-PATHNAME-DEFAULTS*, except that the type component should +;;; default to the appropriate implementation-defined default type for +;;; compiled files. +(defun cfp-output-file-default (input-file) + (let* ((defaults (merge-pathnames input-file + *default-pathname-defaults*)) + (retyped (make-pathname :type *backend-fasl-file-type* + :defaults defaults))) + retyped)) + +;;; KLUDGE: Part of the ANSI spec for this seems contradictory: +;;; If INPUT-FILE is a logical pathname and OUTPUT-FILE is unsupplied, +;;; the result is a logical pathname. If INPUT-FILE is a logical +;;; pathname, it is translated into a physical pathname as if by +;;; calling TRANSLATE-LOGICAL-PATHNAME. +;;; So I haven't really tried to make this precisely ANSI-compatible +;;; at the level of e.g. whether it returns logical pathname or a +;;; physical pathname. Patches to make it more correct are welcome. +;;; -- WHN 2000-12-09 +(defun sb!xc:compile-file-pathname (input-file + &key + (output-file (cfp-output-file-default + input-file)) &allow-other-keys) #!+sb-doc "Return a pathname describing what file COMPILE-FILE would write to given these arguments." - (declare (values (or null pathname))) - (let ((pathname (pathname file-path))) - (cond ((not (eq output-file t)) - (when output-file - (translate-logical-pathname (pathname output-file)))) - ((and (typep pathname 'logical-pathname) (not (eq byte-compile t))) - (make-pathname :type "FASL" :defaults pathname - :case :common)) - (t - (make-pathname :defaults (translate-logical-pathname pathname) - :type (if (eq byte-compile t) - (backend-byte-fasl-file-type) - *backend-fasl-file-type*)))))) + (pathname output-file))