;;;; Code in this file handles VM-independent details of run-time
;;;; function representation that primarily concern IR2 conversion and
;;;; the dumper/loader.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB-C")
;;; This phase runs before IR2 conversion, initializing each XEP's
;;; ENTRY-INFO structure. If there was a forward reference to a function,
;;; then the ENTRY-INFO will already exist, but will be uninitialized.
(defun entry-analyze (component)
(let ((2comp (component-info component)))
(dolist (fun (component-lambdas component))
(when (xep-p fun)
(let ((info (or (leaf-info fun)
(setf (leaf-info fun) (make-entry-info)))))
(compute-entry-info fun info)
(push info (ir2-component-entries 2comp))))))
(values))
;;; An "effectively" null environment captures at most
;;; a compilation policy, nothing more.
;;; This is to make the 2nd value of FUNCTION-LAMBDA-EXPRESSION
;;; accurate; but is it really important to do that? Nah.
#+nil
(defun effectively-null-lexenv-p (lexenv)
(or (null-lexenv-p lexenv)
(and (not (or (lexenv-funs lexenv)
(lexenv-vars lexenv)
(lexenv-blocks lexenv)
(lexenv-tags lexenv)
(lexenv-type-restrictions lexenv)
(lexenv-lambda lexenv)
(lexenv-cleanup lexenv)
(lexenv-handled-conditions lexenv)
(lexenv-disabled-package-locks lexenv)
(lexenv-user-data lexenv)))
(or (not (lexenv-parent lexenv))
(null-lexenv-p (lexenv-parent lexenv))))))
;;; Initialize INFO structure to correspond to the XEP LAMBDA FUN.
(defun compute-entry-info (fun info)
(declare (type clambda fun) (type entry-info info))
(let ((bind (lambda-bind fun))
(internal-fun (functional-entry-fun fun)))
(setf (entry-info-closure-tn info)
(if (physenv-closure (lambda-physenv fun))
(make-normal-tn *backend-t-primitive-type*)
nil))
(setf (entry-info-offset info) (gen-label))
(setf (entry-info-name info)
(leaf-debug-name internal-fun))
(setf (entry-info-xref info) (pack-xref-data (functional-xref internal-fun)))
(let* ((inline-expansion (functional-inline-expansion internal-fun))
(form (if (fasl-output-p *compile-object*)
;; If compiling to a file, we only store sources if the STORE-SOURCE
;; quality value is 3. If to memory, any nonzero value will do.
(and (policy bind (= store-source-form 3))
;; Downgrade the error to a warning if this was signaled
;; by SB-PCL::DONT-KNOW-HOW-TO-DUMP.
;; If not that, let the error propagate.
(block nil
(handler-bind
((compiler-error
;; Everything about error handling sucks so badly.
;; Why turn a perfectly good error into a different
;; and not necessarily better error?
(lambda (e &aux (c (encapsulated-condition e)))
;; And why the heck isn't this just NO-APPLICABLE-METHOD
;; on MAKE-LOAD-FORM? Why did we choose to further obfuscate
;; a condition that was reflectable and instead turn it
;; into a dumb text string?
(if (and (typep c 'simple-error)
(stringp (simple-condition-format-control c))
(search "know how to dump"
(simple-condition-format-control c)))
;; This might be worth a full warning. Dunno.
;; After all, the user asked to do what can't be done.
(compiler-style-warn
"Can't preserve function source - ~
missing MAKE-LOAD-FORM methods?")
(compiler-style-warn
"Can't preserve function source: ~A"
(princ-to-string c)))
(return nil))))
(constant-value (find-constant inline-expansion)))))
(and (policy bind (> store-source-form 0))
inline-expansion)))
(doc (functional-documentation internal-fun)))
(setf (entry-info-form/doc info)
(if (and form doc) (cons form doc) (or form doc))))
(when (policy bind (>= debug 1))
(let ((args (functional-arg-documentation internal-fun)))
;; When the component is dumped, the arglists of the entry
;; points will be dumped. If they contain values that need
;; make-load-form processing then we need to do it now (bug
;; 310132).
(setf (entry-info-arguments info)
(constant-value (find-constant args))))
;; Arguably we should not parse/unparse if the type was obtained from
;; a proclamation. On the other hand, this preserves exact semantics
;; if a later DEFTYPE changes something. Be that as it may, storing
;; just <X> instead of (VALUES <X> &OPTIONAL) saves 6 words per entry.
(let ((spec (type-specifier (leaf-type internal-fun)))
(result))
(setf (entry-info-type info)
(constant-value
(find-constant
(if (and (listp spec)
(typep (setq result (third spec))
'(cons (eql values)
(cons t (cons (eql &optional) null)))))
`(sfunction ,(cadr spec) ,(cadr result))
spec)))))))
(values))
;;; Replace all references to COMPONENT's non-closure XEPs that appear
;;; in top level or externally-referenced components, changing to
;;; :TOPLEVEL-XEP FUNCTIONALs. If the cross-component ref is not in a
;;; :TOPLEVEL/externally-referenced component, or is to a closure,
;;; then substitution is suppressed.
;;;
;;; When a cross-component ref is not substituted, we return T to
;;; indicate that early deletion of this component's IR1 should not be
;;; done. We also return T if this component contains
;;; :TOPLEVEL/externally-referenced lambdas (though it is not a
;;; :TOPLEVEL component.)
;;;
;;; We deliberately don't use the normal reference deletion, since we
;;; don't want to trigger deletion of the XEP (although it shouldn't
;;; hurt, since this is called after COMPONENT is compiled.) Instead,
;;; we just clobber the REF-LEAF.
(defun replace-toplevel-xeps (component)
(let ((res nil))
(dolist (lambda (component-lambdas component))
(case (functional-kind lambda)
(:external
(unless (lambda-has-external-references-p lambda)
(let* ((ef (functional-entry-fun lambda))
(new (make-functional
:kind :toplevel-xep
:info (leaf-info lambda)
:%source-name (functional-%source-name ef)
:%debug-name (functional-%debug-name ef)
:lexenv (make-null-lexenv)))
(main-entry (main-entry ef))
(closure (and
;; It may have been deleted due to none of
;; the optional entries reaching it.
(neq (functional-kind main-entry) :deleted)
(physenv-closure (lambda-physenv main-entry)))))
(dolist (ref (leaf-refs lambda))
(let ((ref-component (node-component ref)))
(cond ((eq ref-component component))
((or (not (component-toplevelish-p ref-component))
closure)
(setq res t))
(t
(setf (ref-leaf ref) new)
(push ref (leaf-refs new))
(setf (leaf-refs lambda)
(delq1 ref (leaf-refs lambda))))))))))
(:toplevel
(setq res t))))
res))