X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-main.lisp;h=70178958b31aaf7f9e8044feb929e9e054339c2b;hb=0a82f2db352cc348d2107a882e50af222ff97ed3;hp=c77d7ebfe4ed5160047b1485268e25353b6c9fdf;hpb=d3862cc781cabf52f15c2d3a164f992dbbba84f4;p=sbcl.git diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index c77d7eb..7017895 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -15,24 +15,25 @@ ;;;; CL:COMPILE -(defun get-lambda-to-compile (definition) - (if (consp definition) - definition - (multiple-value-bind (def env-p) - (function-lambda-expression definition) +(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)) - (unless def - (error "Can't find a definition for ~S." definition)) - def))) + (error "~S was defined in a non-null environment." + definition-designator)) + (unless definition + (error "can't find a definition for ~S" definition-designator)) + definition))) -;;; 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) +;;; 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-fun-name (lambda name) (declare (type clambda lambda) (type (or symbol cons) name)) (when name (let ((fun (ref-leaf @@ -47,17 +48,23 @@ (defun actually-compile (name definition) (with-compilation-values (sb!xc:with-compilation-unit () - (let* (;; FIXME: Do we need this 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 that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*. + ;; 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. + (let* (;; 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*) (*lexenv* (make-null-lexenv)) - (form `#',(get-lambda-to-compile definition)) + (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 () @@ -71,7 +78,6 @@ (*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 @@ -83,24 +89,9 @@ (*compile-print* nil)) (clear-stuff) (find-source-paths form 0) - (let ((lambda (ir1-top-level form '(original-source-start 0 0) t))) - - (compile-fix-function-name lambda name) - (let* ((component - (block-component (node-block (lambda-bind lambda)))) - (*all-components* (list component))) - (local-call-analyze component)) - - (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)))) - - (let ((compiled-fun (core-call-top-level-lambda lambda - *compile-object*))) - (fix-core-source-info *source-info* *compile-object* compiled-fun) - compiled-fun)))))) + (%compile form (make-core-object) + :name name + :path '(original-source-start 0 0)))))) (defun compile (name &optional (definition (fdefinition name))) #!+sb-doc @@ -108,14 +99,16 @@ to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P), where if NAME is NIL, THING is the result of compilation, and otherwise THING is NAME. When NAME is not NIL, the compiled function - is also set into (FDEFINITION NAME)." + is also set into (MACRO-FUNCTION NAME) if NAME names a macro, or into + (FDEFINITION NAME) otherwise." (multiple-value-bind (compiled-definition warnings-p failure-p) (if (compiled-function-p definition) (values definition nil nil) (actually-compile name definition)) (cond (name - (unless failure-p - (setf (fdefinition name) compiled-definition)) + (if (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)))))