-;;;; 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.
(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*
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
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
;;; Mumble conditional on *COMPILE-PROGRESS*.
(defun maybe-mumble (&rest foo)
(when *compile-progress*
- (apply #'compiler-mumble foo)))
+ (compiler-mumble "~&")
+ (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
+ (apply #'compiler-mumble foo))))
(deftype object () '(or fasl-file core-object null))
(zerop *compiler-warning-count*)
(zerop *compiler-style-warning-count*)
(zerop *compiler-note-count*)))
- (compiler-mumble
- "~2&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~]~2%"
- abort-p
- *aborted-compilation-unit-count*
- *compiler-error-count*
- *compiler-warning-count*
- *compiler-style-warning-count*
- *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*)))
+ (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
(entry-analyze component)
(ir2-convert component)
- (when (policy nil (>= speed cspeed))
+ (when (policy nil (>= speed compilation-speed))
(maybe-mumble "copy ")
(copy-propagate component))
(defun byte-compiling ()
(if (eq *byte-compiling* :maybe)
(or (eq *byte-compile* t)
- (policy nil (zerop speed) (<= debug 1)))
+ ;; FIXME: It's bad to share this expression between this
+ ;; function and LAMBDA-IS-BYTE-COMPILABLE-P (and who knows
+ ;; where else?), it should be factored out into some
+ ;; common function.
+ (policy nil (and (zerop speed) (<= debug 1))))
(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 lambda-is-byte-compilable-p (lambda)
+ #|
+ (format t "~S SPEED=~S DEBUG=~S~%" ; REMOVEME
+ lambda
+ (policy (lambda-bind lambda) speed)
+ (policy (lambda-bind lambda) debug))
+ |#
+ (policy (lambda-bind lambda)
+ (and (zerop speed) (<= debug 1))))
+
+(defun byte-compile-this-component-p (component)
+ (ecase *byte-compile*
+ ((t) t)
+ ((nil) nil)
+ ((:maybe)
+ (every #'lambda-is-byte-compilable-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: "
+ (compiler-mumble "~&; ~:[~;byte ~]compiling ~A: "
*byte-compiling*
(component-name component)))
(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))))
;;;; 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))
- ;; This file's FILE-COMMENT, or NIL if none.
- (comment nil :type (or simple-string 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)))
(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
'(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)
;;; *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)))))
;;; 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))))
-;;; Stash file comment in the FILE-INFO structure.
-(defun process-file-comment (form)
- (unless (and (proper-list-of-length-p form 2)
- (stringp (second form)))
- (compiler-error "bad FILE-COMMENT form: ~S" form))
- (let ((file (first (source-info-current-file *source-info*))))
- (cond ((file-info-comment file)
- (compiler-warning "ignoring extra file comment:~% ~S" form))
- (t
- (let ((comment (coerce (second form) 'simple-string)))
- (setf (file-info-comment file) comment)
- (when sb!xc:*compile-verbose*
- (compiler-mumble "~&FILE-COMMENT: ~A~2&" comment)))))))
-
-;;; Force any pending top-level forms to be compiled and dumped so that they
-;;; will be evaluated in the correct package environment. Dump the form to be
-;;; evaled at (cold) load time, and if EVAL is true, eval the form immediately.
+;;; Force any pending top-level forms to be compiled and dumped so
+;;; that they will be evaluated in the correct package environment.
+;;; Dump the form to be evaled at (cold) load time, and if EVAL is
+;;; true, eval the form immediately.
(defun process-cold-load-form (form path eval)
(let ((object *compile-object*))
(etypecase object
(process-top-level-progn (cddr form) path))))
(locally (process-top-level-locally form path))
(progn (process-top-level-progn (cdr form) path))
- (file-comment (process-file-comment form))
(t
(let* ((uform (uncross form))
(exp (preprocessor-macroexpand uform)))
;;; 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)
(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
#+nil (*compiler-style-warning-count* 0)
#+nil (*compiler-note-count* 0)
(*block-compile* *block-compile-argument*)
- (*package* *package*)
- (*initial-package* *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*))
+ (*package* (sane-package))
+ (*policy* *policy*)
(*lexenv* (make-null-lexenv))
(*converting-for-interpreter* nil)
(*source-info* info)
(*top-level-lambdas* ())
(*pending-top-level-lambdas* ())
(*compiler-error-bailout*
- #'(lambda ()
- (compiler-mumble
- "~2&fatal error, aborting compilation~%")
- (return-from sub-compile-file (values nil t t))))
+ (lambda ()
+ (compiler-mumble "~2&; fatal error, aborting compilation~%")
+ (return-from sub-compile-file (values nil t t))))
(*current-path* nil)
(*last-source-context* nil)
(*last-original-source* nil)
(defun start-error-output (source-info)
(declare (type source-info source-info))
(dolist (x (source-info-files source-info))
- (compiler-mumble "compiling file ~S (written ~A):~%"
+ (compiler-mumble "~&; compiling file ~S (written ~A):~%"
(namestring (file-info-name x))
(sb!int:format-universal-time nil
(file-info-write-date x)
:style :government
:print-weekday nil
:print-timezone nil)))
- (compiler-mumble "~%")
(values))
+
(defun finish-error-output (source-info won)
(declare (type source-info source-info))
- (compiler-mumble "~&compilation ~:[aborted after~;finished in~] ~A~&"
+ (compiler-mumble "~&; compilation ~:[aborted after~;finished in~] ~A~&"
won
(elapsed-time-to-string
(- (get-universal-time)
;;; 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..
((: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
(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
;; 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*
(close-fasl-file fasl-file (not compile-won))
(setq output-file-name (pathname (fasl-file-stream fasl-file)))
(when (and compile-won sb!xc:*compile-verbose*)
- (compiler-mumble "~2&~A written~%" (namestring output-file-name))))
+ (compiler-mumble "~2&; ~A written~%" (namestring output-file-name))))
(when sb!xc:*compile-verbose*
(finish-error-output source-info compile-won)))
warnings-p
failure-p)))
\f
-(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))
projects / sbcl.git / blobdiff