1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
10 (in-package "SB-INTERPRETER")
12 ;;; The policy in *VACUOUS-DECLS* specifies neither primary nor dependent
13 ;;; qualities. By this we can determine that the env is to be skipped over
14 ;;; when looking for the current policy.
15 (defglobal *vacuous-decls
* (make-decl-scope nil
(sb-c::make-policy
0 0)))
17 ;;; One environment subtype exists for each kind of binding form.
18 ;;; Structurally they are all identical, except that LAMBDA adds
19 ;;; a block name, as an optimization wherein we attempt to elide
20 ;;; creation of two lexical contours - one for the variables and
21 ;;; one for the block - by creating only one contour when there
22 ;;; is no chance that user code could detect that the block's scope
23 ;;; was "widened" to encompass the variable bindings.
25 ;;; LET and LET* use the same ENV type. The major difference with LAMBDA
26 ;;; is that it has a fancy way to compute initial values,
27 ;;; but internally the bindings look like they came from LET*.
29 (macrolet ((def-subtype (type &optional more-slots
)
30 (let ((constructor (symbolicate "MAKE-" type
)))
32 (declaim (inline ,constructor
))
35 (:include basic-env
) (:copier nil
)
36 (:constructor
,constructor
37 (parent payload symbols contour
,@more-slots
)))
39 (declaim (freeze-type ,type
))))))
40 (def-subtype function-env
)
42 (def-subtype macro-env
)
43 (def-subtype symbol-macro-env
)
44 (def-subtype block-env
)
45 (def-subtype tagbody-env
)
46 ;; LAMBDA-ENV is a theoretical subtype of both VAR-ENV and BLOCK-ENV
47 ;; but implementationally all subtypes are pairwise disjoint.
48 ;; Defining them thusly is a small efficiency win for the compiler,
49 ;; because TYPEP has an optimization for sealed classes with no subclass,
50 ;; but not for a sealed class with a fixed number of sealed subclasses.
51 ;; Plus since structs don't support multiple inheritance anyway,
52 ;; it would be arbitrary whether lambda-env were defined as a LET
53 ;; with a block name, or a BLOCK and some bindings.
54 (def-subtype lambda-env
(block)))
56 ;;; This implementation of lexical environments takes a fairly unconvential
57 ;;; approach to dealing with sequential (LET*) binding. [Anything said here
58 ;;; about LET* pertains to LAMBDA as well]. The conceptual model for LET* is
59 ;;; that it is a sequence of nested LET forms, each creating one binding.
60 ;;; This is often implemented by allocating a new environment structure per
61 ;;; variable, exactly as implied by the equivalence with nested LET forms.
63 ;;; An implementation that realizes LET* as such is quite inefficient though,
64 ;;; especially if the LET* did not really need to be a LET* and was
65 ;;; "just written that way". Assuming that the speed overhead is at least
66 ;;; the space overhead - allocating N words takes N time - we can easily
67 ;;; estimate the space overhead alone based on the structures above.
68 ;;; One VAR-ENV takes up 6 words, plus a simple-vector for the variable values.
69 ;;; Binding 10 variables in a LET consumes 18 words: 6 fixed, plus 12 words
70 ;;; for a 10-vector. In contrast, 10 bindings if nested would take 100 words
71 ;;; which is 10 * (6 + 4). This is nearly 6 times more space.
72 ;;; [The smallest non-empty simple-vector is 4 words]
74 ;;; So instead of using nested environments, this interpreter uses a single
75 ;;; vector for storing all the variables of a LET*, and a quasi-fill-pointer
76 ;;; (essentially a fill-pointer, but not stored as part an adjustable vector)
77 ;;; indicating the effective end. Any operation on the vector should simply
78 ;;; pretend that bindings beyond the effective end do not exist. Furthermore
79 ;;; the parts of the environment pertaining to the body forms of the LET*,
80 ;;; such as TYPE declarations for other than the bound variables, and SPECIAL
81 ;;; declarations, do not exist until all variables have been sequentially bound.
82 ;;; This is dealt with by having the declaration accessors return NIL until such
83 ;;; time as the fill-pointer has reached its limit, at which point the extra
84 ;;; declarations in the environment (SPECIAL,OPTIMIZE,etc.) become visible.
86 ;;; An environment is termed "mutable" if it has not reached the end of its
87 ;;; bindings - it is still subject to change by binding additional variables
88 ;;; beyond the last which is currently bound. But once the last variable has
89 ;;; been bound, the environment becomes "immutable" and it exposes all its
90 ;;; variables plus the free declarations and such.
91 ;;; LET (specifically, not LET*) environments are never mutable because
92 ;;; no new environment is materialized until after all variable initialization
93 ;;; values have been computed. Only the value vector is made in the interim.
95 ;;; But mutability causes a problem for lexical closures - a closure needs a
96 ;;; fixed view of the environment. The solution is to place the burden upon
97 ;;; closure allocation to capture the fixed view.
98 ;;; The FUNCTION special operator is responsible for looking at the environment
99 ;;; that it closes over, and deciding whether the environment is in flux.
100 ;;; If it is, then FUNCTION needs to "freeze" the mutable environment by sharing
101 ;;; all value cells and storing a fixed value for the fill-pointer.
102 ;;; This is a recursive operation - you can close over an immutable environment
103 ;;; whose parent is mutable, so that a deep copy occurs "upwardly"
104 ;;; e.g. in (LET* ((f (...)) (g (let ((x 3)) (lambda () ...))) (h ..)))
105 ;;; the LAMBDA's innermost contour contains an immutable environment for X,
106 ;;; whose ancestor is a mutable environment in which F is seen but not G or H.
108 ;;; In practice it makes a lot of sense to place the burden on closure creation.
109 ;;; to avoid work during environment construction. As shown by the example,
110 ;;; you must write fairly contrived code to cause a closure to see only part
111 ;;; of a LET* environment. Contrived as that it though, there is indeed a
112 ;;; use-case for it. The PCL defmethod expander exercises this uncommon
113 ;;; pattern when making its fast method function:
114 ;;; (LET* ((FMF (NAMED-LAMBDA () ...)) (MF (%MAKE-METHOD-FUNCTION FMF NIL))))
115 ;;; This NAMED-LAMBDA should see no symbols in the LET* environment.
116 ;;; But in fact this usage is a degenerate example in which there is no need
117 ;;; to freeze the environment as long as the parent did not need to be frozen.
118 ;;; Since nothing was bound in the LET*, it is as if it had not happened at all,
119 ;;; as far as the closure is concerned. Is is likely that scenarios in which
120 ;;; freezing must do a non-trivial amount of work are quite rare.
122 ;;; All that said, the representation of "mutable" is that instead of
123 ;;; a vector of sybols, we have a cons of a fixnum and a vector, so ...
124 ;;; Return T if the ENV is currently undergoing sequential variable binding.
125 (declaim (inline env-mutable-p
))
126 (defun env-mutable-p (env) (consp (env-symbols env
)))
128 ;;; Code should only inquire of N-VARS when in the midst of a LET*
129 ;;; or LAMBDA sequential binding operation, not LET, and not a completely
130 ;;; bound LET* or LAMBDA. (You can't take CAR of symbols in that case)
131 (declaim (inline env-n-vars
))
132 (defun env-n-vars (env) (car (env-symbols env
)))
134 ;;; Each subtype of ENV points to subtype of a DECL-SCOPE.
136 (defstruct (local-scope (:include decl-scope
)
137 (:constructor %make-local-scope
138 (declarations %policy body specials
))
141 (specials nil
:read-only t
)
142 (body nil
:read-only t
))
144 (defstruct (local-fn-scope
145 (:include local-scope
)
146 (:constructor %make-local-fn-scope
147 (declarations %policy funs body specials
))
150 (funs nil
:type simple-vector
:read-only t
))
152 (defstruct (symbol-macro-scope
153 (:conc-name symbol-macro-
)
154 (:include decl-scope
)
155 (:constructor %make-symbol-macro-scope
156 (declarations %policy symbols expansions body
))
159 (symbols nil
:type simple-vector
:read-only t
)
160 (expansions nil
:type simple-vector
:read-only t
)
161 (body nil
:read-only t
))
163 ;;; "scope" and "frame" are basically synonymous here.
164 ;;; The existence of both terms is a minor accident.
166 ;; Binding frame specification for LET and LET*
167 ;; This is a prototype stack-frame rather than a runtime stack frame in that
168 ;; one exists per syntactic form, not per dynamic invocation of same.
169 (defstruct (frame (:include decl-scope
)
170 (:copier nil
) (:predicate nil
)
171 (:constructor make-let-frame
172 (declarations %policy
173 symbols special-b values sexpr specials
)))
174 ;; If more symbols exist than values, the remainder are free specials.
175 (symbols nil
:read-only t
:type simple-vector
)
176 ;; Bitmask over symbols. 1 in bit N means bind the Nth symbol as special.
177 (special-b nil
:read-only t
:type integer
)
178 ;; A let frame can't have zero values. (It would be converted to LOCALLY)
179 (values nil
:read-only t
:type simple-vector
)
180 (sexpr nil
:read-only t
) ; code to execute
181 ;; To avoid reconstituting the first PROGV operand from the special-b mask
182 ;; and vector of all bound symbols, store the bound specials as follows:
183 ;; for LET - a list of all bound specials
184 ;; for LET* - a list of singleton lists of bound specials
185 ;; for LAMBDA - possibly both of the preceding: a list for mandatory args
186 ;; and lists of singleton lists for &optional/&rest/&key.
187 (specials nil
:read-only t
))
189 (defmethod print-object ((self frame
) stream
)
190 (print-unreadable-object (self stream
:type t
:identity t
)))
192 (declaim (inline frame-size
))
193 (defun frame-size (frame) (length (frame-values frame
)))
195 ;;; A LET* frame is just like a LET frame.
196 (defstruct (let*-frame
197 (:include frame
) (:predicate nil
) (:copier nil
)
198 (:constructor make-let
*-frame
199 (declarations %policy symbols special-b
200 values sexpr specials
))))
202 ;;; BASIC-ENV stores a policy for its body, but if evaluation has not reached
203 ;;; the body forms of a LET*, then the old policy is in effect. This is due to
204 ;;; the need for presenting a consistent view of the policy, but a frozen ENV
205 ;;; does not get a different static environment - it sees the same object
206 ;;; that the body forms see.
207 (defun env-policy (env)
208 (cond ((not env
) sb-c
::*policy
*)
209 ((env-mutable-p env
) (env-policy (env-parent env
)))
210 (t (let ((policy (%policy
(env-contour env
))))
211 ;; If the policy contains no qualities, look to the parent env.
212 ;; This happens with a BLOCK or TAGBODY, as well as the
213 ;; environment in which LABELS are defined.
214 (if (eql (sb-c::policy-presence-bits policy
) 0)
215 (env-policy (env-parent env
))
218 ;; Fancy binding frame specification
219 (defstruct (lambda-frame (:include let
*-frame
) (:predicate nil
) (:copier nil
))
220 ;; Unlike for a LET* frame the count of bound values can not be determined
221 ;; from the length of the VALUES vector, which contains various extra markers
222 ;; dictating how the arguments are to be parsed.
223 (n-bound-vars 0 :read-only t
:type fixnum
)
224 ;; Number of mandatory and optional arguments.
225 (min-args 0 :read-only t
:type fixnum
)
226 (n-optional 0 :read-only t
:type fixnum
)
227 ;; Packed flags indicating presence of &REST/&KEY/&ALLOW-OTHER-KEYS.
228 (keyword-bits 0 :read-only t
:type fixnum
)
229 ;; A BLOCK name in which to wrap the lambda's evaluable forms.
230 ;; This behaves exactly the same as using a block-env around the forms,
231 ;; however a lambda-env consumes only 8 words plus 2 for the freshly consed
232 ;; catch tag; whereas a var-env + block-env would consume 6 + 6 + 2, which
233 ;; entails 40% more overhead to enter the most trivial interpreted function.
234 (block-name 0 :read-only t
:type
(or (eql 0) symbol
))
235 ;; SHARE-BLOCK-P is T if BLOCK-NAME can be created concurrently
236 ;; with variable bindings. If NIL when a block-name is present,
237 ;; then another environment is allocated to enclose the block,
238 ;; which is not as big a win as combining the block-env and var-env,
239 ;; but still beneficial as it avoids separately calling the block handler.
240 (share-block-p nil
:read-only t
:type boolean
))
242 (defconstant +restp-bit
+ #b100
)
243 (defconstant +keyp-bit
+ #b010
)
244 (defconstant +allowp-bit
+ #b001
)
246 (declaim (inline make-keyword-bits keyword-bits-n-keys keyword-bits-allowp
))
247 (defun make-keyword-bits (n-keys restp keyp allowp
)
248 (logior (ash n-keys
3)
249 (if restp
+restp-bit
+ 0)
250 (if keyp
+keyp-bit
+ 0)
251 (if allowp
+allowp-bit
+ 0)))
252 (defun keyword-bits-n-keys (bits) (ash bits -
3))
253 (defun keyword-bits-allowp (bits) (logtest bits
+allowp-bit
+))
255 (defun lambda-frame-max-args (frame) ; NIL if no explicit upper limit
256 (if (logtest (lambda-frame-keyword-bits frame
)
257 (logior +restp-bit
+ +keyp-bit
+))
259 (truly-the index
(+ (lambda-frame-min-args frame
)
260 (lambda-frame-n-optional frame
)))))
262 ;;; Computation of package locks is done lazily and usually memoized,
263 ;;; but not not memoized if the env is mutable.
264 ;;; This is not as critical to performance as an efficient implementation
265 ;;; of ENV-POLICY so we don't memoize the "old" value. Computing it might
266 ;;; have to bubble up to the null lexenv. But that seems ok for two reasons:
267 ;;; - the only likely way that a closure would see a "wrong" value for this
268 ;;; is if the special variable SB-C::*DISABLED-PACKAGE-LOCKS* were
269 ;;; changed at an inopportune time. It doesn't seem worth worry about.
270 ;;; - even when unmemoized, this is only computed once per binding form,
271 ;;; whereas a valid POLICY is required at each read or write of a lexical
272 ;;; variable. So the binding forms scale much better - binding 20 variables
273 ;;; only compute the package locks once, at parse time of the form.
274 (defun env-disabled-package-locks (env)
275 (cond ((not env
) sb-c
::*disabled-package-locks
*)
276 ((not (env-mutable-p env
))
277 (let ((list (%disabled-package-locks
(env-contour env
))))
278 (when (eq list
:uncomputed
)
279 (setq list
(env-disabled-package-locks (env-parent env
)))
280 (do-decl-spec (declaration (env-declarations env
))
281 (case (car declaration
)
282 ((disable-package-locks enable-package-locks
)
284 (sb-c::process-package-lock-decl declaration list
)))))
285 (setf (%disabled-package-locks
(env-contour env
)) list
))
287 (t (env-disabled-package-locks (env-parent env
)))))
289 ;;; Return the declarations which are currently effective in ENV.
290 ;;; If ENV is a sequential binding environment which has not reached
291 ;;; its body forms, return NIL. This is not recursive,
292 ;;; because declarations are a local aspect of the ENV.
293 (defun env-declarations (env)
294 (if (env-mutable-p env
) nil
(declarations (env-contour env
))))
296 ;;; Everything in the interpreter is compiled without safety,
297 ;;; because when thing work as they should, no mistaken assumptions are made
298 ;;; about the internals. For user code, safety is effectively imparted by the
299 ;;; strict checking of argument list arity in interpreted APPLY,
300 ;;; and all system functions are safe when invoked through their public API.
301 ;;; Whether maximally strict checking of types is performed in user code
302 ;;; has nothing to do with how the interpreter is compiled.
303 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
304 ;; Of course, errors are possible in the interpreter itself,
305 ;; so in that case it helps to define this as '() for debugging.
306 #+nil
(defparameter +handler-optimize
+ '(optimize))
307 (defparameter +handler-optimize
+ '(optimize (speed 2) (debug 2) (safety 0))))
309 ;;; We represent a pointer to a symbol in an environment by a FRAME-PTR
310 ;;; which is a packed integer containing the "up" and "across" indices.
311 (declaim (inline make-frame-ptr frame-ptr-depth frame-ptr-cell-index
))
312 ;;; This provides constant-time access to lexical variables within a frame.
313 (defun make-frame-ptr (across &optional
(up 0))
314 (declare (type (unsigned-byte #.
+frame-depth-bits
+) up
)
315 (type (unsigned-byte #.
+frame-size-bits
+) across
)
316 #.
+handler-optimize
+)
317 (logior (ash across
+frame-depth-bits
+) up
))
319 (defun frame-ptr-depth (frame-ptr) ; "up"
320 (declare (fixnum frame-ptr
))
321 (ldb (byte +frame-depth-bits
+ 0) frame-ptr
))
323 (defun frame-ptr-cell-index (frame-ptr) ; "across"
324 (declare (fixnum frame-ptr
))
325 (ash frame-ptr
(- +frame-depth-bits
+)))
327 ;;; Older frames take O(depth) to locate.
328 (declaim (inline env-ancestor
))
329 (defun env-ancestor (env frame-ptr
)
330 (declare (fixnum frame-ptr
) #.
+handler-optimize
+)
331 (do ((i (frame-ptr-depth frame-ptr
) (1- i
)))
334 (setq env
(env-parent env
))))
336 ;;; Hide an implementation detail of a partially bound environment,
337 ;;; that it is a vector and a count.
338 ;;; END indicates the length of the effective portion of the value vector.
339 ;;; LENGTH of a simple-vector is in the same location as CAR of a cons,
340 ;;; so regardless of whether ENV-SYMBOLS currently hold a cons or a vector
341 ;;; we can always use CAR to read the length.
342 (defmacro with-environment-vars
((symbols end
) env
&body body
)
343 `(awhen (env-symbols ,env
)
344 (let ((,symbols
(truly-the simple-vector
(if (listp it
) (cdr it
) it
)))
345 (,end
(locally (declare (optimize (safety 0))) (car it
))))
346 (declare (index-or-minus-1 ,end
))
348 (eval-when (:compile-toplevel
)
349 ;; Assert that the claims made in the above comment remain true.
350 (assert (= (- (* sb-vm
:n-word-bytes sb-vm
:cons-car-slot
)
351 sb-vm
:list-pointer-lowtag
)
352 (- (* sb-vm
:n-word-bytes sb-vm
:vector-length-slot
)
353 sb-vm
:other-pointer-lowtag
))))
355 (defmacro %cell-ref
(env frame-ptr
)
356 `(svref (env-payload (env-ancestor ,env
,frame-ptr
))
357 (frame-ptr-cell-index ,frame-ptr
)))
359 ;;; Return the symbol that FRAME-PTR represents in ENV (or an ancestor of it).
360 ;;; The symbol vector is a vector of (CONS SYMBOL (OR FUNCTION CTYPE)).
361 (defun frame-symbol (env frame-ptr
)
362 (let ((symbols (env-symbols (env-ancestor env frame-ptr
))))
363 (car (svref (if (listp symbols
) (cdr symbols
) symbols
)
364 (frame-ptr-cell-index frame-ptr
)))))
366 (defun %enforce-types
(typechecks env
)
368 (n (length typechecks
)))
370 (declare (index i n
))
371 (let ((ref (svref typechecks i
)))
374 ((eq i n
) (return-from %enforce-types
))
375 (let* ((frame-ptr (svref typechecks i
))
376 (val (%cell-ref env frame-ptr
))
377 (type (svref typechecks
(logior i
1))))
378 (unless (itypep val type
)
379 (typecheck-fail/ref
(frame-symbol env frame-ptr
) val type
)))))
381 (let ((val (symbol-value ref
))
382 (type (svref typechecks
(logior i
1))))
383 (unless (itypep val type
)
384 (typecheck-fail/ref ref val type
)))))))
386 (defun must-freeze-p (env)
388 (or (env-mutable-p env
)
389 (must-freeze-p (env-parent env
)))))
391 ;; This is an important operation for creation of interpreted lexical closures.
392 ;; It should execute as fast as possible.
393 (defun freeze-env (env)
394 (declare (instance env
)) ; just rule out NIL
395 (labels ((recurse (env)
396 (let* ((parent-copy (awhen (env-parent (truly-the basic-env env
))
398 ;; The reason we're grabbing ENV-SYMBOLS here is
399 ;; to ensure that the slot is accessed exactly once.
400 ;; (CONSP symbols) is the same as (mutable-p env).
401 ;; See comment in 'macros' about figuring out
402 ;; whether this is safe. Maybe I'm just paranoid?
403 ;; Otoh, maybe I'm not, since the concurrency tests
404 ;; are randomly hitting lose("Feh.") in gencgc.
405 (symbols (env-symbols env
))
406 (mutable (consp symbols
)))
407 ;; PARENT-COPY might not actually be a copy
408 (if (or mutable
(neq parent-copy
(env-parent env
)))
409 (let ((new (copy-structure env
)))
410 (setf (env-parent new
) parent-copy
)
412 (setf (env-symbols new
)
413 (cons (car (truly-the list symbols
))
419 ;;; SBCL currently takes declarations affecting policy as if they were "hoisted"
420 ;;; outside the form containing them, so that they apply to initialization forms
421 ;;; as well as body forms. This is in direct contradiction to the X3J13 decision.
422 ;;; This flag says to be conveniently bug-for-bug compatible with the compiler.
423 ;;; See https://bugs.launchpad.net/sbcl/+bug/309125
424 ;;; FIXME: is this used anywhere?
425 (declaim (boolean *hoist-optimize-declarations
*))
426 (defvar *hoist-optimize-declarations
* t
)
428 ;;; Return a new policy based on the existing policy, augmented by DECLS.
429 ;;; FIXME: this looks like it duplicates code that exists elsewhere.
430 ;;; Maybe SB-C::PROCESS-OPTIMIZE-DECL ?
431 (defun new-policy (env decls
)
432 (let ((policy (env-policy env
)) (copy-on-write t
))
433 (do-decl-spec (decl-spec decls policy
)
434 (when (eq (car decl-spec
) 'optimize
)
435 (dolist (qual+val
(cdr decl-spec
))
436 (multiple-value-bind (qual val
)
439 (values (car qual
+val
) (cadr qual
+val
)))
440 (let ((index (sb-c::policy-quality-name-p qual
)))
442 (typep val
'sb-c
::policy-quality
)
443 ;; Read the unadjusted value from the origin policy.
444 ;; If we're not changing that, don't do anything.
445 (/= val
(sb-c::%%policy-quality policy index
)))
447 (setq policy
(copy-structure policy
)
449 (sb-c::alter-policy policy index val
)))))))))
451 ;;;; Function stuff that's not in 'function.lisp'
452 ;;;; because cross-compilation does not need it.
454 ;; If a function's name slot does not hold a proper name,
455 ;; then its name is itself.
456 (defun name-for-fun (fun)
457 (let ((name (fun-name fun
)))
458 (if (and (not (eql name
0)) (legal-fun-name-p name
) (fboundp name
))
462 (defmethod print-object ((obj interpreted-function
) stream
)
463 ;; Do not try to directly print 'NAME-FOR-FUN', which returns OBJ
464 ;; itself if it has no proper name.
465 (let ((name (fun-name obj
)))
467 ;; To avoid an extra space between type and identity, the body must
468 ;; be empty, so we need two cases, because emptiness is compile-time
469 ;; determined, not based on whether the body actually printed anything.
470 (print-unreadable-object (obj stream
:type t
:identity t
))
471 ;; show name whenever NAME it is not 0, even if not OBJ's proper name.
472 (print-unreadable-object (obj stream
:type t
)
473 (prin1 name stream
)))))
475 ;;; Return approximately a type specifier for LAMBDA-LIST.
476 ;;; e.g. after doing (DEFUN FOO (A B) ...), you want (FUNCTION (T T) *)
477 ;;; This is mainly to get accurate information from DESCRIBE
478 ;;; when properly hooked in.
479 ;;; FIXME: this returns T for all &OPTIONAL and &KEY args.
480 (defun approximate-proto-fn-type (lambda-list bound-symbols
)
481 (declare (notinline member cons
))
482 (labels ((recurse (list var-index
&aux
(elt (car list
)))
483 (unless (or (eq elt
'&aux
) (null list
))
484 (let ((ll-keyword-p (member elt lambda-list-keywords
))
486 (cons (cond (ll-keyword-p elt
)
489 (acond ((cdr (svref bound-symbols var-index
))
497 (1+ var-index
))))))))
498 (keys (list &aux
(elt (car list
)))
499 (unless (or (eq elt
'&aux
) (null list
))
500 (cons (cond ((member elt lambda-list-keywords
) elt
)
501 (t `(,(parse-key-arg-spec elt
) t
)))
502 (keys (cdr list
))))))
503 `(function ,(recurse lambda-list
0) *)))
505 (declaim (type boolean
*hook-all-functions
*))
506 (defvar *hook-all-functions-p
* nil
)
508 (declaim (ftype function interpreter-trampoline interpreter-hooked-trampoline
))
510 (defun make-function (proto-fn env
)
511 (let ((function (%make-interpreted-function proto-fn env nil nil
)))
512 ;; Hooking all functions, makes them somewhat slower,
513 ;; but allows for really nifty introspection,
514 ;; such as discovering what calls are made by read-time evals.
515 (setf (funcallable-instance-fun function
)
516 (if *hook-all-functions-p
*
518 (apply #'interpreter-hooked-trampoline function args
))
520 (apply #'interpreter-trampoline function args
))))
523 ;; When globaldb info changes, this counter can be bumped to force interpreted
524 ;; functions to discard memoized data on their next application. For example
525 ;; if a function gets called before a global SPECIAL proclamation has been made
526 ;; regarding one of its lambda variables, this can be corrected by touching the
527 ;; globaldb cookie. On-stack functions will not see the change though.
528 ;; What remains is to hook the setting of some of the globaldb info-types.
530 (declaim (fixnum *globaldb-cookie
*))
531 (defglobal *globaldb-cookie
* most-positive-fixnum
)
533 ;; instrumentation of macro cache flushes, mostly for testing
534 (declaim (fixnum *invalidation-count
*))
535 (defglobal *invalidation-count
* 0)
537 ;; Return two values: FRAME and COOKIE, recomputing if cookie doesn't match
538 ;; globaldb, otherwise return the previously computed information.
539 (declaim (inline proto-fn-frame
))
540 (defun proto-fn-frame (proto-fn env
)
541 (if (eq (proto-fn-cookie proto-fn
) *globaldb-cookie
*)
542 (values (proto-fn-%frame proto-fn
) (proto-fn-cookie proto-fn
))
543 (digest-lambda env proto-fn
)))
545 (defun %fun-type
(fun)
546 (let ((proto-fn (interpreted-function-proto-fn fun
)))
547 (or (proto-fn-type proto-fn
)
548 (setf (proto-fn-type proto-fn
)
549 (approximate-proto-fn-type
550 (proto-fn-lambda-list proto-fn
)
552 (proto-fn-frame (interpreted-function-proto-fn fun
)
553 (interpreted-function-env fun
))))))))
555 ;; This is just a rename of DESTRUCTURING-BIND
556 ;; Should it do anything magic?
557 (defmacro with-subforms
(lambda-list arg-form
&body body
)
558 `(destructuring-bind ,lambda-list
,arg-form
,@body
))
560 ; (let ((arg-list-name (gensym "ARG-LIST-")))
561 ; (multiple-value-bind (body local-decls)
562 ; (parse-defmacro lambda-list arg-list-name body nil
563 ; 'program-destructuring-bind
565 ; :doc-string-allowed nil
567 ; :error-fun 'sb-eval::arg-count-program-error)
568 ; `(let ((,arg-list-name ,arg-list))
572 (declaim (ftype (sfunction (integer t
) function
) local-fdefinition
)
573 (maybe-inline local-fdefinition
))
575 ;; If DECL is a declaration that affects variables, return the kind of
576 ;; variable-affecting declaration it is.
577 (defun applies-to-variables-p (decl)
578 (let ((id (car decl
)))
579 (or (find id
'(ignorable ignore type special
580 dynamic-extent truly-dynamic-extent
))
581 (if (or (listp id
) ; it must be a type-specifier (including NIL)
582 (info :type
:kind id
))
585 (defglobal *unary-functions
* nil
)
586 (defglobal *binary-functions
* nil
)
588 (defun collect-progv-symbols (symbols n mask
)
590 when
(logbitp i mask
)
591 collect
(car (svref symbols i
))))
593 ;;; DECLS-LIST is a list of lists of declarations. The original structure
594 ;;; is preserved, so this necessitates a triply-nested loop.
595 ;;; e.g. (LET () (DECLARE (SPECIAL X) (SPECIAL Y)) (DECLARE (SPECIAL Z W)))
596 ;;; has decls-list (((SPECIAL X) (SPECIAL Y)) ((SPECIAL Z W)))
598 (defun declared-specials (decls-list)
600 (declare (fixnum count
))
601 (collect ((specials))
602 (do-decl-spec (decl-spec decls-list
)
603 (when (eql (car decl-spec
) 'special
)
604 (dolist (var (cdr decl-spec
))
605 (unless (memq var
(specials))
608 (values (specials) count
))))
610 ;;; See if all SYMBOLS can be declare special.
611 ;;; This applies to both free and bound variables.
612 (defun assert-declarable-as-special (env symbols
)
613 (declare (ignore env
))
614 (dolist (name symbols
)
615 (unless (symbolp name
)
616 (ip-error "~A is not a symbol" name
))
617 ;; Same logic as SB-C::PROCESS-SPECIAL-DECL
618 (let ((kind (info :variable
:kind name
)))
619 (unless (member kind
'(:special
:unknown
))
620 (error "Can't declare ~(~A~) variable locally special: ~S" kind name
)))
621 (program-assert-symbol-home-package-unlocked
622 :eval name
"declaring ~A special")))
624 ;; Given that all SPECIAL declarations in DECLS pertain to free specials,
625 ;; return a vector to supply as the SYMBOLS for an environment constructor.
626 ;; This should not be used for LET/LET*/LAMBDA binding handlers,
627 ;; which have their own way of creating the free specials along with
629 (defun free-specials (env decls
)
630 (multiple-value-bind (symbols n
) (declared-specials decls
)
632 (with-package-lock-context (env)
633 (assert-declarable-as-special env symbols
))
634 (let ((a (make-array n
)))
635 ;; If any special declaration exposes a bound special
636 ;; from an enclosing scope, the original binding cell
637 ;; is made visible in this binding scope.
638 ;; This causes any type declaration to be carried forward.
640 (setf (aref a i
) (find-special-binding env
(pop symbols
))))))))
642 (defmacro specially-bind-p
(symbol lexically-special-p
)
643 ;; Don't signal errors here: allow the interpreter to attempt to bind
644 ;; as special if so indicated, and let the native PROGV complain.
645 `(or (memq (info :variable
:kind
,symbol
) '(:constant
:global
:special
))
646 ,lexically-special-p
))
648 (defun mark-bound-specials (env declared-specials symbols n-bound
)
649 (declare (simple-vector symbols
))
650 (with-package-lock-context (env)
651 (assert-declarable-as-special env declared-specials
))
653 ;; Every time I look at this and think that it makes more sense to run the
654 ;; outer loop over declared and the inner loop over bound, so that there
655 ;; are fewer iterations, I have to remember why that is wrong -
656 ;; it would miss global proclamations.
657 (dotimes (i n-bound special-b
)
658 (let ((sym (the symbol
(car (svref symbols i
)))))
659 ;; Given: (let* ((x (foo)) (x (fn x))) (declare (special x)) ...
660 ;; only the second X is special. This mimics the compiler exactly.
661 (when (specially-bind-p
662 sym
(and (memq sym declared-specials
)
663 (not (find sym symbols
:start
(1+ i
) :end n-bound
665 (setf (logbitp i special-b
) t
))))))
667 (defun make-proto-fn (lambda-expression &optional
(silent t
))
668 (multiple-value-bind (name lambda-list body
)
669 (if (eq (car lambda-expression
) 'named-lambda
)
670 (with-subforms (name lambda-list . body
) (cdr lambda-expression
)
671 (values name lambda-list body
))
672 (with-subforms (lambda-list . body
) (cdr lambda-expression
)
673 (values 0 lambda-list body
)))
674 ;; Choke now if the list can't be parsed.
675 ;; If lexical environment is NIL, :silent will be passed as NIL,
676 ;; and we can warn about "suspcious variables" and such.
677 (parse-lambda-list lambda-list
:silent silent
)
678 (multiple-value-bind (forms decls docstring
) (parse-body body t t
)
679 (%make-proto-fn name lambda-list decls forms docstring
680 (do-decl-spec (spec decls lambda-list
)
681 (when (eq (car spec
) 'sb-c
::lambda-list
)
682 (return (cadr spec
))))))))
684 ;; Find function named by FNAME in ENV or an ancestor, returning three values:
685 ;; * KIND = {:MACRO,:FUNCTION}
686 ;; * DEF = the definition
688 (defun find-lexical-fun (env fname
)
689 (flet ((fname (x) (second (fun-name x
))))
690 (do ((test (if (atom fname
) #'eq
#'equal
))
691 (env env
(env-parent env
))
692 (level 0 (1+ level
)))
693 ((null env
) (values nil nil nil
))
694 (declare (type (unsigned-byte #.
+frame-depth-bits
+) level
))
695 (when (and (env-payload env
) ; quick check before using type predicates
696 (or (function-env-p env
) (macro-env-p env
)))
697 (multiple-value-bind (definition index
)
698 (%find-position fname
(the simple-vector
(env-payload env
))
699 nil
0 nil
#'fname test
)
701 (return (values (if (macro-env-p env
) :macro
:function
)
702 definition
(make-frame-ptr index level
)))))))))
704 ;;; Retrieve the function/macro binding of the symbol NAME in
705 ;;; environment ENV, with the global definition as a fallback.
706 ;;; The second return value is T if NAME names a macro.
708 (defun get-function (fname env
)
709 (multiple-value-bind (kind definition
) (find-lexical-fun env fname
)
710 (acond (definition (values definition
(eq kind
:macro
)))
711 ((and (symbolp fname
) (macro-function fname
)) (values it t
))
712 ;; FDEFINITION strips encapsulations, %COERCE-NAME-TO-FUN doesn't.
713 ;; There's a test in 'eval.impure.lisp' asserting that encapsulations
714 ;; aren't stripped, but frankly all bets are off when tracing.
715 (t (values (%coerce-name-to-fun fname
) nil
)))))
717 ;; Find SYM in ENV or an ancestor and return four values:
718 ;; * CELL = a cons of the symbol and its CTYPE
719 ;; * KIND = {:NORMAL,:MACRO,:SPECIAL}
721 ;; * VALUE = the value, if KIND is :NORMAL, else the macroexpansion
723 ;; Bindings are in parallel symbol/value vectors left-to-right as appearing
724 ;; in source. Scanning is right-to-left so that later LET* bindings shadow
725 ;; earlier ones of the same name. The end pointer in a LET* environment
726 ;; constrains the usable length of the symbol vector.
727 ;; Unbound ("free") special variables have no entry in the value vector.
729 (defun find-lexical-var (env sym
)
730 (do ((env env
(env-parent env
))
731 (level 0 (1+ level
)))
732 ((null env
) (values nil nil nil
))
733 (declare (type (unsigned-byte #.
+frame-depth-bits
+) level
))
734 (with-environment-vars (symbols index
) env
; skipped if no symbols
735 ;; Emulate find/position with :FROM-END T here, but faster.
737 (when (minusp (decf index
)) (return))
738 (let ((cell (svref symbols index
)))
739 (when (eq (binding-symbol cell
) sym
)
740 (multiple-value-bind (kind value
)
741 (cond ((or (var-env-p env
) (lambda-env-p env
))
742 (let ((values (the simple-vector
(env-payload env
))))
743 (if (or (>= index
(length values
))
745 (frame-special-b (env-contour env
))))
747 (values :normal
(svref values index
)))))
748 ((symbol-macro-env-p env
)
749 (let ((values (the simple-vector
(env-payload env
))))
750 (if (>= index
(length values
))
752 (values :macro
(svref values index
)))))
753 (t ; function-env, macro-env, basic-env (locally).
754 :special
)) ; no symbol is bound
755 (return-from find-lexical-var
756 (values cell kind
(make-frame-ptr index level
) value
)))))))))
758 ;;; Search ENV for BINDING and return a frame-pointer if the variable
759 ;;; is a lexical var, or :SPECIAL or :MACRO if it is one of those.
760 ;;; Lexically visible special bindings return :SPECIAL.
761 ;;; This is similar to FIND-LEXICAL-VAR in its operation,
762 ;;; but simpler, as bindings are unique objects.
763 (defun find-binding (env binding
)
764 (do ((env env
(env-parent env
))
765 (level 0 (1+ level
)))
767 (declare (type (unsigned-byte #.
+frame-depth-bits
+) level
))
768 (with-environment-vars (bindings index
) env
; skipped if no symbols
769 (declare (ignore index
))
770 (let ((payload (env-payload env
))
771 (index (position binding bindings
)))
774 (cond ((or (var-env-p env
) (lambda-env-p env
))
775 (if (or (>= index
(length (the simple-vector payload
)))
776 (logbitp index
(frame-special-b (env-contour env
))))
778 (make-frame-ptr index level
)))
779 ((symbol-macro-env-p env
)
780 (if (>= index
(length (the simple-vector payload
)))
783 (t ; function-env, macro-env, basic-env (locally).
784 :special
)))))))) ; no symbol is bound
786 ;;; Similar to the above, but only return a lexically visible special binding.
787 ;;; This is required to locate the intended binding in cases such as this:
789 (let ((a 3)) ; special A[1]
790 (declare (special a
))
791 (symbol-macrolet ((a x
)) ; macro A[2]
792 (let ((a (foo))) ; lexical A[3]
793 (macrolet ((foo () ...
))
794 (declare (real a
) (special a
)) ; declares the type of A[1]
795 A
)))) ; references A[1]
797 (defun find-special-binding (env sym
)
798 (do ((env env
(env-parent env
)))
799 ((null env
) sym
) ; Return just SYM if no binding found.
800 ;; Only a LET-like frames can create special bindings.
801 (when (or (var-env-p env
) (lambda-env-p env
))
802 (with-environment-vars (symbols index
) env
; skipped if no symbols
803 (let ((index (position sym symbols
804 :end
(min index
(length (env-payload env
)))
805 :key
#'car
:test
#'eq
:from-end t
)))
806 (when (and index
(logbitp index
(frame-special-b (env-contour env
))))
807 (return (svref symbols index
))))))))
809 ;;; BINDING is either a cell or a symbol (if a free special).
810 (defun find-type-restriction (env binding
)
811 (do ((env env
(env-parent env
)))
814 (or (cdr binding
) *universal-type
*)
816 (unless (env-mutable-p env
)
817 (awhen (assq binding
(type-restrictions (env-contour env
)))
818 (return (cdr it
))))))
820 ;;; Update DECL-SCOPE with type restrictions based on its declarations.
821 ;;; Restrictions are separated into those which apply to bindings made by
822 ;;; this scope - each being pertinent as soon as the variable to which it
823 ;;; applies is bound - and those which apply to the body forms.
824 ;;; Bound lexical and special variables in the new scope have the CTYPE
825 ;;; as stored in the CDR of the binding cell altered to reflect the
826 ;;; restriction, other restrictions go into the TYPE-RESTRICTIONS slot.
827 ;;; A special falls into the latter category if the binding is lexically
828 ;;; visible but did not occur in exactly this scope. This avoids stomping
829 ;;; on the type that was stored in the scope which made the binding.
830 (defun process-typedecls (decl-scope env n-var-bindings symbols
831 &aux new-restrictions
)
832 ;; First compute the effective set of type restrictions.
833 (do-decl-spec (decl (declarations decl-scope
))
834 (when (eq (applies-to-variables-p decl
) 'type
)
835 (multiple-value-bind (type-spec names
)
836 (if (eq (car decl
) 'type
)
837 (values (cadr decl
) (cddr decl
))
838 (values (car decl
) (cdr decl
)))
839 (let ((ctype (specifier-type type-spec
)))
840 (unless (eq ctype
*universal-type
*)
841 (dolist (symbol names
)
842 (multiple-value-bind (binding index
)
843 (%find-position symbol symbols t
0 nil
#'binding-symbol
#'eq
)
844 (if (and index
(< index n-var-bindings
))
845 ;; Any kind of binding created in directly this frame.
846 ;; Type restrictions aren't pervasive downward,
847 ;; so this case doesn't intersect the new type with a
848 ;; prevailing restriction. Global proclamations are
849 ;; pervasive, but violations are caught by the runtime.
851 (acond ((cdr binding
) (type-intersection it ctype
))
853 ;; Three possibilities now:
854 ;; 1. INDEX was past the number of bindings in this scope.
855 ;; This is either a locally declared free special,
856 ;; or a special declaration that exposes a special
857 ;; var bound in some containing scope, possibly with
858 ;; intervening non-special bindings of the same name.
859 ;; 2. A binding from an earlier scope not covered by case 1.
860 ;; 3. Something global: an assumed or proclaimed special,
861 ;; or a global symbol-macro.
862 (let* ((thing (or binding
; case 1
863 (find-lexical-var env symbol
) ; case 2
865 (restriction (assq thing new-restrictions
)))
868 (type-intersection (cdr restriction
) ctype
))
869 (let* ((old-type (find-type-restriction env thing
))
870 (new-type (type-intersection old-type ctype
)))
871 (unless (type= old-type new-type
)
872 (push (cons thing new-type
)
873 new-restrictions
)))))))))))))
874 (setf (type-restrictions decl-scope
) new-restrictions
)
875 ;; Done computing effective restrictions.
876 ;; If the enclosing policy - not the new policy - demands typechecks,
877 ;; then insert assertions for all variables bound by this scope.
878 (when (and (policy env
(>= safety
1))
879 (find-if #'cdr symbols
:end n-var-bindings
))
880 (let ((checks (make-array n-var-bindings
)))
881 (dotimes (i n-var-bindings
(setf (binding-typechecks decl-scope
) checks
))
882 (awhen (cdr (svref symbols i
))
883 (setf (svref checks i
) (type-checker it
))))))
884 ;; If a nested scope re-declares a variable to be of a more constrained
885 ;; type "for efficiency" it does not really help the interpreter any,
886 ;; so don't do those checks unless SAFETY exceeds 2.
887 ;; This is a somewhat arbitrary but reasonable stance to take.
888 (when (and (policy env
(>= safety
2)) new-restrictions
)
889 (collect ((lexical-var-checks) (special-var-checks))
890 (dolist (check new-restrictions
)
891 (let ((binding (car check
))
892 (checkfun (type-checker (cdr check
))))
893 (if (consp binding
) ; some kind of binding, not sure what
894 (let ((frame-ptr (find-binding env binding
)))
897 (:special
(special-var-checks (car binding
) checkfun
))
898 (t (lexical-var-checks frame-ptr checkfun
))))
899 (special-var-checks binding checkfun
))))
900 ;; Restrictions could pertain to symbol-macros only,
901 ;; which are not checked on entry to the scope.
902 (when (or (lexical-var-checks) (special-var-checks))
903 (setf (extra-typechecks decl-scope
)
904 (coerce (nconc (special-var-checks) (lexical-var-checks))
908 ;;; Return the thing that should be asserted about VARIABLE's type.
909 ;;; If there is nothing to check - no declared type, or the current policy
910 ;;; does not require type-checking, then return NIL.
911 ;;; These are the distinct things that might want different controls:
912 ;;; - initial bindings
913 ;;; - entrance to new scope with stronger constraint
917 ;;; Only the writes and reads are controlled here,
918 ;;; the others are kind of spread out. It might be nice to consolidate
919 ;;; the policy-related decisions somewhere.
921 (defun var-type-assertion (env symbol binding op
)
922 ;; ** these criteria are subject to change. Not sure they're the best.
924 (:write
(policy env
(>= safety
1)))
925 (:read
(policy env
(and (= safety
3) (= speed
0)))))
926 (let ((type (find-type-restriction env
(or binding symbol
))))
927 (if (eq type
*universal-type
*) nil
(type-checker type
)))))
929 ;; Convert compiler env to interpreter env
930 (defun env-from-lexenv (lexenv)
931 (when (sb-c::null-lexenv-p lexenv
)
932 (return-from env-from-lexenv nil
))
933 ;; a lexical environment which includes locally [not]inline
934 ;; declarations about global functions is ok
935 (flet ((harmless-defined-fun-p (thing)
936 (and (typep thing
'sb-c
::defined-fun
)
937 (eq (sb-c::defined-fun-kind thing
) :global-function
)))
939 (and (consp thing
) (eq (car thing
) 'sb-sys
:macro
))))
940 (let ((native-funs (sb-c::lexenv-funs lexenv
))
941 (native-vars (sb-c::lexenv-vars lexenv
)))
942 (when (or (sb-c::lexenv-blocks lexenv
)
943 (sb-c::lexenv-tags lexenv
)
944 (sb-c::lexenv-lambda lexenv
)
945 (sb-c::lexenv-cleanup lexenv
)
946 (sb-c::lexenv-type-restrictions lexenv
)
947 (find-if-not (lambda (x) (or (macro-p x
)
948 (harmless-defined-fun-p x
)))
949 native-funs
:key
#'cdr
)
950 (find-if-not #'macro-p native-vars
:key
#'cdr
))
951 (error 'compiler-environment-too-complex-error
953 "~@<Lexical environment is too complex to evaluate in: ~S~:@>"
954 :format-arguments
(list lexenv
)))
956 ;; Macros in an interpreter environment must look like interpreted
957 ;; functions due to use of FUN-NAME to extract their name as a key
958 ;; rather than also needing an alist mapping names to objects.
959 ;; For each compiled expander, wrap it in a trivial interpreted fun.
964 (let ((expander (cddr cell
)))
965 (if (interpreted-function-p expander
)
968 (%make-proto-fn
`(macrolet ,(car cell
)) '(form env
)
970 `((funcall ,expander form env
)) nil
)
971 nil
)))) ; environment for the interpreted fun
972 (remove-if-not #'macro-p native-funs
:key
#'cdr
))
973 nil
; no free specials vars
974 ;; FIXME: type-restrictions, package-locks, handled-conditions.
975 (make-decl-scope nil
(sb-c::lexenv-policy lexenv
)))))
977 (make-symbol-macro-env macro-env
978 (map 'vector
#'cddr native-vars
)
979 (map 'vector
#'car native-vars
)
981 nil
(sb-c::lexenv-policy lexenv
)))
984 ;;; Enclose PROTO-FN in the environment ENV.
985 ;;; SEXPR is provided only because this is a HANDLER.
986 (defun enclose (proto-fn env sexpr
)
987 (declare (ignore sexpr
))
988 (make-function proto-fn env
))
990 ;;; If ENV is a LET* environment that is not yet complete, then make a copy.
991 ;;; Recurse up and see if copy needs to be done on any parent ENV - so not exactly
992 ;;; a shallow copy. It boggles the mind to think of reasons a parent ENV would
993 ;;; be getting sequentially bound and a descendant ENV is captured, but of course
994 ;;; that must be dealt with properly.
995 ;;; It seems unlikely that there would be much benefit from memoizing a
996 ;;; frozen ENV - multiple closures over the same mutable ENV could get the
997 ;;; same immutable copy, but where would I stash it?
998 (defun enclose-freeze (proto-fn env sexpr
)
999 (declare (ignore sexpr
))
1000 (make-function proto-fn
(freeze-env env
)))
1002 ;;; Try to compile an interpreted function. If the environment
1003 ;;; contains local functions we'll punt on compiling it.
1004 ;;; Lexical vars are OK but not specials of either the bound or free variety.
1005 ;;; LEXENV-FROM-ENV fakes up a GLOBAL-VAR which is fine for
1006 ;;; limited kinds of analysis but not for really compiling (at least I
1007 ;;; think it isn't), so must be avoided. This conservatively prevents
1008 ;;; compilation when it shouldn't, but is more liberal than before.
1009 ;;; An example of an environment in which compilation should occur but won't:
1010 ;;; (locally (declare (special x)) (symbol-macrolet ((x 3)) (defun f ...
1012 ;;; Bound specials that were proclaimed special, not locally declared,
1013 ;;; should be allowed because we don't have to inject any SPECIAL declaration
1014 ;;; or otherwise manipulate the lexenv to have the compiler know about
1015 ;;; the specialness.
1016 ;;; Free specials could be made to work fairly easily by inserting
1017 ;;; a (declare (special ...)) into the lambda, provided that there are no
1018 ;;; &optional/&key/&aux arguments. If there any hairy arguments, we don't know
1019 ;;; if some argument's defaulting form would have needed to know about the
1020 ;;; specialness of a symbol.
1022 ;;; Compiled code can access lexical vars in interpreted closures.
1023 ;;; It is achieved by changing each lexical var into a symbol macro
1024 ;;; that accesses its storage location.
1025 ;;; In practice it's likely that an interpreted closure would be "too complex"
1026 ;;; for other reasons, usually due to surrounding BLOCK. It would be somewhat
1027 ;;; nifty to walk the code and find that the block is never used.
1028 (defun prepare-for-compile (function &aux nullify-lexenv
)
1029 (if (named-let too-complex-p
((env (interpreted-function-env function
)))
1031 (return-from too-complex-p nil
))
1032 (when (or (typep env
'(or function-env block-env tagbody-env
))
1033 (and (typep env
'lambda-env
)
1034 ;; a block makes it too complex
1035 (neq (lambda-frame-block-name (env-contour env
)) 0)))
1036 (return-from too-complex-p t
))
1038 (with-environment-vars (symbols end
) env
1039 (when (or (and (= end
(length symbols
)) ; all symbols are accessible
1040 ;; More symbols then values means free specials.
1041 (> (length symbols
) (length (env-payload env
))))
1042 (let ((frame (env-contour env
)))
1043 (and (typep env
'(or var-env lambda-env
))
1044 ;; any bound specials must be proclaimed special
1045 ;; so that we can just drop the binding
1046 (ldb-test (byte end
0) (frame-special-b frame
)))))
1047 (return-from too-complex-p t
)))
1048 ;; Decls inserted into the lambda would give them a scope that is
1049 ;; technically "too small". This is fundamentally a problem in the
1050 ;; NO-HOISTING vote of X3J13. Using syntactic constructs there is
1051 ;; no way to guarantee a safe entry to functions if the prevailing
1052 ;; policy was unsafe:
1053 ;; (declaim (optimize (safety 0)))
1054 ;; (compile nil '(lambda (arg) (declare (optimize safety)) ...))
1055 ;; [They could have voted to hoist OPTIMIZE if nothing else].
1056 ;; But if the only decls in ENV pertain to a POLICY, then simply
1057 ;; propagating that policy into the resulting LEXENV is exactly right.
1058 (do-decl-spec (spec (env-declarations env
))
1059 (unless (member (car spec
) '(optimize))
1060 (return-from too-complex-p t
)))
1061 (too-complex-p (env-parent env
))) ; recurse
1062 ;; KLUDGE: if for no other reason than to make some assertions pass,
1063 ;; we'll recognize the case where the function body does not actually
1064 ;; need its lexical environment.
1065 (let ((forms (proto-fn-forms (interpreted-function-proto-fn function
))))
1066 ;; Happily our CONSTANTP is smart enough to look into a BLOCK.
1067 (if (and (singleton-p forms
) (constantp (car forms
)))
1068 (setq nullify-lexenv t
)
1069 (error 'interpreter-environment-too-complex-error
1071 "~@<Lexical environment of ~S is too complex to compile.~:@>"
1072 :format-arguments
(list function
)))))
1073 (values (fun-lambda-expression function
)
1074 (acond ((and (not nullify-lexenv
) (interpreted-function-env function
))
1075 (lexenv-from-env it
'compile
))
1077 (make-null-lexenv)))))
1079 ;;; Convert ENV from an interpreter environment to a compiler environment,
1080 ;;; i.e. one which is acceptable to various environment inquiry functions
1081 ;;; that do not understand interpreter environments.
1082 ;;; (Things like MACROEXPAND do understand interpreter environments)
1083 ;;; If REASON is COMPILE, then symbols which refer to the interpreter's
1084 ;;; lexical variables are changed to symbol-macros which access the
1085 ;;; interpreter variables.
1087 ;;; NB: This is not the only way to attack the problem of having the
1088 ;;; compiler deal with subtypes of ABSTRACT-LEXENV. Another way would
1089 ;;; make all access functions just do the right thing to begin with,
1090 ;;; though it might slow down the compiler a little bit, since it really
1091 ;;; likes to manipulate LEXENVs a lot.
1092 ;;; Also the parts for sb-cltl2 are fairly odious.
1094 (defun lexenv-from-env (env &optional reason
)
1095 (%lexenv-from-env
(make-hash-table :test
'eq
) env reason
))
1097 (defun %lexenv-from-env
(var-map env
&optional reason
)
1098 (let ((lexenv (acond ((env-parent env
) (%lexenv-from-env var-map it reason
))
1099 ;; The null-lexenv has to be copied into a new
1100 ;; lexenv to get a snapshot of *POLICY*.
1101 (t (sb-c::make-lexenv
:default
(make-null-lexenv)))))
1102 (payload (env-payload env
)))
1103 (flet ((specialize (binding) ; = make a global var, not make less general
1104 (let ((sym (binding-symbol binding
)))
1105 (cons sym
(make-global-var :%source-name sym
1107 :where-from
:declared
))))
1108 (macroize (name thing
) (list* name
'sb-sys
:macro thing
))
1109 (fname (f) (second (fun-name f
))))
1110 (multiple-value-bind (vars funs
)
1112 ((or var-env lambda-env
)
1113 (with-environment-vars (symbols end
) env
1114 (loop for i fixnum from
(1- end
) downto
0
1115 for binding
= (svref symbols i
)
1116 for sym
= (binding-symbol binding
)
1118 (cond ((or (>= i
(length payload
))
1119 (logbitp i
(frame-special-b (env-contour env
))))
1120 (specialize binding
))
1121 ((eq reason
'compile
)
1122 ;; access interpreter's lexical vars
1123 (macroize sym
`(svref ,payload
,i
)))
1125 (let ((leaf (make-lambda-var
1127 :type
(or (cdr binding
) *universal-type
*))))
1128 (setf (gethash binding var-map
) leaf
)
1129 (cons sym leaf
)))))))
1132 (lambda (cell expansion
)
1133 (list* (car cell
) 'sb-sys
:macro
1134 (acond ((cdr cell
) `(the ,it
,expansion
))
1136 (env-symbols env
) payload
)
1137 ;; symbols without values are free specials
1138 (map 'list
#'specialize
1139 (subseq (env-symbols env
) (length payload
)))))
1140 ((or function-env macro-env
)
1141 ;; all symbols are free specials
1142 (values (map 'list
#'specialize
(env-symbols env
))
1143 (map 'list
(if (macro-env-p env
)
1144 (lambda (f) (macroize (fname f
) f
))
1145 (lambda (f &aux
(name (fname f
)))
1147 (sb-c::make-functional
1149 ;; LEXENV is given only because of
1150 ;; type-checking. Value is bogus.
1151 :lexenv
(sb-kernel:make-null-lexenv
)))))
1153 (basic-env ; as in (LOCALLY (DECLARE ..))
1154 (values (map 'list
#'specialize
(env-symbols env
)) nil
)))
1155 ;; FIXME: This is a rather inefficient, and particularly ugly.
1156 ;; Since all the data that are needed by SB-CLTL2 are already
1157 ;; present in the interpreter ENV, it should just look there directly.
1158 ;; The saving grace is that most decls don't have a decl handler.
1159 (do-decl-spec (spec (env-declarations env
))
1162 ;; In (LET* ((X (F)) (X (G X))) (declare (ignore x)) ...)
1163 ;; it's the second X that is ignored. Does this code reflect that?
1164 (dolist (sym (cdr spec
))
1165 (let ((var (cdr (assoc sym vars
))))
1166 (when (sb-c::lambda-var-p var
)
1167 (setf (sb-c::lambda-var-flags var
) 1)))))
1169 ;; This is just enough to get sb-cltl2 tests to pass.
1170 (let ((inlinep (case (car spec
)
1172 (notinline :notinline
))))
1173 (dolist (fname (cdr spec
))
1174 (let ((fun (cdr (assoc fname funs
:test
'equal
))))
1177 (setf (sb-c::functional-inlinep fun
) inlinep
))
1180 (sb-c::make-defined-fun
1182 :type
(sb-int:proclaimed-ftype fname
))))
1183 (setf (sb-c::defined-fun-inlinep defined-fun
) inlinep
)
1184 (push (cons fname defined-fun
) funs
))))))))
1186 ;; As usual, just enough to get sb-cltl2 to pass tests.
1187 (let ((ctype (specifier-type (cadr spec
))))
1188 (dolist (fname (cddr spec
))
1189 (let ((fun (cdr (assoc fname funs
:test
'equal
))))
1192 (setf (sb-c::leaf-type fun
) ctype
)))))))
1193 ((ignorable type optimize special dynamic-extent
)
1196 (let ((fn (info :declaration
:handler
(first spec
))))
1201 ;; This is surely wrong. And as the comment above says,
1202 ;; it's ridiculous that these undergo conversion at all.
1205 (let ((thing (cdr x
)))
1207 (cons x
) ; symbol-macro
1208 (sb-c::lambda-var thing
)
1209 (sb-c::global-var
(make-lambda-var
1211 :%source-name
(car x
))))))
1213 ;; And surely this is wrong...
1216 ;; type-restrictions are represented in the same way essentially.
1217 (dolist (restriction (type-restrictions (env-contour env
)))
1218 (let ((binding (car restriction
)))
1220 (push (cons (gethash binding var-map
) (cdr restriction
))
1221 (sb-c::lexenv-type-restrictions lexenv
)))))
1223 (setf (sb-c::lexenv-vars lexenv
) (nconc vars
(sb-c::lexenv-vars lexenv
))
1224 (sb-c::lexenv-funs lexenv
) (nconc funs
(sb-c::lexenv-funs lexenv
))
1225 (sb-c::lexenv-%policy lexenv
) (%policy
(env-contour env
))
1226 ;; FIXME: package locks, handled conditions
1230 ;;; Produce the source representation expected by :INLINE-EXPANSION-DESIGNATOR.
1231 (defun reconstruct-syntactic-closure-env (env)
1232 (flet ((externalize (env forms
)
1233 (multiple-value-bind (kind data
)
1234 (let ((symbols (env-symbols env
))
1235 (expansions (env-payload env
)))
1238 (values :symbol-macro
1239 (map 'list
(lambda (x y
) (list (car x
) y
))
1240 symbols expansions
)))
1246 ;; The name of each macro is (MACROLET symbol).
1247 (cons (second (fun-name f
))
1248 (fun-lambda-expression f
)))
1250 ;; Insert all declarations, and hope for the best.
1251 ;; OPTIMIZE won't do anything. SPECIAL may or may not.
1252 (basic-env (values :declare nil
))))
1254 (let ((decl (awhen (env-declarations env
)
1255 (list* :declare it forms
))))
1257 (list* kind data
(if decl
(list decl
) forms
))
1261 (let ((sexpr (externalize env nest
)))
1263 (acond ((env-parent env
) (setq nest
(list sexpr
) env it
))
1267 ;;; Return :INLINE or :NOTINLINE if FNAME has a lexical declaration,
1268 ;;; otherwise NIL for no information.
1269 ;;; FIXME: obviously this does nothing
1270 (defun fun-lexically-notinline-p (fname env
)
1271 (declare (ignore fname env
))