X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=b4c90eb5c8e85191b25d0438d79b4272901b7646;hb=91392754bf1d241cd6913c728268caf18eae1485;hp=af3cf931877cdb4aea077d780d1e08409fd94bc3;hpb=c831b2828176641e93a45d3fd643e9f58cd44a3f;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index af3cf93..b4c90eb 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -799,11 +799,11 @@ ;;; 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) (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 @@ -871,13 +871,15 @@ (debug-namify "~S initial component" name)) (setf (component-kind component) :initial) (let* ((locall-fun (ir1-convert-lambda - definition - :debug-name (debug-namify "top level local call ~S" - name))) + definition + :debug-name (debug-namify "top level local call ~S" + name))) (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun) :source-name (or name '.anonymous.) :debug-name (unless name "top level form")))) + (when name + (assert-global-function-definition-type name locall-fun)) (setf (functional-entry-fun fun) locall-fun (functional-kind fun) :external (functional-has-external-references-p fun) t) @@ -1113,17 +1115,19 @@ ((macrolet) (funcall-in-macrolet-lexenv magic - (lambda () + (lambda (&key funs) + (declare (ignore funs)) (process-toplevel-locally body path compile-time-too)))) ((symbol-macrolet) (funcall-in-symbol-macrolet-lexenv magic - (lambda () + (lambda (&key vars) (process-toplevel-locally body path - compile-time-too))))))) + compile-time-too + :vars vars))))))) ((locally) (process-toplevel-locally (rest form) path compile-time-too)) ((progn) @@ -1183,68 +1187,29 @@ ;;;; 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) @@ -1261,11 +1226,8 @@ 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)) @@ -1284,20 +1246,17 @@ (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]~%") @@ -1305,7 +1264,7 @@ (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))) @@ -1333,7 +1292,6 @@ (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~%") @@ -1360,7 +1318,6 @@ (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)) @@ -1637,7 +1594,6 @@ (: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))