-;;;; the top-level interfaces to the compiler, plus some other
+;;;; 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
(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*
*last-source-form* *last-format-string* *last-format-args*
*last-message-count* *lexenv*))
-(defvar *byte-compile-default* :maybe
- #!+sb-doc
- "the default value for the :BYTE-COMPILE argument to COMPILE-FILE")
-
-(defvar *byte-compile-top-level*
- #-sb-xc-host t
- #+sb-xc-host nil ; since the byte compiler isn't supported in cross-compiler
- #!+sb-doc
- "Similar to *BYTE-COMPILE-DEFAULT*, but controls the compilation of top-level
- forms (evaluated at load-time) when the :BYTE-COMPILE argument is :MAYBE
- (the default.) When true, we decide to byte-compile.")
-
-;;; 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
-;;; native compiling. During IR1 conversion this can also be :MAYBE,
-;;; in which case we must look at the policy, see (byte-compiling).
-(defvar *byte-compiling* :maybe)
-(declaim (type (member t nil :maybe) *byte-compile* *byte-compiling*
- *byte-compile-default*))
-
(defvar *check-consistency* nil)
(defvar *all-components*)
(defvar *entry-points*)
(declaim (list *entry-points*))
-;;; When block compiling, used by PROCESS-FORM to accumulate top-level
+;;; When block compiling, used by PROCESS-FORM to accumulate top level
;;; lambdas resulting from compiling subforms. (In reverse order.)
-(defvar *top-level-lambdas*)
-(declaim (list *top-level-lambdas*))
+(defvar *toplevel-lambdas*)
+(declaim (list *toplevel-lambdas*))
(defvar sb!xc:*compile-verbose* t
#!+sb-doc
(if (symbolp x)
(symbol-name x)
(prin1-to-string x)))))))
- (unless *converting-for-interpreter*
- (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))
-
- (let ((warn-count (length warnings)))
- (when (and warnings (> undefined-warning-count warn-count))
- (let ((more (- undefined-warning-count warn-count)))
- (compiler-style-warning
- "~D more use~:P of undefined ~(~A~) ~S"
- more kind name)))))))
+ (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))
+ (let ((warn-count (length warnings)))
+ (when (and warnings (> undefined-warning-count warn-count))
+ (let ((more (- undefined-warning-count warn-count)))
+ (compiler-style-warning
+ "~D more use~:P of undefined ~(~A~) ~S"
+ more kind name))))))
(dolist (kind '(:variable :function :type))
(let ((summary (mapcar #'undefined-warning-name
~% ~{~<~% ~1:;~S~>~^ ~}"
(cdr summary) kind summary)))))))
- (unless (or *converting-for-interpreter*
- (and (not abort-p)
- (zerop *aborted-compilation-unit-count*)
- (zerop *compiler-error-count*)
- (zerop *compiler-warning-count*)
- (zerop *compiler-style-warning-count*)
- (zerop *compiler-note-count*)))
+ (unless (and (not abort-p)
+ (zerop *aborted-compilation-unit-count*)
+ (zerop *compiler-error-count*)
+ (zerop *compiler-warning-count*)
+ (zerop *compiler-style-warning-count*)
+ (zerop *compiler-note-count*))
(format *error-output* "~&")
(pprint-logical-block (*error-output* nil :per-line-prefix "; ")
(compiler-mumble "compilation unit ~:[finished~;aborted~]~
(declare (special *constraint-number* *delayed-ir1-transforms*))
(loop
(ir1-optimize-until-done component)
- (when (or (component-new-functions component)
- (component-reanalyze-functions component))
+ (when (or (component-new-funs component)
+ (component-reanalyze-funs component))
(maybe-mumble "locall ")
- (local-call-analyze component))
+ (locall-analyze-component component))
(dfo-as-needed component)
(when *constraint-propagate*
(maybe-mumble "constraint ")
;; confuse itself.
(unless (and (or (component-reoptimize component)
(component-reanalyze component)
- (component-new-functions component)
- (component-reanalyze-functions 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-functions component)
- (component-reanalyze-functions component))
+ (component-new-funs component)
+ (component-reanalyze-funs component))
(return)))
(when (>= loop-count *reoptimize-after-type-check-max*)
(maybe-mumble "[reoptimize limit]")
(ir1-finalize component)
(values))
-(defun native-compile-component (component)
+(defun %compile-component (component)
(let ((*code-segment* nil)
(*elsewhere* nil))
(maybe-mumble "GTN ")
(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.
-;;;
-;;; FIXME: This should be called something more mnemonic, e.g.
-;;; PROBABLY-BYTE-COMPILING
-(defun byte-compiling ()
- (if (eq *byte-compiling* :maybe)
- (or (eq *byte-compile* t)
- (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.
-;;;
-;;; 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))
+ (dolist (fun (component-lambdas component) (delete-component component))
+ (when (functional-has-external-references-p fun)
+ (return))
(case (functional-kind fun)
- (:top-level (return))
+ (:toplevel (return))
(:external
(unless (every (lambda (ref)
(eq (block-component (node-block ref))
(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* (byte-compile-this-component-p component)))
+ (let* ((*component-being-compiled* component))
(when sb!xc:*compile-print*
- (compiler-mumble "~&; ~:[~;byte ~]compiling ~A: "
- *byte-compiling*
- (component-name component)))
+ (compiler-mumble "~&; compiling ~A: " (component-name component)))
(ir1-phases component)
;; FIXME: What is MAYBE-MUMBLE for? Do we need it any more?
(maybe-mumble "env ")
- (environment-analyze component)
+ (physenv-analyze component)
(dfo-as-needed component)
(delete-if-no-entries component)
(unless (eq (block-next (component-head component))
(component-tail component))
- (if *byte-compiling*
- (byte-compile-component component)
- (native-compile-component component))))
+ (%compile-component component)))
(clear-constant-info)
(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)))
+ (name (missing-arg) :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
(make-source-info :file-info file-info)))
-;;; Return a SOURCE-INFO to describe the incremental compilation of
-;;; FORM. Also used by SB!EVAL:INTERNAL-EVAL.
+;;; Return a SOURCE-INFO to describe the incremental compilation of FORM.
(defun make-lisp-source-info (form)
(make-source-info :start-time (get-universal-time)
:file-info (make-file-info :name :lisp
(make-source-info :file-info file-info
:stream stream)))
-;;; Return a form read from STREAM; or for EOF, use the trick
-;;; popularized by Kent Pitman of returning STREAM itself. If an error
-;;; happens, then convert it to standard abort-the-compilation error
-;;; condition (possibly recording some extra location information).
+;;; Return a form read from STREAM; or for EOF use the trick,
+;;; popularized by Kent Pitman, of returning STREAM itself. If an
+;;; error happens, then convert it to standard abort-the-compilation
+;;; error condition (possibly recording some extra location
+;;; information).
(defun read-for-compile-file (stream position)
(handler-case (read stream nil stream)
(reader-error (condition)
(setf (source-info-stream info) nil)
(values))
-;;; Read the source file.
-(defun process-source (info)
+;;; Read and compile the source file.
+(defun sub-sub-compile-file (info)
(let* ((file-info (source-info-file-info info))
(stream (get-source-stream info)))
(loop
(file-info-source-root file-info))))
(vector-push-extend form forms)
(vector-push-extend pos (file-info-positions file-info))
- (clrhash *source-paths*)
(find-source-paths form current-idx)
- (process-top-level-form form
- `(original-source-start 0
- ,current-idx))))))))
+ (process-toplevel-form form
+ `(original-source-start 0 ,current-idx)
+ nil)))))))
;;; Return the INDEX'th source form read from INFO and the position
;;; where it was read.
(values (aref (file-info-forms file-info) index)
(aref (file-info-positions file-info) index))))
\f
-;;;; top-level form processing
+;;;; processing of top level forms
-;;; This is called by top-level form processing when we are ready to
+;;; This is called by top level form processing when we are ready to
;;; actually compile something. If *BLOCK-COMPILE* is T, then we still
;;; convert the form, but delay compilation, pushing the result on
-;;; *TOP-LEVEL-LAMBDAS* instead.
+;;; *TOPLEVEL-LAMBDAS* instead.
(defun convert-and-maybe-compile (form path)
(declare (list path))
(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 PROGN-like portion of a top-level form. Forms is a list of
-;;; the forms, and Path is source path of the form they came out of.
-(defun process-top-level-progn (forms path)
- (declare (list forms) (list path))
- (dolist (form forms)
- (process-top-level-form form path)))
+ (tll (ir1-toplevel form path nil)))
+ (cond ((eq *block-compile* t) (push tll *toplevel-lambdas*))
+ (t (compile-toplevel (list tll) nil)))))
-;;; Macroexpand form in the current environment with an error handler.
+;;; Macroexpand FORM in the current environment with an error handler.
;;; We only expand one level, so that we retain all the intervening
;;; forms in the source path.
-(defun preprocessor-macroexpand (form)
+(defun preprocessor-macroexpand-1 (form)
(handler-case (sb!xc:macroexpand-1 form *lexenv*)
(error (condition)
- (compiler-error "(during macroexpansion)~%~A" condition))))
+ (compiler-error "(during macroexpansion of ~A)~%~A"
+ (let ((*print-level* 1)
+ (*print-length* 2))
+ (format nil "~S" form))
+ condition))))
+
+;;; Process a PROGN-like portion of a top level form. FORMS is a list of
+;;; the forms, and PATH is the source path of the FORM they came out of.
+;;; COMPILE-TIME-TOO is as in ANSI "3.2.3.1 Processing of Top Level Forms".
+(defun process-toplevel-progn (forms path compile-time-too)
+ (declare (list forms) (list path))
+ (dolist (form forms)
+ (process-toplevel-form form path compile-time-too)))
-;;; Process a top-level use of LOCALLY. We parse declarations and then
-;;; recursively process the body.
-(defun process-top-level-locally (form path)
+;;; Process a top level use of LOCALLY, or anything else (e.g.
+;;; MACROLET) at top level which has declarations and ordinary forms.
+;;; We parse declarations and then recursively process the body.
+(defun process-toplevel-locally (body path compile-time-too)
(declare (list path))
- (multiple-value-bind (forms decls) (sb!sys:parse-body (cdr form) nil)
+ (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
(let* ((*lexenv*
(process-decls decls nil nil (make-continuation)))
;; Binding *POLICY* is pretty much of a hack, since it
;; 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))))
+ (process-toplevel-progn forms path compile-time-too))))
+
+;;; Parse an EVAL-WHEN situations list, returning three flags,
+;;; (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
+;;; the types of situations present in the list.
+(defun parse-eval-when-situations (situations)
+ (when (or (not (listp situations))
+ (set-difference situations
+ '(:compile-toplevel
+ compile
+ :load-toplevel
+ load
+ :execute
+ eval)))
+ (compiler-error "bad EVAL-WHEN situation list: ~S" situations))
+ (let ((deprecated-names (intersection situations '(compile load eval))))
+ (when deprecated-names
+ (style-warn "using deprecated EVAL-WHEN situation names~{ ~S~}"
+ deprecated-names)))
+ (values (intersection '(:compile-toplevel compile)
+ situations)
+ (intersection '(:load-toplevel load) situations)
+ (intersection '(:execute eval) situations)))
+
+
+;;; utilities for extracting COMPONENTs of FUNCTIONALs
+(defun functional-components (f)
+ (declare (type functional f))
+ (etypecase f
+ (clambda (list (lambda-component f)))
+ (optional-dispatch (let ((result nil))
+ (labels ((frob (clambda)
+ (pushnew (lambda-component clambda)
+ result))
+ (maybe-frob (maybe-clambda)
+ (when maybe-clambda
+ (frob maybe-clambda))))
+ (mapc #'frob (optional-dispatch-entry-points f))
+ (maybe-frob (optional-dispatch-more-entry f))
+ (maybe-frob (optional-dispatch-main-entry f)))))))
+
+(defun make-functional-from-toplevel-lambda (definition
+ &key
+ name
+ (path
+ ;; I'd thought NIL should
+ ;; work, but it doesn't.
+ ;; -- WHN 2001-09-20
+ (missing-arg)))
+ (let* ((*current-path* path)
+ (component (make-empty-component))
+ (*current-component* component))
+ (setf (component-name component)
+ (debug-namify "~S initial component" name))
+ (setf (component-kind component) :initial)
+ (let* ((locall-fun (ir1-convert-lambda definition
+ :debug-name (debug-namify
+ "top level locall ~S"
+ name)))
+ (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
+ :source-name (or name '.anonymous.)
+ :debug-name (unless name
+ "top level form"))))
+ (/show "in MAKE-FUNCTIONAL-FROM-TOP-LEVEL-LAMBDA" locall-fun fun component)
+ (/show (component-lambdas component))
+ (/show (lambda-calls fun))
+ (setf (functional-entry-fun fun) locall-fun
+ (functional-kind fun) :external
+ (functional-has-external-references-p fun) t)
+ fun)))
+
+;;; Compile LAMBDA-EXPRESSION into *COMPILE-OBJECT*, returning a
+;;; description of the result.
+;;; * If *COMPILE-OBJECT* is a CORE-OBJECT, then write the function
+;;; into core and return the compiled FUNCTION value.
+;;; * If *COMPILE-OBJECT* is a fasl file, then write the function
+;;; into the fasl file and return a dump handle.
+;;;
+;;; If NAME is provided, then we try to use it as the name of the
+;;; function for debugging/diagnostic information.
+(defun %compile (lambda-expression
+ *compile-object*
+ &key
+ name
+ (path
+ ;; This magical idiom seems to be the appropriate
+ ;; path for compiling standalone LAMBDAs, judging
+ ;; from the CMU CL code and experiment, so it's a
+ ;; nice default for things where we don't have a
+ ;; real source path (as in e.g. inside CL:COMPILE).
+ '(original-source-start 0 0)))
+ (/show "entering %COMPILE" lambda-expression name)
+ (unless (or (null name) (legal-fun-name-p name))
+ (error "not a legal function name: ~S" name))
+ (let* ((*lexenv* (make-lexenv :policy *policy*))
+ (fun (make-functional-from-toplevel-lambda lambda-expression
+ :name name
+ :path path)))
+ (/show "back in %COMPILE from M-F-FROM-TL-LAMBDA" fun)
+ (/show (lambda-component fun) (component-lambdas (lambda-component fun)))
+
+ ;; FIXME: The compile-it code from here on is sort of a
+ ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be
+ ;; better to find a way to share the code there; or
+ ;; alternatively, to use this code to replace the code there.
+ ;; (The second alternative might be pretty easy if we used
+ ;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the
+ ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..)
+
+ #+nil (break "before LOCALL-ANALYZE-CLAMBDAS-UNTIL-DONE" fun)
+ (locall-analyze-clambdas-until-done (list fun))
+ (/show (lambda-calls fun))
+ #+nil (break "back from LOCALL-ANALYZE-CLAMBDAS-UNTIL-DONE" fun)
+
+ (multiple-value-bind (components-from-dfo top-components hairy-top)
+ (find-initial-dfo (list fun))
+ (/show components-from-dfo top-components hairy-top)
+ (/show (mapcar #'component-lambdas components-from-dfo))
+ (/show (mapcar #'component-lambdas top-components))
+ (/show (mapcar #'component-lambdas 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)
+ (/show component-from-dfo (component-lambdas component-from-dfo))
+ (compile-component component-from-dfo)
+ (replace-toplevel-xeps component-from-dfo)))
+
+ (prog1
+ (let ((entry-table (etypecase *compile-object*
+ (fasl-output (fasl-output-entry-table
+ *compile-object*))
+ (core-object (core-object-entry-table
+ *compile-object*)))))
+ (multiple-value-bind (result found-p)
+ (gethash (leaf-info fun) entry-table)
+ (aver found-p)
+ result))
+ (mapc #'clear-ir1-info components-from-dfo)
+ (clear-stuff)
+ (/show "returning from %COMPILE")))))
+
+(defun process-toplevel-cold-fset (name lambda-expression path)
+ (unless (producing-fasl-file)
+ (error "can't COLD-FSET except in a fasl file"))
+ (unless (legal-fun-name-p name)
+ (error "not a legal function name: ~S" name))
+ (fasl-dump-cold-fset name
+ (%compile lambda-expression
+ *compile-object*
+ :name name
+ :path path)
+ *compile-object*)
+ (values))
-;;; 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
- (fasl-output
- (compile-top-level-lambdas () t)
- (fasl-dump-cold-load-form form object))
- ((or null core-object)
- (convert-and-maybe-compile form path)))
- (when eval
- (eval form))))
-
-;;; Process a top-level FORM with the specified source PATH.
-;;; * If this is a magic top-level form, then do stuff.
+;;; Process a top level FORM with the specified source PATH.
+;;; * If this is a magic top level form, then do stuff.
;;; * If this is a macro, then expand it.
;;; * Otherwise, just compile it.
-(defun process-top-level-form (form path)
+;;;
+;;; COMPILE-TIME-TOO is as defined in ANSI
+;;; "3.2.3.1 Processing of Top Level Forms".
+(defun process-toplevel-form (form path compile-time-too)
(declare (list path))
- (catch 'process-top-level-form-error-abort
+ (catch 'process-toplevel-form-error-abort
(let* ((path (or (gethash form *source-paths*) (cons form path)))
(*compiler-error-bailout*
- #'(lambda ()
- (convert-and-maybe-compile
- `(error "execution of a form compiled with errors:~% ~S"
- ',form)
- path)
- (throw 'process-top-level-form-error-abort nil))))
+ (lambda ()
+ (convert-and-maybe-compile
+ `(error "execution of a form compiled with errors:~% ~S"
+ ',form)
+ path)
+ (throw 'process-toplevel-form-error-abort nil))))
+
(if (atom form)
+ ;; (There are no EVAL-WHEN issues in the ATOM case until
+ ;; SBCL gets smart enough to handle global
+ ;; DEFINE-SYMBOL-MACRO.)
(convert-and-maybe-compile form path)
- (case (car form)
- ;; FIXME: It's not clear to me why we would want this
- ;; special case; it might have been needed for some
- ;; variation of the old GENESIS system, but it certainly
- ;; doesn't seem to be needed for ours. Sometime after the
- ;; system is running I'd like to remove it tentatively and
- ;; see whether anything breaks, and if nothing does break,
- ;; remove it permanently. (And if we *do* want special
- ;; treatment of all these, we probably want to treat WARN
- ;; the same way..)
- ((error cerror break signal)
- (process-cold-load-form form path nil))
- ;; FIXME: ANSI seems to encourage things like DEFSTRUCT to
- ;; be done with EVAL-WHEN, without this kind of one-off
- ;; compiler magic.
- (sb!kernel:%compiler-defstruct
- (convert-and-maybe-compile form path)
- (compile-top-level-lambdas () t))
- ((eval-when)
- (unless (>= (length form) 2)
- (compiler-error "EVAL-WHEN form is too short: ~S" form))
- (do-eval-when-stuff
- (cadr form) (cddr form)
- #'(lambda (forms)
- (process-top-level-progn forms path))))
- ((macrolet)
- (unless (>= (length form) 2)
- (compiler-error "MACROLET form is too short: ~S" form))
- (do-macrolet-stuff
- (cadr form)
- #'(lambda ()
- (process-top-level-progn (cddr form) path))))
- (locally (process-top-level-locally form path))
- (progn (process-top-level-progn (cdr form) path))
- (t
- (let* ((uform (uncross form))
- (exp (preprocessor-macroexpand uform)))
- (if (eq exp uform)
- (convert-and-maybe-compile uform path)
- (process-top-level-form exp path))))))))
+ (flet ((need-at-least-one-arg (form)
+ (unless (cdr form)
+ (compiler-error "~S form is too short: ~S"
+ (car form)
+ form))))
+ (case (car form)
+ ;; In the cross-compiler, top level COLD-FSET arranges
+ ;; for static linking at cold init time.
+ #+sb-xc-host
+ ((cold-fset)
+ (aver (not compile-time-too))
+ (destructuring-bind (cold-fset fun-name lambda-expression) form
+ (declare (ignore cold-fset))
+ (process-toplevel-cold-fset fun-name
+ lambda-expression
+ path)))
+ ((eval-when macrolet symbol-macrolet);things w/ 1 arg before body
+ (need-at-least-one-arg form)
+ (destructuring-bind (special-operator magic &rest body) form
+ (ecase special-operator
+ ((eval-when)
+ ;; CT, LT, and E here are as in Figure 3-7 of ANSI
+ ;; "3.2.3.1 Processing of Top Level Forms".
+ (multiple-value-bind (ct lt e)
+ (parse-eval-when-situations magic)
+ (let ((new-compile-time-too (or ct
+ (and compile-time-too
+ e))))
+ (cond (lt (process-toplevel-progn
+ body path new-compile-time-too))
+ (new-compile-time-too (eval
+ `(progn ,@body)))))))
+ ((macrolet)
+ (funcall-in-macrolet-lexenv
+ magic
+ (lambda ()
+ (process-toplevel-locally body
+ path
+ compile-time-too))))
+ ((symbol-macrolet)
+ (funcall-in-symbol-macrolet-lexenv
+ magic
+ (lambda ()
+ (process-toplevel-locally body
+ path
+ compile-time-too)))))))
+ ((locally)
+ (process-toplevel-locally (rest form) path compile-time-too))
+ ((progn)
+ (process-toplevel-progn (rest form) path compile-time-too))
+ ;; When we're cross-compiling, consider: what should we
+ ;; do when we hit e.g.
+ ;; (EVAL-WHEN (:COMPILE-TOPLEVEL)
+ ;; (DEFUN FOO (X) (+ 7 X)))?
+ ;; DEFUN has a macro definition in the cross-compiler,
+ ;; and a different macro definition in the target
+ ;; compiler. The only sensible thing is to use the
+ ;; target compiler's macro definition, since the
+ ;; cross-compiler's macro is in general into target
+ ;; functions which can't meaningfully be executed at
+ ;; cross-compilation time. So make sure we do the EVAL
+ ;; here, before we macroexpand.
+ ;;
+ ;; Then things get even dicier with something like
+ ;; (DEFCONSTANT-EQX SB!XC:LAMBDA-LIST-KEYWORDS ..)
+ ;; where we have to make sure that we don't uncross
+ ;; the SB!XC: prefix before we do EVAL, because otherwise
+ ;; we'd be trying to redefine the cross-compilation host's
+ ;; constants.
+ ;;
+ ;; (Isn't it fun to cross-compile Common Lisp?:-)
+ #+sb-xc-host
+ (t
+ (when compile-time-too
+ (eval form)) ; letting xc host EVAL do its own macroexpansion
+ (let* (;; (We uncross the operator name because things
+ ;; like SB!XC:DEFCONSTANT and SB!XC:DEFTYPE
+ ;; should be equivalent to their CL: counterparts
+ ;; when being compiled as target code. We leave
+ ;; the rest of the form uncrossed because macros
+ ;; might yet expand into EVAL-WHEN stuff, and
+ ;; things inside EVAL-WHEN can't be uncrossed
+ ;; until after we've EVALed them in the
+ ;; cross-compilation host.)
+ (slightly-uncrossed (cons (uncross (first form))
+ (rest form)))
+ (expanded (preprocessor-macroexpand-1
+ slightly-uncrossed)))
+ (if (eq expanded slightly-uncrossed)
+ ;; (Now that we're no longer processing toplevel
+ ;; forms, and hence no longer need to worry about
+ ;; EVAL-WHEN, we can uncross everything.)
+ (convert-and-maybe-compile expanded path)
+ ;; (We have to demote COMPILE-TIME-TOO to NIL
+ ;; here, no matter what it was before, since
+ ;; otherwise we'd tend to EVAL subforms more than
+ ;; once, because of WHEN COMPILE-TIME-TOO form
+ ;; above.)
+ (process-toplevel-form expanded path nil))))
+ ;; When we're not cross-compiling, we only need to
+ ;; macroexpand once, so we can follow the 1-thru-6
+ ;; sequence of steps in ANSI's "3.2.3.1 Processing of
+ ;; Top Level Forms".
+ #-sb-xc-host
+ (t
+ (let ((expanded (preprocessor-macroexpand-1 form)))
+ (cond ((eq expanded form)
+ (when compile-time-too
+ (eval form))
+ (convert-and-maybe-compile form path))
+ (t
+ (process-toplevel-form expanded
+ path
+ compile-time-too))))))))))
(values))
\f
;;;;
;;;; (See EMIT-MAKE-LOAD-FORM.)
-;;; Returns T iff we are currently producing a fasl file and hence
+;;; Return T if we are currently producing a fasl file and hence
;;; constants need to be dumped carefully.
(defun producing-fasl-file ()
- (unless *converting-for-interpreter*
- (fasl-output-p *compile-object*)))
+ (fasl-output-p *compile-object*))
;;; 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.
(values
(fasl-dump-load-time-value-lambda lambda *compile-object*)
(let ((type (leaf-type lambda)))
- (if (function-type-p type)
- (single-value-type (function-type-returns type))
+ (if (fun-type-p type)
+ (single-value-type (fun-type-returns type))
*wild-type*)))))
;;; 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)))
- (fasl-dump-top-level-lambda-call lambda *compile-object*)))
+ (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)
(with-ir1-namespace
(let* ((*lexenv* (make-null-lexenv))
- (lambda (ir1-top-level form *current-path* for-value)))
- (setf (leaf-name lambda) name)
- (compile-top-level (list lambda) t)
+ (lambda (ir1-toplevel form *current-path* for-value)))
+ (compile-toplevel (list lambda) t)
lambda)))
-;;; Called by COMPILE-TOP-LEVEL when it was pased T for
+;;; This is called by COMPILE-TOPLEVEL when it was passed T for
;;; LOAD-TIME-VALUE-P (which happens in COMPILE-LOAD-TIME-STUFF). We
;;; don't try to combine this component with anything else and frob
-;;; the name. If not in a :TOP-LEVEL component, then don't bother
+;;; the name. If not in a :TOPLEVEL component, then don't bother
;;; compiling, because it was merged with a run-time component.
(defun compile-load-time-value-lambda (lambdas)
(aver (null (cdr lambdas)))
(let* ((lambda (car lambdas))
- (component (block-component (node-block (lambda-bind lambda)))))
- (when (eq (component-kind component) :top-level)
- (setf (component-name component) (leaf-name lambda))
+ (component (lambda-component lambda)))
+ (when (eql (component-kind component) :toplevel)
+ (setf (component-name component) (leaf-debug-name lambda))
(compile-component component)
(clear-ir1-info component))))
\f
;;;; COMPILE-FILE
-;;; We build a list of top-level lambdas, and then periodically smash
+;;; We build a list of top level lambdas, and then periodically smash
;;; them together into a single component and compile it.
-(defvar *pending-top-level-lambdas*)
+(defvar *pending-toplevel-lambdas*)
-;;; The maximum number of top-level lambdas we put in a single
-;;; top-level component.
+;;; The maximum number of top level lambdas we put in a single
+;;; top level component.
;;;
;;; CMU CL 18b used this nontrivially by default (setting it to 10)
;;; but consequently suffered from the inability to execute some
;;; GENESIS, which is desirable, since at least for SBCL version
;;; 0.6.7, this is the high water mark for memory usage during system
;;; construction.
-(defparameter *top-level-lambda-max* 0)
+(defparameter *toplevel-lambda-max* 0)
-(defun object-call-top-level-lambda (tll)
+(defun object-call-toplevel-lambda (tll)
(declare (type functional tll))
(let ((object *compile-object*))
(etypecase object
(fasl-output
- (fasl-dump-top-level-lambda-call tll object))
+ (fasl-dump-toplevel-lambda-call tll object))
(core-object
- (core-call-top-level-lambda tll object))
+ (core-call-toplevel-lambda tll object))
(null))))
;;; Add LAMBDAS to the pending lambdas. If this leaves more than
-;;; *TOP-LEVEL-LAMBDA-MAX* lambdas in the list, or if FORCE-P is true,
+;;; *TOPLEVEL-LAMBDA-MAX* lambdas in the list, or if FORCE-P is true,
;;; then smash the lambdas into a single component, compile it, and
;;; call the resulting function.
-(defun sub-compile-top-level-lambdas (lambdas force-p)
+(defun sub-compile-toplevel-lambdas (lambdas force-p)
(declare (list lambdas))
- (setq *pending-top-level-lambdas*
- (append *pending-top-level-lambdas* lambdas))
- (let ((pending *pending-top-level-lambdas*))
+ (setq *pending-toplevel-lambdas*
+ (append *pending-toplevel-lambdas* lambdas))
+ (let ((pending *pending-toplevel-lambdas*))
(when (and pending
- (or (> (length pending) *top-level-lambda-max*)
+ (or (> (length pending) *toplevel-lambda-max*)
force-p))
- (multiple-value-bind (component tll) (merge-top-level-lambdas pending)
- (setq *pending-top-level-lambdas* ())
- (let ((*byte-compile* (if (eq *byte-compile* :maybe)
- *byte-compile-top-level*
- *byte-compile*)))
- (compile-component component))
+ (multiple-value-bind (component tll) (merge-toplevel-lambdas pending)
+ (setq *pending-toplevel-lambdas* ())
+ (compile-component component)
(clear-ir1-info component)
- (object-call-top-level-lambda tll))))
+ (object-call-toplevel-lambda tll))))
(values))
-;;; Compile top-level code and call the top-level lambdas. We pick off
-;;; top-level lambdas in non-top-level components here, calling
-;;; SUB-c-t-l-l on each subsequence of normal top-level lambdas.
-(defun compile-top-level-lambdas (lambdas force-p)
+;;; Compile top level code and call the top level lambdas. We pick off
+;;; top level lambdas in non-top-level components here, calling
+;;; SUB-c-t-l-l on each subsequence of normal top level lambdas.
+(defun compile-toplevel-lambdas (lambdas force-p)
(declare (list lambdas))
(let ((len (length lambdas)))
(flet ((loser (start)
- (or (position-if #'(lambda (x)
- (not (eq (component-kind
- (block-component
- (node-block
- (lambda-bind x))))
- :top-level)))
+ (or (position-if (lambda (x)
+ (not (eq (component-kind
+ (block-component
+ (node-block
+ (lambda-bind x))))
+ :toplevel)))
lambdas
:start start)
len)))
(loser (loser start) (loser start)))
((>= start len)
(when force-p
- (sub-compile-top-level-lambdas nil t)))
- (sub-compile-top-level-lambdas (subseq lambdas start loser)
- (or force-p (/= loser len)))
+ (sub-compile-toplevel-lambdas nil t)))
+ (sub-compile-toplevel-lambdas (subseq lambdas start loser)
+ (or force-p (/= loser len)))
(unless (= loser len)
- (object-call-top-level-lambda (elt lambdas loser))))))
+ (object-call-toplevel-lambda (elt lambdas loser))))))
(values))
-;;; Compile LAMBDAS (a list of the lambdas for top-level forms) into
-;;; the object file. We loop doing local call analysis until it
-;;; converges, since a single pass might miss something due to
-;;; components being joined by LET conversion.
+;;; Compile LAMBDAS (a list of CLAMBDAs for top level forms) into the
+;;; object file.
;;;
;;; LOAD-TIME-VALUE-P seems to control whether it's MAKE-LOAD-FORM and
;;; COMPILE-LOAD-TIME-VALUE stuff. -- WHN 20000201
-(defun compile-top-level (lambdas load-time-value-p)
+(defun compile-toplevel (lambdas load-time-value-p)
(declare (list lambdas))
+
(maybe-mumble "locall ")
- (loop
- (let ((did-something nil))
- (dolist (lambda lambdas)
- (let* ((component (block-component (node-block (lambda-bind lambda))))
- (*all-components* (list component)))
- (when (component-new-functions component)
- (setq did-something t)
- (local-call-analyze component))))
- (unless did-something (return))))
+ (locall-analyze-clambdas-until-done lambdas)
(maybe-mumble "IDFO ")
(multiple-value-bind (components top-components hairy-top)
(find-initial-dfo lambdas)
(let ((*all-components* (append components top-components))
- (top-level-closure nil))
+ (toplevel-closure nil))
(when *check-consistency*
(maybe-mumble "[check]~%")
(check-ir1-consistency *all-components*))
(dolist (component (append hairy-top top-components))
- (when (pre-environment-analyze-top-level component)
- (setq top-level-closure t)))
-
- (let ((*byte-compile*
- (if (and top-level-closure (eq *byte-compile* :maybe))
- nil
- *byte-compile*)))
- (dolist (component components)
- (compile-component component)
- (when (replace-top-level-xeps component)
- (setq top-level-closure t)))
+ (when (pre-physenv-analyze-toplevel component)
+ (setq toplevel-closure t)))
+
+ (dolist (component components)
+ (compile-component component)
+ (when (replace-toplevel-xeps component)
+ (setq toplevel-closure t)))
- (when *check-consistency*
- (maybe-mumble "[check]~%")
- (check-ir1-consistency *all-components*))
+ (when *check-consistency*
+ (maybe-mumble "[check]~%")
+ (check-ir1-consistency *all-components*))
- (if load-time-value-p
- (compile-load-time-value-lambda lambdas)
- (compile-top-level-lambdas lambdas top-level-closure)))
+ (if load-time-value-p
+ (compile-load-time-value-lambda lambdas)
+ (compile-toplevel-lambdas lambdas toplevel-closure))
- (dolist (component components)
- (clear-ir1-info component))
+ (mapc #'clear-ir1-info components)
(clear-stuff)))
(values))
;;; compilation.
(defun finish-block-compilation ()
(when *block-compile*
- (when *top-level-lambdas*
- (compile-top-level (nreverse *top-level-lambdas*) nil)
- (setq *top-level-lambdas* ()))
+ (when *toplevel-lambdas*
+ (compile-toplevel (nreverse *toplevel-lambdas*) nil)
+ (setq *toplevel-lambdas* ()))
(setq *block-compile* nil)
(setq *entry-points* nil)))
;;; Return (VALUES NIL WARNINGS-P FAILURE-P).
(defun sub-compile-file (info)
(declare (type source-info info))
- (let* (;; These are bound in WITH-COMPILATION-UNIT now. -- WHN 20000308
- #+nil (*compiler-error-count* 0)
- #+nil (*compiler-warning-count* 0)
- #+nil (*compiler-style-warning-count* 0)
- #+nil (*compiler-note-count* 0)
- (*block-compile* *block-compile-argument*)
+ (let* ((*block-compile* *block-compile-argument*)
(*package* (sane-package))
(*policy* *policy*)
(*lexenv* (make-null-lexenv))
- (*converting-for-interpreter* nil)
(*source-info* info)
(sb!xc:*compile-file-pathname* nil)
(sb!xc:*compile-file-truename* nil)
- (*top-level-lambdas* ())
- (*pending-top-level-lambdas* ())
+ (*toplevel-lambdas* ())
+ (*pending-toplevel-lambdas* ())
(*compiler-error-bailout*
(lambda ()
(compiler-mumble "~2&; fatal error, aborting compilation~%")
(*last-format-string* nil)
(*last-format-args* nil)
(*last-message-count* 0)
- (*info-environment* (or *backend-info-environment*
- *info-environment*))
+ ;; FIXME: Do we need this rebinding here? It's a literal
+ ;; translation of the old CMU CL rebinding to
+ ;; (OR *BACKEND-INFO-ENVIRONMENT* *INFO-ENVIRONMENT*),
+ ;; and it's not obvious whether the rebinding to itself is
+ ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*.
+ (*info-environment* *info-environment*)
(*gensym-counter* 0))
(handler-case
(with-compilation-values
(sb!xc:with-compilation-unit ()
(clear-stuff)
- (process-source info)
+ (sub-sub-compile-file info)
(finish-block-compilation)
- (compile-top-level-lambdas () t)
+ (compile-toplevel-lambdas () t)
(let ((object *compile-object*))
(etypecase object
(fasl-output (fasl-dump-source-info info object))
;; extensions
(trace-file nil)
- ((:block-compile *block-compile-argument*) nil)
- ((:byte-compile *byte-compile*) *byte-compile-default*))
+ ((:block-compile *block-compile-argument*) nil))
#!+sb-doc
"Compile INPUT-FILE, producing a corresponding fasl file and returning
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
derived from the input file name.
- :BYTE-COMPILE {T | NIL | :MAYBE}
- Determines whether to compile into interpreted byte code instead of
- machine instructions. Byte code is several times smaller, but much
- slower. If :MAYBE, then only byte-compile when SPEED is 0 and
- DEBUG <= 1. The default is the value of SB-EXT:*BYTE-COMPILE-DEFAULT*,
- which is initially :MAYBE. (This option will probably become
- formally deprecated starting around sbcl-0.7.0, when various
- cleanups related to the byte interpreter are planned.)
Also, as a workaround for vaguely-non-ANSI behavior, the :BLOCK-COMPILE
argument is quasi-supported, to determine whether multiple
functions are compiled together as a unit, resolving function
:output-file output-file))
(setq fasl-output
(open-fasl-output output-file-name
- (namestring input-pathname)
- (eq *byte-compile* t))))
+ (namestring input-pathname))))
(when trace-file
(let* ((default-trace-file-pathname
(make-pathname :type "trace" :defaults input-pathname))
;;; 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 (make-pathname :type *fasl-file-type* :defaults defaults)))
retyped))
;;; KLUDGE: Part of the ANSI spec for this seems contradictory:
(:ignore-it
nil)
(t
- (compile-top-level-lambdas () t)
+ (compile-toplevel-lambdas () t)
(when (fasl-constant-already-dumped-p constant *compile-object*)
(return-from emit-make-load-form nil))
(let* ((name (let ((*print-level* 1) (*print-length* 2))
projects / sbcl.git / blobdiff