X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=d77ff04ba15ba370333acc9d7c7c47940f3c52dd;hb=7e24349c17298e2959e853ea411b5f65d9f7f332;hp=d750adf820521db394bfcff050c9379a34596908;hpb=89723dab1eff0dcc17c79c5675cb18c7c4e62b80;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index d750adf..d77ff04 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -37,7 +37,6 @@ (defvar *flame-on-necessarily-undefined-function* nil) (defvar *check-consistency* nil) -(defvar *all-components*) ;;; Set to NIL to disable loop analysis for register allocation. (defvar *loop-analyze* t) @@ -115,6 +114,8 @@ (defvar *compile-object* nil) (declaim (type object *compile-object*)) + +(defvar *fopcompile-label-counter*) ;;;; WITH-COMPILATION-UNIT and WITH-COMPILATION-VALUES @@ -544,6 +545,11 @@ (let* ((*component-being-compiled* component)) + ;; Record xref information before optimization. This way the + ;; stored xref data reflects the real source as closely as + ;; possible. + (record-component-xrefs component) + (ir1-phases component) (when *loop-analyze* @@ -743,7 +749,7 @@ ;;; Given a pathname, return a SOURCE-INFO structure. (defun make-file-source-info (file external-format) (let ((file-info (make-file-info :name (truename file) - :untruename file + :untruename (merge-pathnames file) :external-format external-format :write-date (file-write-date file)))) @@ -852,16 +858,19 @@ ;;; *TOPLEVEL-LAMBDAS* instead. (defun convert-and-maybe-compile (form path) (declare (list path)) - (let* ((*top-level-form-noted* (note-top-level-form form t)) - (*lexenv* (make-lexenv - :policy *policy* - :handled-conditions *handled-conditions* - :disabled-package-locks *disabled-package-locks*)) - (tll (ir1-toplevel form path nil))) - (if (eq *block-compile* t) - (push tll *toplevel-lambdas*) - (compile-toplevel (list tll) nil)) - nil)) + (if (fopcompilable-p form) + (let ((*fopcompile-label-counter* 0)) + (fopcompile form path nil)) + (let* ((*top-level-form-noted* (note-top-level-form form t)) + (*lexenv* (make-lexenv + :policy *policy* + :handled-conditions *handled-conditions* + :disabled-package-locks *disabled-package-locks*)) + (tll (ir1-toplevel form path nil))) + (if (eq *block-compile* t) + (push tll *toplevel-lambdas*) + (compile-toplevel (list tll) nil)) + nil))) ;;; Macroexpand FORM in the current environment with an error handler. ;;; We only expand one level, so that we retain all the intervening @@ -965,16 +974,27 @@ (debug-name 'initial-component name)) (setf (component-kind component) :initial) (let* ((locall-fun (let ((*allow-instrumenting* t)) - (apply #'ir1-convert-lambdalike - definition - (list :source-name name)))) + (funcall #'ir1-convert-lambdalike + definition + :source-name name))) + (debug-name (debug-name 'tl-xep + (or name + (functional-%source-name locall-fun)))) + ;; Convert the XEP using the policy of the real + ;; function. Otherwise the wrong policy will be used for + ;; deciding whether to type-check the parameters of the + ;; real function (via CONVERT-CALL / PROPAGATE-TO-ARGS). + ;; -- JES, 2007-02-27 + (*lexenv* (make-lexenv :policy (lexenv-policy + (functional-lexenv locall-fun)))) (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun) :source-name (or name '.anonymous.) - :debug-name (debug-name 'tl-xep name)))) + :debug-name debug-name))) (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 locall-fun) t (functional-has-external-references-p fun) t) fun))) @@ -1004,6 +1024,7 @@ :policy *policy* :handled-conditions *handled-conditions* :disabled-package-locks *disabled-package-locks*)) + (*compiler-sset-counter* 0) (fun (make-functional-from-toplevel-lambda lambda-expression :name name :path path))) @@ -1018,14 +1039,10 @@ (locall-analyze-clambdas-until-done (list fun)) - (multiple-value-bind (components-from-dfo top-components hairy-top) - (find-initial-dfo (list fun)) - (declare (ignore hairy-top)) - - (let ((*all-components* (append components-from-dfo top-components))) - (dolist (component-from-dfo components-from-dfo) - (compile-component component-from-dfo) - (replace-toplevel-xeps component-from-dfo))) + (let ((components-from-dfo (find-initial-dfo (list fun)))) + (dolist (component-from-dfo components-from-dfo) + (compile-component component-from-dfo) + (replace-toplevel-xeps component-from-dfo)) (let ((entry-table (etypecase *compile-object* (fasl-output (fasl-output-entry-table @@ -1185,7 +1202,9 @@ ;; sequence of steps in ANSI's "3.2.3.1 Processing of ;; Top Level Forms". #-sb-xc-host - (let ((expanded (preprocessor-macroexpand-1 form))) + (let ((expanded + (let ((*current-path* path)) + (preprocessor-macroexpand-1 form)))) (cond ((eq expanded form) (when compile-time-too (eval-in-lexenv form *lexenv*)) @@ -1375,10 +1394,10 @@ (maybe-mumble "IDFO ") (multiple-value-bind (components top-components hairy-top) (find-initial-dfo lambdas) - (let ((*all-components* (append components top-components))) + (let ((all-components (append components top-components))) (when *check-consistency* (maybe-mumble "[check]~%") - (check-ir1-consistency *all-components*)) + (check-ir1-consistency all-components)) (dolist (component (append hairy-top top-components)) (pre-physenv-analyze-toplevel component)) @@ -1389,7 +1408,7 @@ (when *check-consistency* (maybe-mumble "[check]~%") - (check-ir1-consistency *all-components*)) + (check-ir1-consistency all-components)) (if load-time-value-p (compile-load-time-value-lambda lambdas) @@ -1484,6 +1503,7 @@ ;; and it's not obvious whether the rebinding to itself is ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*. (*info-environment* *info-environment*) + (*compiler-sset-counter* 0) (*gensym-counter* 0)) (handler-case (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler)) @@ -1505,8 +1525,8 @@ ;; the input file. (fatal-compiler-error (condition) (signal condition) - (when *compile-verbose* - (format *standard-output* + (pprint-logical-block (*error-output* nil :per-line-prefix "; ") + (format *error-output* "~@" condition)) (values nil t t))))) @@ -1701,13 +1721,14 @@ SPEED and COMPILATION-SPEED optimization values, and the ;;; -- WHN 2000-12-09 (defun sb!xc:compile-file-pathname (input-file &key - (output-file (cfp-output-file-default - input-file)) + (output-file nil output-file-p) &allow-other-keys) #!+sb-doc "Return a pathname describing what file COMPILE-FILE would write to given these arguments." - (merge-pathnames output-file (merge-pathnames input-file))) + (if output-file-p + (merge-pathnames output-file (cfp-output-file-default input-file)) + (cfp-output-file-default input-file))) ;;;; MAKE-LOAD-FORM stuff @@ -1787,8 +1808,6 @@ SPEED and COMPILATION-SPEED optimization values, and the (:ignore-it nil) (t - (when (fasl-constant-already-dumped-p constant *compile-object*) - (return-from emit-make-load-form nil)) (let* ((name (write-to-string constant :level 1 :length 2)) (info (if init-form (list constant name init-form)