;;; 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)
+(defun process-toplevel-locally (body path compile-time-too &key vars funs)
(declare (list path))
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
(let* ((*lexenv*
- (process-decls decls nil nil (make-continuation)))
+ (process-decls decls vars funs (make-continuation)))
;; 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
;; 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)))
- (unless (or (null name) (legal-fun-name-p name))
- (error "not a legal function name: ~S" name))
+ (when name
+ (legal-fun-name-or-type-error name))
(let* ((*lexenv* (make-lexenv :policy *policy*))
(fun (make-functional-from-toplevel-lambda lambda-expression
:name name
(gethash (leaf-info fun) entry-table)
(aver found-p)
result))
+ ;; KLUDGE: This code duplicates some other code in this
+ ;; file. In the great reorganzation, the flow of program logic
+ ;; changed from the original CMUCL model, and that path (as of
+ ;; sbcl-0.7.5 in SUB-COMPILE-FILE) was no longer followed for
+ ;; CORE-OBJECTS, leading to BUG 156. This place is
+ ;; transparently not the right one for this code, but I don't
+ ;; have a clear enough overview of the compiler to know how to
+ ;; rearrange it all so that this operation fits in nicely, and
+ ;; it was blocking reimplementation of
+ ;; (DECLAIM (INLINE FOO)) (MACROLET ((..)) (DEFUN FOO ...))
+ ;;
+ ;; FIXME: This KLUDGE doesn't solve all the problem in an
+ ;; ideal way, as (1) definitions typed in at the REPL without
+ ;; an INLINE declaration will give a NULL
+ ;; FUNCTION-LAMBDA-EXPRESSION (allowable, but not ideal) and
+ ;; (2) INLINE declarations will yield a
+ ;; FUNCTION-LAMBDA-EXPRESSION headed by
+ ;; SB-C:LAMBDA-WITH-LEXENV, even for null LEXENV.
+ ;;
+ ;; CSR, 2002-07-02
+ (when (core-object-p *compile-object*)
+ (fix-core-source-info *source-info* *compile-object*))
+
(mapc #'clear-ir1-info components-from-dfo)
(clear-stuff)))))
(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))
+ (legal-fun-name-or-type-error name)
(fasl-dump-cold-fset name
(%compile lambda-expression
*compile-object*
(*compiler-error-bailout*
(lambda ()
(convert-and-maybe-compile
- `(error "execution of a form compiled with errors:~% ~S"
- ',form)
+ `(error 'simple-program-error
+ :format-control "execution of a form compiled with errors:~% ~S"
+ :format-arguments (list ',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)
- (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)))
+ (flet ((default-processor (form)
+ ;; 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
+ (progn
+ (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
+ (let ((expanded (preprocessor-macroexpand-1 form)))
(cond ((eq expanded form)
(when compile-time-too
- (eval form))
+ (eval-in-lexenv form *lexenv*))
(convert-and-maybe-compile form path))
(t
(process-toplevel-form expanded
path
- compile-time-too))))))))))
+ compile-time-too))))))
+ (if (atom form)
+ #+sb-xc-host
+ ;; (There are no EVAL-WHEN issues in the ATOM case until
+ ;; SBCL gets smart enough to handle global
+ ;; DEFINE-SYMBOL-MACRO or SYMBOL-MACROLET.)
+ (convert-and-maybe-compile form path)
+ #-sb-xc-host
+ (default-processor form)
+ (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-in-lexenv
+ `(progn ,@body)
+ *lexenv*))))))
+ ((macrolet)
+ (funcall-in-macrolet-lexenv
+ magic
+ (lambda (&key funs)
+ (declare (ignore funs))
+ (process-toplevel-locally body
+ path
+ compile-time-too))))
+ ((symbol-macrolet)
+ (funcall-in-symbol-macrolet-lexenv
+ magic
+ (lambda (&key vars)
+ (process-toplevel-locally body
+ path
+ compile-time-too
+ :vars vars)))))))
+ ((locally)
+ (process-toplevel-locally (rest form) path compile-time-too))
+ ((progn)
+ (process-toplevel-progn (rest form) path compile-time-too))
+ (t (default-processor form))))))))
(values))
\f
\f
;;;; COMPILE-FILE
-;;; We build a list of top level lambdas, and then periodically smash
-;;; them together into a single component and compile it.
-(defvar *pending-toplevel-lambdas*)
-
-;;; 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
-;;; troublesome constructs correctly, e.g. inability to load a fasl
-;;; file compiled from the source file
-;;; (defpackage "FOO" (:use "CL"))
-;;; (print 'foo::bar)
-;;; because it would dump data-setup fops (including a FOP-PACKAGE for
-;;; "FOO") for the second form before dumping the the code in the
-;;; first form, or the fop to execute the code in the first form. By
-;;; setting this value to 0 by default, we avoid this badness. This
-;;; increases the number of toplevel form functions, and so increases
-;;; the size of object files.
-;;;
-;;; The variable is still supported because when we are compiling the
-;;; SBCL system itself, which is known not contain any troublesome
-;;; constructs, we can set it to a nonzero value, which reduces the
-;;; number of toplevel form objects, reducing the peak memory usage in
-;;; 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 *toplevel-lambda-max* 0)
-
(defun object-call-toplevel-lambda (tll)
(declare (type functional tll))
(let ((object *compile-object*))
(etypecase object
- (fasl-output
- (fasl-dump-toplevel-lambda-call tll object))
- (core-object
- (core-call-toplevel-lambda tll object))
+ (fasl-output (fasl-dump-toplevel-lambda-call tll object))
+ (core-object (core-call-toplevel-lambda tll object))
(null))))
-;;; Add LAMBDAS to the pending lambdas. If this leaves more than
-;;; *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-toplevel-lambdas (lambdas force-p)
+;;; Smash LAMBDAS into a single component, compile it, and arrange for
+;;; the resulting function to be called.
+(defun sub-compile-toplevel-lambdas (lambdas)
(declare (list lambdas))
- (setq *pending-toplevel-lambdas*
- (append *pending-toplevel-lambdas* lambdas))
- (let ((pending *pending-toplevel-lambdas*))
- (when (and pending
- (or (> (length pending) *toplevel-lambda-max*)
- force-p))
- (multiple-value-bind (component tll) (merge-toplevel-lambdas pending)
- (setq *pending-toplevel-lambdas* ())
- (compile-component component)
- (clear-ir1-info component)
- (object-call-toplevel-lambda tll))))
+ (when lambdas
+ (multiple-value-bind (component tll) (merge-toplevel-lambdas lambdas)
+ (compile-component component)
+ (clear-ir1-info component)
+ (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-toplevel-lambdas (lambdas force-p)
+(defun compile-toplevel-lambdas (lambdas)
(declare (list lambdas))
(let ((len (length lambdas)))
(flet ((loser (start)
(node-component (lambda-bind x)))
:toplevel)))
lambdas
- :start start)
+ ;; this used to read ":start start", but
+ ;; start can be greater than len, which
+ ;; is an error according to ANSI - CSR,
+ ;; 2002-04-25
+ :start (min start len))
len)))
(do* ((start 0 (1+ loser))
(loser (loser start) (loser start)))
- ((>= start len)
- (when force-p
- (sub-compile-toplevel-lambdas nil t)))
- (sub-compile-toplevel-lambdas (subseq lambdas start loser)
- (or force-p (/= loser len)))
+ ((>= start len))
+ (sub-compile-toplevel-lambdas (subseq lambdas start loser))
(unless (= loser len)
(object-call-toplevel-lambda (elt lambdas loser))))))
(values))
(maybe-mumble "IDFO ")
(multiple-value-bind (components top-components hairy-top)
(find-initial-dfo lambdas)
- (let ((*all-components* (append components top-components))
- (toplevel-closure nil))
+ (let ((*all-components* (append components top-components)))
(when *check-consistency*
(maybe-mumble "[check]~%")
(check-ir1-consistency *all-components*))
(dolist (component (append hairy-top top-components))
- (when (pre-physenv-analyze-toplevel component)
- (setq toplevel-closure t)))
+ (pre-physenv-analyze-toplevel component))
(dolist (component components)
(compile-component component)
- (when (replace-toplevel-xeps component)
- (setq toplevel-closure t)))
+ (replace-toplevel-xeps component))
(when *check-consistency*
(maybe-mumble "[check]~%")
(if load-time-value-p
(compile-load-time-value-lambda lambdas)
- (compile-toplevel-lambdas lambdas toplevel-closure))
+ (compile-toplevel-lambdas lambdas))
(mapc #'clear-ir1-info components)
(clear-stuff)))
(sb!xc:*compile-file-pathname* nil)
(sb!xc:*compile-file-truename* nil)
(*toplevel-lambdas* ())
- (*pending-toplevel-lambdas* ())
(*compiler-error-bailout*
(lambda ()
(compiler-mumble "~2&; fatal error, aborting compilation~%")
(sub-sub-compile-file info)
(finish-block-compilation)
- (compile-toplevel-lambdas () t)
(let ((object *compile-object*))
(etypecase object
(fasl-output (fasl-dump-source-info info object))
#!+sb-doc
"Return a pathname describing what file COMPILE-FILE would write to given
these arguments."
- (pathname output-file))
+ (merge-pathnames output-file (merge-pathnames input-file)))
\f
;;;; MAKE-LOAD-FORM stuff
;;; If the constant doesn't show up in *CONSTANTS-BEING-CREATED*, then
;;; we have to create it. We call MAKE-LOAD-FORM and check to see
;;; whether the creation form is the magic value
-;;; :JUST-DUMP-IT-NORMALLY. If it is, then we don't do anything. The
+;;; :SB-JUST-DUMP-IT-NORMALLY. If it is, then we don't do anything. The
;;; dumper will eventually get its hands on the object and use the
;;; normal structure dumping noise on it.
;;;
constant
condition)))
(case creation-form
- (:just-dump-it-normally
+ (:sb-just-dump-it-normally
(fasl-validate-structure constant *compile-object*)
t)
(:ignore-it
nil)
(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))
(when circular-ref
(setf (cdr circular-ref)
(append (cdr circular-ref) (cdr info))))))))))))
+
+\f
+;;;; Host compile time definitions
+#+sb-xc-host
+(defun compile-in-lexenv (name lambda lexenv)
+ (declare (ignore lexenv))
+ (compile name lambda))
+
+#+sb-xc-host
+(defun eval-in-lexenv (form lexenv)
+ (declare (ignore lexenv))
+ (eval form))
projects / sbcl.git / blobdiff