X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-main.lisp;h=0b11bda3fc7c5cdfcc4daf5de01414ce0d98669f;hb=3d544b84f2b7ecd617d220145a775079df6c7919;hp=950ccf6954251ba6976975a4f65dfdc24509774b;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index 950ccf6..0b11bda 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -12,97 +12,165 @@ ;;;; files for more information. (in-package "SB!C") - -(file-comment - "$Header$") -;;;; COMPILE and UNCOMPILE +;;;; CL:COMPILE + +(defun get-lambda-to-compile (definition-designator) + (if (consp definition-designator) + definition-designator + (multiple-value-bind (definition env-p) + (function-lambda-expression definition-designator) + (when env-p + (error "~S was defined in a non-null environment." + definition-designator)) + (unless definition + (error "can't find a definition for ~S" definition-designator)) + definition))) -(defun get-lambda-to-compile (definition) - (if (consp definition) - definition - (multiple-value-bind (def env-p) - (function-lambda-expression definition) - (when env-p - (error "~S was defined in a non-null environment." definition)) - (unless def - (error "Can't find a definition for ~S." definition)) - def))) +;;; Handle the nontrivial case of CL:COMPILE. +;;; +;;; If ERRORP is true signals an error immediately -- otherwise returns +;;; a function that will signal the error. +(defun actually-compile (name definition *lexenv* source-info tlf errorp) + (let ((source-paths (when source-info *source-paths*))) + (with-compilation-values + (sb!xc:with-compilation-unit () + ;; FIXME: These bindings were copied from SUB-COMPILE-FILE with + ;; few changes. Once things are stable, the shared bindings + ;; probably be merged back together into some shared utility + ;; macro, or perhaps both merged into one of the existing utility + ;; macros SB-C::WITH-COMPILATION-VALUES or + ;; CL:WITH-COMPILATION-UNIT. + (with-source-paths + (prog* ((tlf (or tlf 0)) + ;; If we have a source-info from LOAD, we will + ;; also have a source-paths already set up -- so drop + ;; the ones from WITH-COMPILATION-VALUES. + (*source-paths* (or source-paths *source-paths*)) + ;; FIXME: Do we need the *INFO-ENVIRONMENT* 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 now that SBCL doesn't + ;; need *BACKEND-INFO-ENVIRONMENT*. + (*info-environment* *info-environment*) + (form (get-lambda-to-compile definition)) + (*source-info* (or source-info + (make-lisp-source-info + form :parent *source-info*))) + (*toplevel-lambdas* ()) + (*block-compile* nil) + (*allow-instrumenting* nil) + (*code-coverage-records* nil) + (*code-coverage-blocks* nil) + (*current-path* nil) + (*last-source-context* nil) + (*last-original-source* nil) + (*last-source-form* nil) + (*last-format-string* nil) + (*last-format-args* nil) + (*last-message-count* 0) + (*last-error-context* nil) + (*gensym-counter* 0) + ;; KLUDGE: This rebinding of policy is necessary so that + ;; forms such as LOCALLY at the REPL actually extend the + ;; compilation policy correctly. However, there is an + ;; invariant that is potentially violated: future + ;; refactoring must not allow this to be done in the file + ;; compiler. At the moment we're clearly alright, as we + ;; call %COMPILE with a core-object, not a fasl-stream, + ;; but caveat future maintainers. -- CSR, 2002-10-27 + (*policy* (lexenv-policy *lexenv*)) + ;; see above + (*handled-conditions* (lexenv-handled-conditions *lexenv*)) + ;; ditto + (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*)) + ;; FIXME: ANSI doesn't say anything about CL:COMPILE + ;; interacting with these variables, so we shouldn't. As + ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by + ;; binding these variables, so as a quick hack we do so + ;; too. But a proper implementation would have verbosity + ;; controlled by function arguments and lexical variables. + (*compile-verbose* nil) + (*compile-print* nil) + (oops nil)) + (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler)) + (unless source-paths + (find-source-paths form tlf)) + (let ((*compiler-error-bailout* + (lambda (e) + (setf oops e) + ;; Unwind the compiler frames: users want the know where + ;; the error came from, not how the compiler got there. + (go :error)))) + (return + (with-world-lock () + (%compile form (make-core-object) + :name name + :path `(original-source-start 0 ,tlf)))))) + :error + ;; Either signal the error right away, or return a function that + ;; will signal the corresponding COMPILED-PROGRAM-ERROR. This is so + ;; that we retain our earlier behaviour when called with erronous + ;; lambdas via %SIMPLE-EVAL. We could legally do just either one + ;; always, but right now keeping the old behaviour seems like less + ;; painful option: compiler.pure.lisp is full of tests that make all + ;; sort of assumptions about when which things are signalled. FIXME, + ;; probably. + (if errorp + (error oops) + (let ((message (princ-to-string oops)) + (source (source-to-string form))) + (return + (lambda (&rest arguments) + (declare (ignore arguments)) + (error 'compiled-program-error + :message message + :source source))))))))))) -;;; Find the function that is being compiled by COMPILE and bash its name to -;;; NAME. We also substitute for any references to name so that recursive -;;; calls will be compiled direct. Lambda is the top-level lambda for the -;;; compilation. A REF for the real function is the only thing in the -;;; top-level lambda other than the bind and return, so it isn't too hard to -;;; find. -(defun compile-fix-function-name (lambda name) - (declare (type clambda lambda) (type (or symbol cons) name)) - (when name - (let ((fun (ref-leaf - (continuation-next - (node-cont (lambda-bind lambda)))))) - (setf (leaf-name fun) name) - (let ((old (gethash name *free-functions*))) - (when old (substitute-leaf fun old))) - name))) +(defun compile-in-lexenv (name definition lexenv + &optional source-info tlf errorp) + (multiple-value-bind (compiled-definition warnings-p failure-p) + (cond + #!+sb-eval + ((sb!eval:interpreted-function-p definition) + (multiple-value-bind (definition lexenv) + (sb!eval:prepare-for-compile definition) + (actually-compile name definition lexenv source-info tlf errorp))) + ((compiled-function-p definition) + (values definition nil nil)) + (t + (actually-compile name definition lexenv source-info tlf errorp))) + (check-type compiled-definition compiled-function) + (cond (name + (if (and (symbolp name) + (macro-function name)) + (setf (macro-function name) compiled-definition) + (setf (fdefinition name) compiled-definition)) + (values name warnings-p failure-p)) + (t + (values compiled-definition warnings-p failure-p))))) -(defun compile (name &optional (definition (fdefinition name))) +(defun compile (name &optional (definition (or (and (symbolp name) + (macro-function name)) + (fdefinition name)))) #!+sb-doc - "Compiles the function whose name is Name. If Definition is supplied, - it should be a lambda expression that is compiled and then placed in the - function cell of Name. If Name is Nil, the compiled code object is - returned." - (with-compilation-values - (sb!xc:with-compilation-unit () - (let* ((*info-environment* (or *backend-info-environment* - *info-environment*)) - (*lexenv* (make-null-lexenv)) - (form `#',(get-lambda-to-compile definition)) - (*source-info* (make-lisp-source-info form)) - (*top-level-lambdas* ()) - (*converting-for-interpreter* nil) - (*block-compile* nil) - (*compiler-error-bailout* - #'(lambda () - (compiler-mumble - "~2&fatal error, aborting compilation~%") - (return-from compile (values nil t nil)))) - (*current-path* nil) - (*last-source-context* nil) - (*last-original-source* nil) - (*last-source-form* nil) - (*last-format-string* nil) - (*last-format-args* nil) - (*last-message-count* 0) - (*compile-object* (make-core-object)) - (*gensym-counter* 0) - ;; FIXME: ANSI doesn't say anything about CL:COMPILE - ;; interacting with these variables, so we shouldn't. As - ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by - ;; binding these variables, so as a quick hack we do so - ;; too. But a proper implementation would have verbosity - ;; controlled by function arguments and lexical variables. - (*compile-verbose* nil) - (*compile-print* nil)) - (clear-stuff) - (find-source-paths form 0) - (let ((lambda (ir1-top-level form '(original-source-start 0 0) t))) + "Produce a compiled function from DEFINITION. If DEFINITION is a +lambda-expression, it is coerced to a function. If DEFINITION is an +interpreted function, it is compiled. If DEFINITION is already a compiled +function, it is used as-is. (Future versions of SBCL might try to +recompile the existing definition, but this is not currently supported.) - (compile-fix-function-name lambda name) - (let* ((component - (block-component (node-block (lambda-bind lambda)))) - (*all-components* (list component))) - (local-call-analyze component)) +If NAME is NIL, the compiled function is returned as the primary value. +Otherwise the resulting compiled function replaces existing function +definition of NAME, and NAME is returned as primary value; if NAME is a symbol +tha names a macro, its macro function is replaced and NAME is returned as +primary value. - (multiple-value-bind (components top-components) - (find-initial-dfo (list lambda)) - (let ((*all-components* (append components top-components))) - (dolist (component *all-components*) - (compile-component component)))) +Also returns secondary value which is true if any conditions of type WARNING +occur during the compilation, and NIL otherwise. - (let* ((res1 (core-call-top-level-lambda lambda *compile-object*)) - (result (or name res1))) - (fix-core-source-info *source-info* *compile-object* res1) - (when name - (setf (fdefinition name) res1)) - result)))))) +Tertiary value is true if any conditions of type ERROR, or WARNING that are +not STYLE-WARNINGs occur during compilation, and NIL otherwise. +" + (compile-in-lexenv name definition (make-null-lexenv)))