+
+;;; utilities for extracting COMPONENTs of FUNCTIONALs
+(defun functional-components (f)
+ (declare (type functional f))
+ (etypecase f
+ (clambda (list (lambda-component f)))
+ (optional-dispatch (let ((result nil))
+ (flet ((maybe-frob (maybe-clambda)
+ (when (and maybe-clambda
+ (promise-ready-p maybe-clambda))
+ (pushnew (lambda-component
+ (force maybe-clambda))
+ result))))
+ (map nil #'maybe-frob (optional-dispatch-entry-points f))
+ (maybe-frob (optional-dispatch-more-entry f))
+ (maybe-frob (optional-dispatch-main-entry f)))
+ result))))
+
+(defun make-functional-from-toplevel-lambda (definition
+ &key
+ name
+ (path
+ ;; I'd thought NIL should
+ ;; work, but it doesn't.
+ ;; -- WHN 2001-09-20
+ (missing-arg)))
+ (let* ((*current-path* path)
+ (component (make-empty-component))
+ (*current-component* component))
+ (setf (component-name component)
+ (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))))
+ (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
+ :source-name (or name '.anonymous.)
+ :debug-name (debug-name 'tl-xep 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 fun) t)
+ fun)))
+
+;;; Compile LAMBDA-EXPRESSION into *COMPILE-OBJECT*, returning a
+;;; description of the result.
+;;; * If *COMPILE-OBJECT* is a CORE-OBJECT, then write the function
+;;; into core and return the compiled FUNCTION value.
+;;; * If *COMPILE-OBJECT* is a fasl file, then write the function
+;;; into the fasl file and return a dump handle.
+;;;
+;;; If NAME is provided, then we try to use it as the name of the
+;;; function for debugging/diagnostic information.
+(defun %compile (lambda-expression
+ *compile-object*
+ &key
+ name
+ (path
+ ;; This magical idiom seems to be the appropriate
+ ;; path for compiling standalone LAMBDAs, judging
+ ;; from the CMU CL code and experiment, so it's a
+ ;; nice default for things where we don't have a
+ ;; real source path (as in e.g. inside CL:COMPILE).
+ '(original-source-start 0 0)))
+ (when name
+ (legal-fun-name-or-type-error name))
+ (let* ((*lexenv* (make-lexenv
+ :policy *policy*
+ :handled-conditions *handled-conditions*
+ :disabled-package-locks *disabled-package-locks*))
+ (fun (make-functional-from-toplevel-lambda lambda-expression
+ :name name
+ :path path)))
+
+ ;; FIXME: The compile-it code from here on is sort of a
+ ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be
+ ;; better to find a way to share the code there; or
+ ;; alternatively, to use this code to replace the code there.
+ ;; (The second alternative might be pretty easy if we used
+ ;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the
+ ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..)
+
+ (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 ((entry-table (etypecase *compile-object*
+ (fasl-output (fasl-output-entry-table
+ *compile-object*))
+ (core-object (core-object-entry-table
+ *compile-object*)))))
+ (multiple-value-bind (result found-p)
+ (gethash (leaf-info fun) entry-table)
+ (aver found-p)
+ (prog1
+ result
+ ;; KLUDGE: This code duplicates some other code in this
+ ;; file. In the great reorganzation, the flow of program
+ ;; logic changed from the original CMUCL model, and that
+ ;; path (as of sbcl-0.7.5 in SUB-COMPILE-FILE) was no
+ ;; longer followed for CORE-OBJECTS, leading to BUG
+ ;; 156. This place is transparently not the right one for
+ ;; this code, but I don't have a clear enough overview of
+ ;; the compiler to know how to rearrange it all so that
+ ;; this operation fits in nicely, and it was blocking
+ ;; reimplementation of (DECLAIM (INLINE FOO)) (MACROLET
+ ;; ((..)) (DEFUN FOO ...))
+ ;;
+ ;; FIXME: This KLUDGE doesn't solve all the problem in an
+ ;; ideal way, as (1) definitions typed in at the REPL
+ ;; without an INLINE declaration will give a NULL
+ ;; FUNCTION-LAMBDA-EXPRESSION (allowable, but not ideal)
+ ;; and (2) INLINE declarations will yield a
+ ;; FUNCTION-LAMBDA-EXPRESSION headed by
+ ;; SB-C:LAMBDA-WITH-LEXENV, even for null LEXENV. -- CSR,
+ ;; 2002-07-02
+ ;;
+ ;; (2) is probably fairly easy to fix -- it is, after all,
+ ;; a matter of list manipulation (or possibly of teaching
+ ;; CL:FUNCTION about SB-C:LAMBDA-WITH-LEXENV). (1) is
+ ;; significantly harder, as the association between
+ ;; function object and source is a tricky one.
+ ;;
+ ;; FUNCTION-LAMBDA-EXPRESSION "works" (i.e. returns a
+ ;; non-NULL list) when the function in question has been
+ ;; compiled by (COMPILE <x> '(LAMBDA ...)); it does not
+ ;; work when it has been compiled as part of the top-level
+ ;; EVAL strategy of compiling everything inside (LAMBDA ()
+ ;; ...). -- CSR, 2002-11-02
+ (when (core-object-p *compile-object*)
+ (fix-core-source-info *source-info* *compile-object* result))
+
+ (mapc #'clear-ir1-info components-from-dfo)
+ (clear-stuff)))))))
+
+(defun process-toplevel-cold-fset (name lambda-expression path)
+ (unless (producing-fasl-file)
+ (error "can't COLD-FSET except in a fasl file"))
+ (legal-fun-name-or-type-error name)
+ (fasl-dump-cold-fset name
+ (%compile lambda-expression
+ *compile-object*
+ :name name
+ :path path)
+ *compile-object*)
+ (values))
+
+(defun note-top-level-form (form &optional finalp)
+ (when *compile-print*
+ (cond ((not *top-level-form-noted*)
+ (let ((*print-length* 2)
+ (*print-level* 2)
+ (*print-pretty* nil))
+ (with-compiler-io-syntax
+ (compiler-mumble "~&; ~:[compiling~;converting~] ~S"
+ *block-compile* form)))
+ form)
+ ((and finalp
+ (eq :top-level-forms *compile-print*)
+ (neq form *top-level-form-noted*))
+ (let ((*print-length* 1)
+ (*print-level* 1)
+ (*print-pretty* nil))
+ (with-compiler-io-syntax
+ (compiler-mumble "~&; ... top level ~S" form)))
+ form)
+ (t
+ *top-level-form-noted*))))
+
+;;; Process a top level FORM with the specified source PATH.
+;;; * If this is a magic top level form, then do stuff.
projects / sbcl.git / blobdiff