-
Notifications
You must be signed in to change notification settings - Fork 313
/
entry.lisp
158 lines (153 loc) · 8.21 KB
/
entry.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
;;;; 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))
;;; 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 (environment-closure (lambda-environment 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 (producing-fasl-file)
;; 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))))
(maybe-emit-make-load-forms inline-expansion)
inline-expansion)))
(and (policy bind (> store-source-form 0))
inline-expansion)))
(doc (functional-documentation internal-fun)))
(when doc
(setf doc (possibly-base-stringize doc)))
(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).
(when (producing-fasl-file)
(maybe-emit-make-load-forms args))
(setf (entry-info-arguments info) 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)
(let ((type (if (and (listp spec)
(typep (setq result (third spec))
'(cons (eql values)
(cons t (cons (eql &optional) null)))))
`(sfunction ,(cadr spec) ,(cadr result))
spec)))
(when (producing-fasl-file)
(maybe-emit-make-load-forms type))
type)))))
(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))
(functional-kind-case lambda
(external
(unless (lambda-has-external-references-p lambda)
(let* ((ef (functional-entry-fun lambda))
(new (make-functional
:kind (functional-kind-attributes 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.
(not (functional-kind-eq main-entry deleted))
(environment-closure (lambda-environment 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))