X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=84bfea7f25b3b33eee7be2a52a564de46e168c8d;hb=c179ad4d7bef50a974e8907adb079d47c8bea37e;hp=993bd7ff4886f790c274936ff9b81640c517ae0c;hpb=09e08ad0ba4eb09cd1a08ef5b7da527757ca78e5;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 993bd7f..84bfea7 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -136,60 +136,122 @@ (defmacro sb!xc:with-compilation-unit (options &body body) #!+sb-doc - "WITH-COMPILATION-UNIT ({Key Value}*) Form* - This form affects compilations that take place within its dynamic extent. It - is intended to be wrapped around the compilation of all files in the same - system. These keywords are defined: - - :OVERRIDE Boolean-Form - One of the effects of this form is to delay undefined warnings - until the end of the form, instead of giving them at the end of each - compilation. If OVERRIDE is NIL (the default), then the outermost - WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying - OVERRIDE true causes that form to grab any enclosed warnings, even if - it is enclosed by another WITH-COMPILATION-UNIT. - - :SOURCE-PLIST Plist-Form - Attaches the value returned by the Plist-Form to internal debug-source - information of functions compiled in within the dynamic contour. - Primarily for use by development environments, in order to eg. associate - function definitions with editor-buffers. Can be accessed as - SB-INTROSPECT:DEFINITION-SOURCE-PLIST. If multiple, nested - WITH-COMPILATION-UNITs provide :SOURCE-PLISTs, they are appended - togather, innermost left. If Unaffected by :OVERRIDE." + "Affects compilations that take place within its dynamic extent. It is +intended to be eg. wrapped around the compilation of all files in the same system. + +Following options are defined: + + :OVERRIDE Boolean-Form + One of the effects of this form is to delay undefined warnings until the + end of the form, instead of giving them at the end of each compilation. + If OVERRIDE is NIL (the default), then the outermost + WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying + OVERRIDE true causes that form to grab any enclosed warnings, even if it + is enclosed by another WITH-COMPILATION-UNIT. + + :POLICY Optimize-Declaration-Form + Provides dynamic scoping for global compiler optimization qualities and + restrictions, limiting effects of subsequent OPTIMIZE proclamations and + calls to SB-EXT:RESTRICT-COMPILER-POLICY to the dynamic scope of BODY. + + If OVERRIDE is false, specified POLICY is merged with current global + policy. If OVERRIDE is true, current global policy, including any + restrictions, is discarded in favor of the specified POLICY. + + Supplying POLICY NIL is equivalent to the option not being supplied at + all, ie. dynamic scoping of policy does not take place. + + This option is an SBCL-specific experimental extension: Interface + subject to change. + + :SOURCE-NAMESTRING Namestring-Form + Attaches the value returned by the Namestring-Form to the internal + debug-source information as the namestring of the source file. Normally + the namestring of the input-file for COMPILE-FILE is used: this option + can be used to provide source-file information for functions compiled + using COMPILE, or to override the input-file of COMPILE-FILE. + + If both an outer and an inner WITH-COMPILATION-UNIT provide a + SOURCE-NAMESTRING, the inner one takes precedence. Unaffected + by :OVERRIDE. + + This is an SBCL-specific extension. + + :SOURCE-PLIST Plist-Form + Attaches the value returned by the Plist-Form to internal debug-source + information of functions compiled in within the dynamic extent of BODY. + + Primarily for use by development environments, in order to eg. associate + function definitions with editor-buffers. Can be accessed using + SB-INTROSPECT:DEFINITION-SOURCE-PLIST. + + If an outer WITH-COMPILATION-UNIT form also provide a SOURCE-PLIST, it + is appended to the end of the provided SOURCE-PLIST. Unaffected + by :OVERRIDE. + + This is an SBCL-specific extension. + +Examples: + + ;; Prevent proclamations from the file leaking, and restrict + ;; SAFETY to 3 -- otherwise uses the current global policy. + (with-compilation-unit (:policy '(optimize)) + (restrict-compiler-policy 'safety 3) + (load \"foo.lisp\")) + + ;; Using default policy instead of the current global one, + ;; except for DEBUG 3. + (with-compilation-unit (:policy '(optimize debug) + :override t) + (load \"foo.lisp\")) + + ;; Same as if :POLICY had not been specified at all: SAFETY 3 + ;; proclamation leaks out from WITH-COMPILATION-UNIT. + (with-compilation-unit (:policy nil) + (declaim (optimize safety)) + (load \"foo.lisp\")) +" `(%with-compilation-unit (lambda () ,@body) ,@options)) (defvar *source-plist* nil) +(defvar *source-namestring* nil) -(defun %with-compilation-unit (fn &key override source-plist) +(defun %with-compilation-unit (fn &key override policy source-plist source-namestring) (declare (type function fn)) - (let ((succeeded-p nil) - (*source-plist* (append source-plist *source-plist*))) - (if (and *in-compilation-unit* (not override)) - ;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is - ;; ordinarily (unless OVERRIDE) basically a no-op. - (unwind-protect - (multiple-value-prog1 (funcall fn) (setf succeeded-p t)) - (unless succeeded-p - (incf *aborted-compilation-unit-count*))) - (let ((*aborted-compilation-unit-count* 0) - (*compiler-error-count* 0) - (*compiler-warning-count* 0) - (*compiler-style-warning-count* 0) - (*compiler-note-count* 0) - (*undefined-warnings* nil) - (*in-compilation-unit* t)) - (with-world-lock () - (handler-bind ((parse-unknown-type - (lambda (c) - (note-undefined-reference - (parse-unknown-type-specifier c) - :type)))) - (unwind-protect - (multiple-value-prog1 (funcall fn) (setf succeeded-p t)) - (unless succeeded-p - (incf *aborted-compilation-unit-count*)) - (summarize-compilation-unit (not succeeded-p))))))))) + (flet ((with-it () + (let ((succeeded-p nil) + (*source-plist* (append source-plist *source-plist*)) + (*source-namestring* (or source-namestring *source-namestring*))) + (if (and *in-compilation-unit* (not override)) + ;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is + ;; ordinarily (unless OVERRIDE) basically a no-op. + (unwind-protect + (multiple-value-prog1 (funcall fn) (setf succeeded-p t)) + (unless succeeded-p + (incf *aborted-compilation-unit-count*))) + (let ((*aborted-compilation-unit-count* 0) + (*compiler-error-count* 0) + (*compiler-warning-count* 0) + (*compiler-style-warning-count* 0) + (*compiler-note-count* 0) + (*undefined-warnings* nil) + (*in-compilation-unit* t)) + (with-world-lock () + (handler-bind ((parse-unknown-type + (lambda (c) + (note-undefined-reference + (parse-unknown-type-specifier c) + :type)))) + (unwind-protect + (multiple-value-prog1 (funcall fn) (setf succeeded-p t)) + (unless succeeded-p + (incf *aborted-compilation-unit-count*)) + (summarize-compilation-unit (not succeeded-p)))))))))) + (if policy + (let ((*policy* (process-optimize-decl policy (unless override *policy*))) + (*policy-restrictions* (unless override *policy-restrictions*))) + (with-it)) + (with-it)))) ;;; Is NAME something that no conforming program can rely on ;;; defining? @@ -952,7 +1014,7 @@ ;;; We only expand one level, so that we retain all the intervening ;;; forms in the source path. (defun preprocessor-macroexpand-1 (form) - (handler-case (sb!xc:macroexpand-1 form *lexenv*) + (handler-case (%macroexpand-1 form *lexenv*) (error (condition) (compiler-error "(during macroexpansion of ~A)~%~A" (let ((*print-level* 2) @@ -1050,28 +1112,39 @@ (source-name (or name '.anonymous.))) (setf (component-name component) (debug-name 'initial-component debug-name-tail) (component-kind component) :initial) - (let* ((locall-fun (let ((*allow-instrumenting* t)) - (funcall #'ir1-convert-lambdalike - lambda-expression - :source-name source-name))) - ;; 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) + (let* ((fun (let ((*allow-instrumenting* t)) + (funcall #'ir1-convert-lambdalike + lambda-expression + :source-name source-name))) + ;; 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 fun)))) + (xep (ir1-convert-lambda (make-xep-lambda-expression fun) :source-name source-name :debug-name (debug-name 'tl-xep debug-name-tail) :system-lambda t))) (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))) + (assert-global-function-definition-type name fun)) + (setf (functional-kind xep) :external + (functional-entry-fun xep) fun + (functional-entry-fun fun) xep + (component-reanalyze component) t + (functional-has-external-references-p xep) t) + (reoptimize-component component :maybe) + (locall-analyze-xep-entry-point fun) + ;; Any leftover REFs to FUN outside local calls get replaced with the + ;; XEP. + (substitute-leaf-if (lambda (ref) + (let* ((lvar (ref-lvar ref)) + (dest (when lvar (lvar-dest lvar))) + (kind (when (basic-combination-p dest) + (basic-combination-kind dest)))) + (neq :local kind))) + xep + fun) + xep))) ;;; Compile LAMBDA-EXPRESSION into *COMPILE-OBJECT*, returning a ;;; description of the result. @@ -1187,8 +1260,10 @@ (*print-level* 2) (*print-pretty* nil)) (with-compiler-io-syntax - (compiler-mumble "~&; ~:[compiling~;converting~] ~S" - *block-compile* form))) + (compiler-mumble + #-sb-xc-host "~&; ~:[compiling~;converting~] ~S" + #+sb-xc-host "~&; ~:[x-compiling~;x-converting~] ~S" + *block-compile* form))) form) ((and finalp (eq :top-level-forms *compile-print*) @@ -1206,10 +1281,7 @@ ;;; compilation. Normally just evaluate in the appropriate ;;; environment, but also compile if outputting a CFASL. (defun eval-compile-toplevel (body path) - (handler-case (eval-in-lexenv `(progn ,@body) *lexenv*) - (error (condition) - (compiler-error "(during compile-time-too processing)~%~A" - condition))) + (eval-tlf `(progn ,@body) (source-path-tlf-number path) *lexenv*) (when *compile-toplevel-object* (let ((*compile-object* *compile-toplevel-object*)) (convert-and-maybe-compile `(progn ,@body) path)))) @@ -1978,6 +2050,6 @@ SPEED and COMPILATION-SPEED optimization values, and the (compile name lambda)) #+sb-xc-host -(defun eval-in-lexenv (form lexenv) - (declare (ignore lexenv)) +(defun eval-tlf (form index &optional lexenv) + (declare (ignore index lexenv)) (eval form))