/[cmucl]/src/compiler/ir1tran.lisp
ViewVC logotype

Contents of /src/compiler/ir1tran.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.176 - (show annotations)
Tue Apr 20 17:57:46 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.175: +15 -15 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Package: C; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/ir1tran.lisp,v 1.176 2010/04/20 17:57:46 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains code which does the translation from Lisp code to the
13 ;;; first intermediate representation (IR1).
14 ;;;
15 ;;; Written by Rob MacLachlan
16 ;;;
17 (in-package "C")
18 (intl:textdomain "cmucl")
19
20 (export '(*compile-time-define-macros* *converting-for-interpreter*
21 *suppress-values-declaration*))
22
23 (in-package "EXT")
24 (export '(truly-the maybe-inline *derive-function-types*))
25
26 (in-package "LISP")
27 (export '(ignorable dynamic-extent symbol-macrolet))
28
29 (in-package "KERNEL")
30 (export '(lambda-with-environment instance-lambda))
31
32 (in-package "C")
33
34
35 (declaim (special *compiler-error-bailout*))
36
37
38 ;;; The lexical environment we are currently converting in. See the LEXENV
39 ;;; structure.
40 ;;;
41 (defvar *lexical-environment*)
42 (declaim (type lexenv *lexical-environment*))
43
44 ;;; That variable is used to control the context-sensitive declarations
45 ;;; mechanism (see WITH-COMPILATION-UNIT). Each entry is a function which is
46 ;;; called with the function name and parent form name. If it returns non-nil,
47 ;;; then that is a list of DECLARE forms which should be inserted at the head
48 ;;; of the body.
49 ;;;
50 (defvar *context-declarations* ())
51 (declaim (list *context-declarations*))
52
53 ;;; *free-variables* translates from the names of variables referenced globally
54 ;;; to the Leaf structures for them. *free-functions* is like
55 ;;; *free-variables*, only it deals with function names.
56 ;;;
57 ;;; We must preserve the property that a proclamation for a global thing
58 ;;; only affects the code after it. This takes some work, since a proclamation
59 ;;; may appear in the middle of a block being compiled. If there are
60 ;;; references before the proclaim, then we copy the current entry before
61 ;;; modifying it. Code converted before the proclaim sees the old Leaf, while
62 ;;; code after it sees the new Leaf.
63 ;;;
64 (defvar *free-variables*)
65 (defvar *free-functions*)
66 (declaim (hash-table *free-variables* *free-functions*))
67
68 ;;; We use the same Constant structure to represent all equal anonymous
69 ;;; constants. This hashtable translates from constants to the Leafs that
70 ;;; represent them.
71 ;;;
72 (defvar *constants*)
73 (declaim (hash-table *constants*))
74
75 (defvar *coalesce-constants*)
76 (declaim (type (member t nil) *coalesce-constants*))
77
78 ;;; *SOURCE-PATHS* is a hashtable from source code forms to the path taken
79 ;;; through the source to reach the form. This provides a way to keep track of
80 ;;; the location of original source forms, even when macroexpansions and other
81 ;;; arbitary permutations of the code happen. This table is initialized by
82 ;;; calling FIND-SOURCE-PATHS on the original source.
83 ;;;
84 (declaim (hash-table *source-paths*))
85 (defvar *source-paths*)
86
87 ;;; *CURRENT-COMPONENT* is the Component structure which we link blocks into as
88 ;;; we generate them. This just serves to glue the emitted blocks together
89 ;;; until local call analysis and flow graph canonicalization figure out what
90 ;;; is really going on. We need to keep track of all the blocks generated so
91 ;;; that we can delete them if they turn out to be unreachable.
92 ;;;
93 (declaim (type (or component null) *current-component*))
94 (defvar *current-component*)
95
96 ;;; *CURRENT-PATH* is the source path of the form we are currently translating.
97 ;;; See NODE-SOURCE-PATH in the NODE structure.
98 ;;;
99 (declaim (list *current-path*))
100 (defvar *current-path* nil)
101
102 ;;; *CONVERTING-FOR-INTERPRETER* is true when we are creating IR1 to be
103 ;;; interpreted rather than compiled. This inhibits source transformations and
104 ;;; stuff.
105 ;;;
106 (defvar *converting-for-interpreter* nil)
107
108 ;;; *COMPILE-TIME-DEFINE-MACROS* is true when we want DEFMACRO definitions to
109 ;;; be installed in the compilation environment as interpreted functions. We
110 ;;; set this to false when compiling some parts of the system.
111 ;;;
112 (defvar *compile-time-define-macros* t)
113
114 ;;; Stack (alist) of names of currently compiled functions and counters
115 ;;; how often a name has been used.
116 ;;;
117 (declaim (list *current-function-names*))
118 (defvar *current-function-names* ())
119
120 (defvar *derive-function-types* t
121 "If true, argument and result type information derived from compilation of
122 DEFUNs is used when compiling calls to that function. If false, only
123 information from FTYPE proclamations will be used.")
124
125 ;;;
126 ;;; Returns non-nil if X and Y name the same function. This is more
127 ;;; involved than a simple call to EQ due to support for generalized
128 ;;; function names. In the IR1 representation, the local function INNER
129 ;;; in the following
130 ;;;
131 ;;; (defun outer (a)
132 ;;; (flet ((inner (x) (random x)))
133 ;;; (declaim (inline inner))
134 ;;; (inner a)))
135 ;;;
136 ;;; will have a lambda-name of (FLET INNER OUTER). Some parts of the
137 ;;; compiler may search for it under the name INNER.
138 ;;;
139 (defun function-name-eqv-p (x y)
140 (or (equal x y)
141 (and (consp y)
142 (member (car y) '(flet labels))
143 (equal x (cadr y)))))
144
145
146 ;;; *ALLOW-DEBUG-CATCH-TAG* controls whether we should allow the
147 ;;; insertion a (CATCH ...) around code to allow the debugger
148 ;;; return-from-frame (RETURN) command to work.
149 (defvar *allow-debug-catch-tag* t)
150
151 ;;; This is for debugging the return-from-frame functionality. These are
152 ;;; supposed to go away in the future. --jwr
153 (defvar *print-debug-tag-conversions* nil)
154 (defvar *print-debug-tag-converted-bodies* nil)
155
156
157 ;;;; Dynamic-Extent
158
159 (defvar *trust-dynamic-extent-declarations* nil
160 "If NIL, never trust dynamic-extent declarations.
161
162 If T, always trust dynamic-extent declarations.
163
164 Otherwise, the value of this variable must be a function of four
165 arguments SAFETY, SPACE, SPEED, and DEBUG. If the function returns
166 true when called, dynamic-extent declarations are trusted,
167 otherwise they are not trusted.")
168
169 (defvar *dynamic-extent-trace* nil)
170
171 (defun trust-dynamic-extent-declaration-p
172 (&optional (lexenv *lexical-environment*))
173 (declare (type lexenv lexenv))
174 (let ((trust *trust-dynamic-extent-declarations*))
175 (if (functionp trust)
176 (let ((cookie (lexenv-cookie lexenv)))
177 (funcall trust (cookie-safety cookie) (cookie-space cookie)
178 (cookie-speed cookie) (cookie-debug cookie)))
179 trust)))
180
181
182 (defun process-dynamic-extent-declaration (spec vars fvars lexenv)
183 (declare (list spec vars fvars) (type lexenv lexenv))
184 (if (trust-dynamic-extent-declaration-p lexenv)
185 (collect ((dynamic-extent))
186 (dolist (name (cdr spec))
187 (cond ((symbolp name)
188 (let* ((bound-var (find-in-bindings vars name))
189 (var (or bound-var
190 (lexenv-find name variables)
191 (find-free-variable name))))
192 (if (leaf-p var)
193 (if bound-var
194 (setf (leaf-dynamic-extent var) t)
195 (dynamic-extent var)))))
196 ((and (consp name)
197 (eq (car name) 'function)
198 (null (cddr name))
199 (valid-function-name-p (cadr name)))
200 (let* ((fn-name (cadr name))
201 (fn (find fn-name fvars
202 :key #'leaf-name
203 :test #'function-name-eqv-p)))
204 (if fn
205 (setf (leaf-dynamic-extent fn) t)
206 (dynamic-extent (find-lexically-apparent-function
207 fn-name
208 "in a dynamic-extent declaration")))))
209 (t
210 (compiler-warning
211 _N"~@<Invalid name ~s in a dynamic-extent declaration.~@:>"
212 name))))
213 (if (dynamic-extent)
214 (make-lexenv :default lexenv :dynamic-extent (dynamic-extent))
215 lexenv))
216 lexenv))
217
218 ;;;
219 ;;; Value is true if some dynamic-extent allocation can be done in the
220 ;;; initialization of variables Vars with values Vals.
221 ;;;
222 (defun dynamic-extent-allocation-p (vars vals)
223 (loop for var in vars and val in vals
224 thereis (and (leaf-dynamic-extent var)
225 (consp val)
226 (memq (car val) '(list list* cons)))))
227
228 ;;;
229 ;;; Return a list of indices for arguments in Args which might end up
230 ;;; as dynamic-extent closures. We can't tell for sure here because
231 ;;; environment analysis runs after IR1 conversion, so we don't know
232 ;;; yet what are closures and what not.
233 ;;;
234 (defun dynamic-extent-closure-args (args)
235 (declare (list args))
236 (flet ((find-local-function (name)
237 (let ((var (lexenv-find-function name)))
238 (when (leaf-p var)
239 var))))
240 (let ((dynamic-extent (lexenv-dynamic-extent *lexical-environment*)))
241 (collect ((indices))
242 (do* ((i 0 (1+ i))
243 (tail args (cdr tail))
244 (arg (car tail) (car tail)))
245 ((null tail))
246 (when (and (consp arg)
247 (eq (car arg) 'function)
248 (valid-function-name-p (cadr arg))
249 (let ((fn (find-local-function (cadr arg))))
250 (and fn
251 (or (leaf-dynamic-extent fn)
252 (and (functional-p fn)
253 (or (memq fn dynamic-extent)
254 (memq (functional-entry-function fn)
255 dynamic-extent)))))))
256 (indices i)))
257 (indices)))))
258
259 ;;;
260 ;;; Evaluate Body wrapped in a dynamic-extent cleanup.
261 ;;; FIXME: Maybe don't %dynamic-extent-start if kind = :rest.
262 ;;;
263 (defun gen-%dynamic-extent (kind)
264 `(%dynamic-extent ,kind (%dynamic-extent-start)))
265
266 (defmacro with-dynamic-extent ((start cont nnext-cont kind) &body body)
267 `(progn
268 (continuation-starts-block ,cont)
269 (let ((.cleanup. (make-cleanup :kind :dynamic-extent))
270 (.next-cont. (make-continuation))
271 (,nnext-cont (make-continuation)))
272 (ir1-convert ,start .next-cont. (gen-%dynamic-extent ,kind))
273 (setf (cleanup-mess-up .cleanup.) (continuation-use .next-cont.))
274 (let ((*lexical-environment* (make-lexenv :cleanup .cleanup.)))
275 (ir1-convert .next-cont. ,nnext-cont '(%cleanup-point))
276 (locally ,@body)))))
277
278
279 ;;;; Namespace management utilities:
280
281 (declaim (start-block find-free-function find-lexically-apparent-function))
282
283 ;;; Find-Free-Really-Function -- Internal
284 ;;;
285 ;;; Return a Global-Var structure usable for referencing the global function
286 ;;; Name.
287 ;;;
288 (defun find-free-really-function (name &optional context)
289 (unless (info function kind name)
290 (setf (info function kind name) :function)
291 (setf (info function where-from name) :assumed))
292
293 (let ((where (info function where-from name)))
294 (when (eq where :assumed)
295 (note-undefined-reference name :function context))
296 (make-global-var :kind :global-function :name name
297 :type (if (or *derive-function-types*
298 (eq where :declared))
299 (info function type name)
300 (specifier-type 'function))
301 :where-from where)))
302
303
304 ;;; Find-Structure-Slot-Accessor -- Internal
305 ;;;
306 ;;; Return a Slot-Accessor structure usable for referencing the slot
307 ;;; accessor Name. Class is the structure class.
308 ;;;
309 (defun find-structure-slot-accessor (class name)
310 (declare (type kernel::class class))
311 (let* ((info (layout-info
312 (or (info type compiler-layout (%class-name class))
313 (%class-layout class))))
314 (accessor (if (listp name) (cadr name) name))
315 (slot (find accessor (kernel:dd-slots info)
316 :key #'kernel:dsd-accessor))
317 (type (kernel:dd-name info))
318 (slot-type (kernel:dsd-type slot)))
319 (assert slot () (intl:gettext "Can't find slot ~S.") type)
320 (make-slot-accessor
321 :name name
322 :type (specifier-type
323 (if (listp name)
324 `(function (,slot-type ,type) ,slot-type)
325 `(function (,type) ,slot-type)))
326 :for class
327 :slot slot)))
328
329
330 ;;; Find-Free-Function -- Internal
331 ;;;
332 ;;; If NAME is already entered in *free-functions*, then return the value.
333 ;;; Otherwise, make a new Global-Var using information from the global
334 ;;; environment and enter it in *free-functions*. If NAME names a macro or
335 ;;; special form, then we error out using the supplied CONTEXT which indicates
336 ;;; what we were trying to do that demanded a function.
337 ;;;
338 (defun find-free-function (name context)
339 (declare (string context))
340 (declare (values global-var))
341 (or (gethash name *free-functions*)
342 (ecase (info function kind name)
343 (:macro
344 (compiler-error _N"Found macro name ~S ~A." name context))
345 (:special-form
346 (compiler-error _N"Found special-form name ~S ~A." name context))
347 ((:function nil)
348 (check-function-name name)
349 (note-if-setf-function-and-macro name)
350 (let ((expansion (info function inline-expansion name))
351 (inlinep (info function inlinep name)))
352 (setf (gethash name *free-functions*)
353 (if (or expansion inlinep)
354 (make-defined-function
355 :name name
356 :inline-expansion expansion
357 :inlinep inlinep
358 :where-from (info function where-from name)
359 :type (info function type name))
360 (let ((info (info function accessor-for name)))
361 (etypecase info
362 (null
363 (find-free-really-function name context))
364 (kernel::structure-class
365 (find-structure-slot-accessor info name))
366 (class
367 (if (typep (layout-info (info type compiler-layout
368 (%class-name info)))
369 'defstruct-description)
370 (find-structure-slot-accessor info name)
371 (find-free-really-function name context))))))))))))
372
373
374 ;;; Find-Lexically-Apparent-Function -- Internal
375 ;;;
376 ;;; Return the Leaf structure for the lexically apparent function definition
377 ;;; of NAME.
378 ;;;
379 (defun find-lexically-apparent-function (name context)
380 (declare (string context) (values leaf))
381 (let ((var (lexenv-find-function name)))
382 (cond (var
383 (unless (leaf-p var)
384 (assert (and (consp var) (eq (car var) 'macro)))
385 (compiler-error _N"Found macro name ~S ~A." name context))
386 var)
387 (t
388 (find-free-function name context)))))
389
390 (declaim (end-block))
391
392 ;;; Find-Free-Variable -- Internal
393 ;;;
394 ;;; Return the Leaf node for a global variable reference to Name. If Name
395 ;;; is already entered in *free-variables*, then we just return the
396 ;;; corresponding value. Otherwise, we make a new leaf using information from
397 ;;; the global environment and enter it in *free-variables*. If the variable
398 ;;; is unknown, then we emit a warning.
399 ;;;
400 (defun find-free-variable (name)
401 (declare (values (or leaf cons heap-alien-info)))
402 (unless (symbolp name)
403 (compiler-error _N"Variable name is not a symbol: ~S." name))
404 (or (gethash name *free-variables*)
405 (let ((kind (info variable kind name))
406 (type (info variable type name))
407 (where-from (info variable where-from name)))
408 (when (and (eq where-from :assumed) (eq kind :global))
409 (note-undefined-reference name :variable))
410 ;;
411 ;; Paper over the fact that unknown types aren't removed
412 ;; from the info database when a types gets defined.
413 (when (unknown-type-p type)
414 (setq type (specifier-type (type-specifier type)))
415 (setf (info variable type name) type))
416
417 (setf (gethash name *free-variables*)
418 (case kind
419 (:alien
420 (info variable alien-info name))
421 (:macro
422 (let ((expansion (info variable macro-expansion name)))
423 `(MACRO . (the ,(type-specifier type) ,expansion))))
424 (:constant
425 (multiple-value-bind (val valp)
426 (info variable constant-value name)
427 (if valp
428 (make-constant :value val :name name
429 :type (ctype-of val)
430 :where-from where-from)
431 (make-global-var :kind kind :name name :type type
432 :where-from where-from))))
433 (t
434 (make-global-var :kind kind :name name :type type
435 :where-from where-from)))))))
436
437
438 ;;; MAYBE-EMIT-MAKE-LOAD-FORMS -- internal
439 ;;;
440 ;;; Grovel over CONSTANT checking for any sub-parts that need to be processed
441 ;;; with MAKE-LOAD-FORM. We have to be careful, because CONSTANT might be
442 ;;; circular. We also check that the constant (and any subparts) are dumpable
443 ;;; at all.
444 ;;;
445 (defconstant list-to-hash-table-threshold 32)
446 ;;;
447 (defun maybe-emit-make-load-forms (constant)
448 (let ((things-processed nil)
449 (count 0))
450 (declare (type (or list hash-table) things-processed)
451 (type (integer 0 #.(1+ list-to-hash-table-threshold)) count)
452 (inline member))
453 (labels ((grovel (value)
454 (unless (typep value
455 '(or unboxed-array symbol number character))
456 (etypecase things-processed
457 (list
458 (when (member value things-processed :test #'eq)
459 (return-from grovel nil))
460 (push value things-processed)
461 (incf count)
462 (when (> count list-to-hash-table-threshold)
463 (let ((things things-processed))
464 (setf things-processed
465 (make-hash-table :test #'eq))
466 (dolist (thing things)
467 (setf (gethash thing things-processed) t)))))
468 (hash-table
469 (when (gethash value things-processed)
470 (return-from grovel nil))
471 (setf (gethash value things-processed) t)))
472 (typecase value
473 (cons
474 (grovel (car value))
475 (grovel (cdr value)))
476 (simple-vector
477 (dotimes (i (length value))
478 (grovel (svref value i))))
479 ((vector t)
480 (dotimes (i (length value))
481 (grovel (aref value i))))
482 ((simple-array t)
483 ;; Even though the (array t) branch does the exact same
484 ;; thing as this branch we do this seperate so that
485 ;; the compiler can use faster versions of array-total-size
486 ;; and row-major-aref.
487 (dotimes (i (array-total-size value))
488 (grovel (row-major-aref value i))))
489 ((array t)
490 (dotimes (i (array-total-size value))
491 (grovel (row-major-aref value i))))
492 (instance
493 (when (emit-make-load-form value)
494 (dotimes (i (%instance-length value))
495 (grovel (%instance-ref value i)))))
496 (t
497 (compiler-error
498 _N"Cannot dump objects of type ~S into fasl files."
499 (type-of value)))))))
500 (grovel constant)))
501 (undefined-value))
502
503
504 ;;;; Some flow-graph hacking utilities:
505
506 (eval-when (:compile-toplevel :execute)
507 ;;; IR1-Error-Bailout -- Internal
508 ;;;
509 ;;; Bind *compiler-error-bailout* to a function that throws out of the body
510 ;;; and converts a proxy form instead.
511 ;;;
512 (defmacro ir1-error-bailout
513 ((start cont form
514 &optional
515 (proxy ``(error 'simple-program-error
516 :format-control (intl:gettext "Execution of a form compiled with errors:~% ~S")
517 :format-arguments (list ',,form))))
518 &body body)
519 (let ((skip (gensym)))
520 `(block ,skip
521 (catch 'ir1-error-abort
522 (let ((*compiler-error-bailout*
523 #'(lambda () (throw 'ir1-error-abort nil))))
524 ,@body
525 (return-from ,skip nil)))
526 (ir1-convert ,start ,cont ,proxy))))
527
528 ); eval-when (:compile-toplevel :execute)
529
530
531 ;;; Prev-Link -- Internal
532 ;;;
533 ;;; This function sets up the back link between the node and the
534 ;;; continuation which continues at it.
535 ;;;
536 (declaim (inline prev-link))
537 (defun prev-link (node cont)
538 (declare (type node node) (type continuation cont))
539 (assert (not (continuation-next cont)))
540 (setf (continuation-next cont) node)
541 (setf (node-prev node) cont))
542
543
544 ;;; Use-Continuation -- Internal
545 ;;;
546 ;;; This function is used to set the continuation for a node, and thus
547 ;;; determine what recieves the value and what is evaluated next. If the
548 ;;; continuation has no block, then we make it be in the block that the node is
549 ;;; in. If the continuation heads its block, we end our block and link it to
550 ;;; that block. If the continuation is not currently used, then we set the
551 ;;; derived-type for the continuation to that of the node, so that a little
552 ;;; type propagation gets done.
553 ;;;
554 ;;; We also deal with a bit of THE's semantics here: we weaken the assertion
555 ;;; on Cont to be no stronger than the assertion on Cont in our scope. See the
556 ;;; THE IR1-CONVERT method.
557 ;;;
558 (declaim (inline use-continuation))
559 (defun use-continuation (node cont)
560 (declare (type node node) (type continuation cont))
561 (let ((node-block (continuation-block (node-prev node))))
562 (case (continuation-kind cont)
563 (:unused
564 (setf (continuation-block cont) node-block)
565 (setf (continuation-kind cont) :inside-block)
566 (setf (continuation-use cont) node)
567 (setf (node-cont node) cont))
568 (t
569 (%use-continuation node cont)))))
570 ;;;
571 (defun %use-continuation (node cont)
572 (declare (type node node) (type continuation cont) (inline member))
573 (let ((block (continuation-block cont))
574 (node-block (continuation-block (node-prev node))))
575 (assert (eq (continuation-kind cont) :block-start))
576 (assert (not (block-last node-block)) () (intl:gettext "~S has already ended.")
577 node-block)
578 (setf (block-last node-block) node)
579 (assert (null (block-succ node-block)) () (intl:gettext "~S already has successors.")
580 node-block)
581 (setf (block-succ node-block) (list block))
582 (assert (not (member node-block (block-pred block) :test #'eq)) ()
583 (intl:gettext "~S is already a predecessor of ~S.") node-block block)
584 (push node-block (block-pred block))
585 (add-continuation-use node cont)
586 (unless (eq (continuation-asserted-type cont) *wild-type*)
587 (let ((new (values-type-union (continuation-asserted-type cont)
588 (or (lexenv-find cont type-restrictions)
589 *wild-type*))))
590 (when (type/= new (continuation-asserted-type cont))
591 (setf (continuation-asserted-type cont) new)
592 (reoptimize-continuation cont))))))
593
594
595 ;;;; Exported functions:
596
597 ;;; IR1-Top-Level -- Interface
598 ;;;
599 ;;; This function takes a form and the top-level form number for that form,
600 ;;; and returns a lambda representing the translation of that form in the
601 ;;; current global environment. The lambda is top-level lambda that can be
602 ;;; called to cause evaluation of the forms. This lambda is in the initial
603 ;;; component. If For-Value is T, then the value of the form is returned from
604 ;;; the function, otherwise NIL is returned.
605 ;;;
606 ;;; This function may have arbitrary effects on the global environment due
607 ;;; to processing of Proclaims and Eval-Whens. All syntax error checking is
608 ;;; done, with erroneous forms being replaced by a proxy which signals an error
609 ;;; if it is evaluated. Warnings about possibly inconsistent or illegal
610 ;;; changes to the global environment will also be given.
611 ;;;
612 ;;; We make the initial component and convert the form in a progn (and an
613 ;;; optional NIL tacked on the end.) We then return the lambda. We bind all
614 ;;; of our state variables here, rather than relying on the global value (if
615 ;;; any) so that IR1 conversion will be reentrant. This is necessary for
616 ;;; eval-when processing, etc.
617 ;;;
618 ;;; The hashtables used to hold global namespace info must be reallocated
619 ;;; elsewhere. Note also that *lexical-environment* is not bound, so that
620 ;;; local macro definitions can be introduced by enclosing code.
621 ;;;
622 (defun ir1-top-level (form path for-value)
623 (declare (list path))
624 (let* ((*current-path* path)
625 (component (make-empty-component))
626 (*current-component* component))
627 (setf (component-name component) "initial component")
628 (setf (component-kind component) :initial)
629 (let* ((forms (if for-value `(,form) `(,form nil)))
630 (res (ir1-convert-lambda-body forms ())))
631 (setf (leaf-name res) "Top-Level Form")
632 (setf (functional-entry-function res) res)
633 (setf (functional-arg-documentation res) ())
634 (setf (functional-kind res) :top-level)
635 res)))
636
637
638 ;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the form
639 ;;; number to associate with a source path. This should be bound to 0 around
640 ;;; the processing of each truly top-level form.
641 ;;;
642 (declaim (type index *current-form-number*))
643 (defvar *current-form-number*)
644
645 ;;; Find-Source-Paths -- Interface
646 ;;;
647 ;;; This function is called on freshly read forms to record the initial
648 ;;; location of each form (and subform.) Form is the form to find the paths
649 ;;; in, and TLF-Num is the top-level form number of the truly top-level form.
650 ;;;
651 ;;; This gets a bit interesting when the source code is circular. This can
652 ;;; (reasonably?) happen in the case of circular list constants.
653 ;;;
654 (defun find-source-paths (form tlf-num)
655 (declare (type index tlf-num))
656 (let ((*current-form-number* 0))
657 (sub-find-source-paths form (list tlf-num)))
658 (undefined-value))
659 ;;;
660 (defun sub-find-source-paths (form path)
661 (unless (gethash form *source-paths*)
662 (setf (gethash form *source-paths*)
663 (list* 'original-source-start *current-form-number* path))
664 (incf *current-form-number*)
665 (let ((pos 0)
666 (subform form)
667 (trail form))
668 (declare (fixnum pos))
669 (macrolet ((frob ()
670 '(progn
671 (when (atom subform) (return))
672 (let ((fm (car subform)))
673 (when (consp fm)
674 (sub-find-source-paths fm (cons pos path)))
675 (incf pos))
676 (setq subform (cdr subform))
677 (when (eq subform trail) (return)))))
678 (loop
679 (frob)
680 (frob)
681 (setq trail (cdr trail)))))))
682
683
684
685
686 ;;;; IR1-CONVERT, macroexpansion and special-form dispatching.
687
688 (declaim (start-block ir1-convert ir1-convert-progn-body
689 ir1-convert-combination-args reference-leaf
690 reference-constant))
691
692 ;;; IR1-Convert -- Interface
693 ;;;
694 ;;; Translate Form into IR1. The code is inserted as the Next of the
695 ;;; continuation Start. Cont is the continuation which receives the value of
696 ;;; the Form to be translated. The translators call this function recursively
697 ;;; to translate their subnodes.
698 ;;;
699 ;;; As a special hack to make life easier in the compiler, a Leaf
700 ;;; IR1-converts into a reference to that leaf structure. This allows the
701 ;;; creation using backquote of forms that contain leaf references, without
702 ;;; having to introduce dummy names into the namespace.
703 ;;;
704 (defun ir1-convert (start cont form)
705 (declare (type continuation start cont))
706 (ir1-error-bailout (start cont form)
707 (let ((*current-path* (or (gethash form *source-paths*)
708 (cons form *current-path*))))
709 (if (atom form)
710 (cond ((and (symbolp form) (not (keywordp form)))
711 (ir1-convert-variable start cont form))
712 ((leaf-p form)
713 (reference-leaf start cont form))
714 (t
715 (reference-constant start cont form)))
716 (let ((fun (car form)))
717 (cond
718 ((symbolp fun)
719 (let ((lexical-def (lexenv-find-function fun)))
720 (typecase lexical-def
721 (null
722 (when (eq fun 'declare)
723 (compiler-error _N"Misplaced declaration."))
724 (ir1-convert-global-functoid start cont form))
725 (functional
726 (ir1-convert-local-combination start cont form lexical-def))
727 (global-var
728 (ir1-convert-srctran start cont lexical-def form))
729 (t
730 (assert (and (consp lexical-def)
731 (eq (car lexical-def) 'macro)))
732 (ir1-convert start cont
733 (careful-expand-macro (cdr lexical-def)
734 form))))))
735 ((or (atom fun) (not (eq (car fun) 'lambda)))
736 (compiler-error _N"Illegal function call."))
737 (t
738 (ir1-convert-combination start cont form
739 ;; TODO: check this case --jwr
740 (ir1-convert-lambda fun
741 nil ; name
742 nil ; parent-form
743 t
744 'ir1-convert)))))))))
745
746
747 ;;; Reference-Constant -- Internal
748 ;;;
749 ;;; Generate a reference to a manifest constant, creating a new leaf if
750 ;;; necessary. If we are producing a fasl-file, make sure MAKE-LOAD-FORM
751 ;;; gets used on any parts of the constant that it needs to be.
752 ;;;
753 (defun reference-constant (start cont value)
754 (declare (type continuation start cont) (inline find-constant))
755 (ir1-error-bailout
756 (start cont value
757 '(error (intl:gettext "Attempt to reference undumpable constant.")))
758 (when (and (producing-fasl-file)
759 (not (typep value '(or symbol number character string))))
760 (maybe-emit-make-load-forms value))
761 (let* ((leaf (find-constant value))
762 (res (make-ref (leaf-type leaf) leaf)))
763 (push res (leaf-refs leaf))
764 (prev-link res start)
765 (use-continuation res cont)))
766 (undefined-value))
767
768
769 ;;; MAYBE-REANALYZE-FUNCTION -- Internal
770 ;;;
771 ;;; Add Fun to the COMPONENT-REANALYZE-FUNCTIONS. Fun is returned.
772 ;;;
773 (defun maybe-reanalyze-function (fun)
774 (declare (type functional fun))
775 (when (typep fun '(or optional-dispatch clambda))
776 (pushnew fun (component-reanalyze-functions *current-component*)))
777 fun)
778
779
780 ;;; Reference-Leaf -- Internal
781 ;;;
782 ;;; Generate a Ref node for a Leaf, frobbing the Leaf structure as needed.
783 ;;; If the leaf is a defined function which has already been converted, and is
784 ;;; not :NOTINLINE, then reference the functional instead.
785 ;;;
786 (defun reference-leaf (start cont leaf)
787 (declare (type continuation start cont) (type leaf leaf))
788 (let* ((leaf (or (and (defined-function-p leaf)
789 (not (eq (defined-function-inlinep leaf)
790 :notinline))
791 (let ((fun (defined-function-functional leaf)))
792 (when (and fun (not (functional-kind fun)))
793 (maybe-reanalyze-function fun))))
794 leaf))
795 (res (make-ref (or (lexenv-find leaf type-restrictions)
796 (leaf-type leaf))
797 leaf)))
798 (push res (leaf-refs leaf))
799 (setf (leaf-ever-used leaf) t)
800 (prev-link res start)
801 (use-continuation res cont)))
802
803
804 ;;; IR1-Convert-Variable -- Internal
805 ;;;
806 ;;; Convert a reference to a symbolic constant or variable. If the symbol
807 ;;; is entered in the LEXENV-VARIABLES we use that definition, otherwise we
808 ;;; find the current global definition. This is also where we pick off symbol
809 ;;; macro and Alien variable references.
810 ;;;
811 (defun ir1-convert-variable (start cont name)
812 (declare (type continuation start cont) (symbol name))
813 (let ((var (or (lexenv-find name variables) (find-free-variable name))))
814 (etypecase var
815 (leaf
816 (when (lambda-var-p var)
817 (when (lambda-var-ignorep var)
818 (compiler-note _N"Reading an ignored variable: ~S." name))
819 ;;
820 ;; FIXME: There's a quirk somewhere when recording this
821 ;; dependency, which I don't have to time to debug right now.
822 ;; Redefining a function like this:
823 ;;
824 ;; (defun foo ())
825 ;;
826 ;; (let ((foo #'foo))
827 ;; (defun foo () (funcall foo)))
828 ;;
829 ;; leads to infinite recursion because the funcall uses
830 ;; FOO's fdefn object instead of the local variable's value.
831 ;; -- Gerd, 2003-11-04
832 #+nil
833 (note-dfo-dependency start var))
834 (reference-leaf start cont var))
835 (cons
836 (assert (eq (car var) 'MACRO))
837 (ir1-convert start cont (cdr var)))
838 (heap-alien-info
839 (ir1-convert start cont `(%heap-alien ',var)))))
840 (undefined-value))
841
842
843 ;;; IR1-Convert-Global-Functoid -- Internal
844 ;;;
845 ;;; Convert anything that looks like a special-form, global function or
846 ;;; macro call.
847 ;;;
848 (defun ir1-convert-global-functoid (start cont form)
849 (declare (type continuation start cont) (list form))
850 (let* ((fun (first form))
851 (translator (info function ir1-convert fun))
852 (cmacro (info function compiler-macro-function fun)))
853 (cond
854 (translator (funcall translator start cont form))
855 ((and cmacro (not *converting-for-interpreter*)
856 (not (eq (info function inlinep fun) :notinline)))
857 (let ((res (careful-expand-macro cmacro form)))
858 (if (eq res form)
859 (ir1-convert-global-functoid-no-cmacro start cont form fun)
860 (ir1-convert start cont res))))
861 (t
862 (ir1-convert-global-functoid-no-cmacro start cont form fun)))))
863
864
865 ;;; IR1-Convert-Global-Functoid-No-Cmacro -- Internal
866 ;;;
867 ;;; Handle the case of where the call was not a compiler macro, or was a
868 ;;; compiler macro and passed.
869 ;;;
870 (defun ir1-convert-global-functoid-no-cmacro (start cont form fun)
871 (declare (type continuation start cont) (list form))
872 (ecase (info function kind fun)
873 (:macro
874 (when c:*record-xref-info*
875 (let ((leb (lexenv-blocks *lexical-environment*)))
876 (unless (or (null leb) (null (caar leb)))
877 (xref:register-xref :macroexpands fun
878 (xref:make-xref-context :name (caar leb))))))
879 (ir1-convert start cont
880 (careful-expand-macro (info function macro-function fun)
881 form)))
882 ((nil :function)
883 (ir1-convert-srctran start cont (find-free-function fun "")
884 form))))
885
886
887 ;;; Careful-Expand-Macro -- Internal
888 ;;;
889 ;;; Trap errors during the macroexpansion.
890 ;;;
891 (defun careful-expand-macro (fun form)
892 (handler-case (invoke-macroexpand-hook fun form *lexical-environment*)
893 (error (condition)
894 (compiler-error _N"(during macroexpansion)~%~A"
895 condition))))
896
897
898 ;;;; Conversion utilities:
899
900 ;;; IR1-Convert-Progn-Body -- Internal
901 ;;;
902 ;;; Convert a bunch of forms, discarding all the values except the last.
903 ;;; If there aren't any forms, then translate a NIL.
904 ;;;
905 (defun ir1-convert-progn-body (start cont body)
906 (declare (type continuation start cont) (list body))
907 (if (endp body)
908 (reference-constant start cont nil)
909 (let ((this-start start)
910 (forms body))
911 (loop
912 (let ((form (car forms)))
913 (when (endp (cdr forms))
914 (ir1-convert this-start cont form)
915 (return))
916 (let ((this-cont (make-continuation)))
917 (ir1-convert this-start this-cont form)
918 (setq this-start this-cont forms (cdr forms))))))))
919
920
921 ;;;; Converting combinations:
922
923 ;;; IR1-Convert-Combination -- Internal
924 ;;;
925 ;;; Convert a function call where the function (Fun) is a Leaf. We return
926 ;;; the Combination node so that we can poke at it if we want to.
927 ;;;
928 (defun ir1-convert-combination (start cont form fun)
929 (declare (type continuation start cont) (list form) (type leaf fun)
930 (values combination))
931 (let ((indices (dynamic-extent-closure-args (cdr form))))
932 (if indices
933 (with-dynamic-extent (start cont nnext-cont :closure)
934 (when *dynamic-extent-trace*
935 (format t (intl:gettext "~&dynamic-extent args ~:s in ~s~%") indices form))
936 (let ((fun-cont (make-continuation)))
937 (reference-leaf nnext-cont fun-cont fun)
938 (ir1-convert-combination-args fun-cont cont (cdr form) indices)))
939 (let ((fun-cont (make-continuation)))
940 (reference-leaf start fun-cont fun)
941 (ir1-convert-combination-args fun-cont cont (cdr form))))))
942
943
944 ;;; IR1-Convert-Combination-Args -- Internal
945 ;;;
946 ;;; Convert the arguments to a call and make the Combination node. Fun-Cont
947 ;;; is the continuation which yields the function to call. Form is the source
948 ;;; for the call. Args is the list of arguments for the call, which defaults
949 ;;; to the cdr of source. We return the Combination node.
950 ;;;
951 (defun ir1-convert-combination-args (fun-cont cont args
952 &optional dynamic-extent-args)
953 (declare (type continuation fun-cont cont) (list args))
954 (let ((node (make-combination fun-cont)))
955 (setf (continuation-dest fun-cont) node)
956 (assert-continuation-type
957 fun-cont (values-specifier-type '(values (or function symbol) &rest t)))
958 (collect ((arg-conts))
959 (let ((this-start fun-cont)
960 (lambda-vars (let* ((use (continuation-use fun-cont))
961 (leaf (when use (ref-leaf use))))
962 (when (lambda-p leaf)
963 (lambda-vars leaf))))
964 (i 0))
965 (dolist (arg args)
966 (let ((this-cont (make-continuation node)))
967 (when (or (and lambda-vars
968 (leaf-dynamic-extent (pop lambda-vars)))
969 (member i dynamic-extent-args))
970 (setf (continuation-dynamic-extent this-cont) t))
971 (ir1-convert this-start this-cont arg)
972 (setq this-start this-cont)
973 (arg-conts this-cont)
974 (incf i)))
975 (prev-link node this-start)
976 (use-continuation node cont)
977 (setf (combination-args node) (arg-conts))))
978 node))
979
980
981 ;;; IR1-CONVERT-SRCTRAN -- Internal
982 ;;;
983 ;;; Convert a call to a global function. If not :NOTINLINE, then we do
984 ;;; source transforms and try out any inline expansion. If there is no
985 ;;; expansion, but is :INLINE, then give an efficiency note (unless a known
986 ;;; function which will quite possibly be open-coded.) Next, we go to
987 ;;; ok-combination conversion.
988 ;;;
989 (defun ir1-convert-srctran (start cont var form)
990 (declare (type continuation start cont) (type global-var var))
991 (let ((inlinep (when (defined-function-p var)
992 (defined-function-inlinep var))))
993 (cond
994 ((eq inlinep :notinline)
995 (ir1-convert-combination start cont form var))
996 (*converting-for-interpreter*
997 (ir1-convert-combination-checking-type start cont form var))
998 (t
999 (let ((transform (info function source-transform (leaf-name var))))
1000 (cond
1001 (transform
1002 (multiple-value-bind (result pass)
1003 (funcall transform form)
1004 (if pass
1005 (ir1-convert-maybe-predicate start cont form var)
1006 (ir1-convert start cont result))))
1007 (t
1008 (ir1-convert-maybe-predicate start cont form var))))))))
1009
1010
1011 ;;; IR1-CONVERT-MAYBE-PREDICATE -- Internal
1012 ;;;
1013 ;;; If the function has the Predicate attribute, and the CONT's DEST isn't
1014 ;;; an IF, then we convert (IF <form> T NIL), ensuring that a predicate always
1015 ;;; appears in a conditional context.
1016 ;;;
1017 ;;; If the function isn't a predicate, then we call
1018 ;;; IR1-CONVERT-COMBINATION-CHECKING-TYPE.
1019 ;;;
1020 (defun ir1-convert-maybe-predicate (start cont form var)
1021 (declare (type continuation start cont) (list form) (type global-var var))
1022 (let ((info (info function info (leaf-name var))))
1023 (if (and info
1024 (ir1-attributep (function-info-attributes info) predicate)
1025 (not (if-p (continuation-dest cont))))
1026 (ir1-convert start cont `(if ,form t nil))
1027 (ir1-convert-combination-checking-type start cont form var))))
1028
1029
1030 ;;; IR1-CONVERT-COMBINATION-CHECKING-TYPE -- Internal
1031 ;;;
1032 ;;; Actually really convert a global function call that we are allowed to
1033 ;;; early-bind.
1034 ;;;
1035 ;;; If we know the function type of the function, then we check the call for
1036 ;;; syntactic legality with respect to the declared function type. If it is
1037 ;;; impossible to determine whether the call is correct due to non-constant
1038 ;;; keywords, then we give up, marking the call as :FULL to inhibit further
1039 ;;; error messages. We return true when the call is legal.
1040 ;;;
1041 ;;; If the call is legal, we also propagate type assertions from the function
1042 ;;; type to the arg and result continuations. We do this now so that IR1
1043 ;;; optimize doesn't have to redundantly do the check later so that it can do
1044 ;;; the type propagation.
1045 ;;;
1046 ;;;
1047 (defun ir1-convert-combination-checking-type (start cont form var)
1048 (declare (type continuation start cont) (list form) (type leaf var))
1049 (let* ((node (ir1-convert-combination start cont form var))
1050 (fun-cont (basic-combination-fun node))
1051 (type (leaf-type var)))
1052 (when (validate-call-type node type t)
1053 (setf (continuation-%derived-type fun-cont) type)
1054 (setf (continuation-reoptimize fun-cont) nil)
1055 (setf (continuation-%type-check fun-cont) nil)))
1056
1057 (undefined-value))
1058
1059
1060 ;;; IR1-CONVERT-LOCAL-COMBINATION -- Internal
1061 ;;;
1062 ;;; Convert a call to a local function. If the function has already been
1063 ;;; let converted, then throw FUN to LOCAL-CALL-LOSSAGE. This should only
1064 ;;; happen when we are converting inline expansions for local functions during
1065 ;;; optimization.
1066 ;;;
1067 (defun ir1-convert-local-combination (start cont form fun)
1068 (if (functional-kind fun)
1069 (throw 'local-call-lossage fun)
1070 (ir1-convert-combination start cont form
1071 (maybe-reanalyze-function fun))))
1072
1073
1074 ;;;; PROCESS-DECLARATIONS:
1075
1076 (declaim (start-block process-declarations make-new-inlinep
1077 find-in-bindings))
1078
1079 ;;; Find-In-Bindings -- Internal
1080 ;;;
1081 ;;; Given a list of Lambda-Var structures and a variable name, return the
1082 ;;; structure for that name, or NIL if it isn't found. We return the *last*
1083 ;;; variable with that name, since let* bindings may be duplicated, and
1084 ;;; declarations always apply to the last.
1085 ;;;
1086 (defun find-in-bindings (vars name)
1087 (declare (list vars) (symbol name) (values (or lambda-var list)))
1088 (let ((found nil))
1089 (dolist (var vars)
1090 (cond ((leaf-p var)
1091 (when (eq (leaf-name var) name)
1092 (setq found var))
1093 (let ((info (lambda-var-arg-info var)))
1094 (when info
1095 (let ((supplied-p (arg-info-supplied-p info)))
1096 (when (and supplied-p
1097 (eq (leaf-name supplied-p) name))
1098 (setq found supplied-p))))))
1099 ((and (consp var) (eq (car var) name))
1100 (setf found (cdr var)))))
1101 found))
1102
1103
1104 ;;; Process-Type-Declaration -- Internal
1105 ;;;
1106 ;;; Called by Process-Declarations to deal with a variable type declaration.
1107 ;;; If a lambda-var being bound, we intersect the type with the vars type,
1108 ;;; otherwise we add a type-restriction on the var. If a symbol macro, we just
1109 ;;; wrap a THE around the expansion.
1110 ;;;
1111 (defun process-type-declaration (decl res vars)
1112 (declare (list decl vars) (type lexenv res))
1113 (let ((type (specifier-type (first decl))))
1114 (collect ((restr nil cons)
1115 (new-vars nil cons))
1116 (dolist (var-name (rest decl))
1117 (let* ((bound-var (find-in-bindings vars var-name))
1118 (var (or bound-var
1119 (lexenv-find var-name variables)
1120 (find-free-variable var-name))))
1121 (etypecase var
1122 (leaf
1123 (flet ((process (var bound-var)
1124 (let* ((old-type (or (lexenv-find var type-restrictions)
1125 (leaf-type var)))
1126 (int (if (or (function-type-p type)
1127 (function-type-p old-type))
1128 type
1129 (type-intersection old-type type))))
1130 (cond ((eq int *empty-type*)
1131 (unless (policy nil (= brevity 3))
1132 (compiler-warning
1133 _N"Conflicting type declarations ~
1134 ~S and ~S for ~S."
1135 (type-specifier old-type)
1136 (type-specifier type)
1137 var-name)))
1138 (bound-var
1139 (setf (leaf-type bound-var) int))
1140 (t
1141 (restr (cons var int)))))))
1142 (process var bound-var)
1143 (when (lambda-var-p var)
1144 (let ((special (lambda-var-specvar var)))
1145 (when special
1146 (process special nil))))))
1147 (cons
1148 (assert (eq (car var) 'MACRO))
1149 (new-vars `(,var-name . (MACRO . (the ,(first decl)
1150 ,(cdr var))))))
1151 (heap-alien-info
1152 (compiler-error _N"Can't declare type of Alien variable: ~S."
1153 var-name)))))
1154
1155 (if (or (restr) (new-vars))
1156 (make-lexenv :default res
1157 :type-restrictions (restr)
1158 :variables (new-vars))
1159 res))))
1160
1161
1162 ;;; Process-Ftype-Declaration -- Internal
1163 ;;;
1164 ;;; Somewhat similar to PROCESS-TYPE-DECLARATION, but handles declarations
1165 ;;; for function variables. In addition to allowing declarations for functions
1166 ;;; being bound, we must also deal with declarations that constrain the type of
1167 ;;; lexically apparent functions.
1168 ;;;
1169 (defun process-ftype-declaration (spec res names fvars)
1170 (declare (list names fvars) (type lexenv res)
1171 (type (or symbol list) spec))
1172 (let ((type (specifier-type spec)))
1173 (collect ((res nil cons))
1174 (dolist (name names)
1175 (let ((found (find name fvars :key #'leaf-name :test #'function-name-eqv-p)))
1176 (cond
1177 (found
1178 (setf (leaf-type found) type)
1179 (assert-definition-type found type
1180 :warning-function #'compiler-note
1181 :where "FTYPE declaration"))
1182 (t
1183 (res (cons (find-lexically-apparent-function
1184 name "in a function type declaration")
1185 type))))))
1186 (if (res)
1187 (make-lexenv :default res :type-restrictions (res))
1188 res))))
1189
1190
1191 ;;; PROCESS-SPECIAL-DECLARATION -- Internal
1192 ;;;
1193 ;;; Process a special declaration, returning a new LEXENV. A non-bound
1194 ;;; special declaration is instantiated by throwing a special variable into the
1195 ;;; variables.
1196 ;;;
1197 (defun process-special-declaration (spec res vars)
1198 (declare (list spec vars) (type lexenv res))
1199 (collect ((new-venv nil cons))
1200 (dolist (name (cdr spec))
1201 (let ((var (find-in-bindings vars name)))
1202 (etypecase var
1203 (cons
1204 (assert (eq (car var) 'MACRO))
1205 (compiler-error _N"Declaring symbol-macro ~S special." name))
1206 (lambda-var
1207 (when (lambda-var-ignorep var)
1208 (compiler-note _N"Ignored variable ~S is being declared special."
1209 name))
1210 (setf (lambda-var-specvar var)
1211 (specvar-for-binding name)))
1212 (null
1213 (unless (assoc name (new-venv) :test #'eq)
1214 (new-venv (cons name (specvar-for-binding name))))))))
1215 (if (new-venv)
1216 (make-lexenv :default res :variables (new-venv))
1217 res)))
1218
1219
1220 ;;; MAKE-NEW-INLINEP -- Internal
1221 ;;;
1222 ;;; Return a DEFINED-FUNCTION which copies a global-var but for its inlinep.
1223 ;;;
1224 (defun make-new-inlinep (var inlinep)
1225 (declare (type global-var var) (type inlinep inlinep))
1226 (let ((res (make-defined-function
1227 :name (leaf-name var)
1228 :where-from (leaf-where-from var)
1229 :type (leaf-type var)
1230 :inlinep inlinep)))
1231 (when (defined-function-p var)
1232 (setf (defined-function-inline-expansion res)
1233 (defined-function-inline-expansion var))
1234 (setf (defined-function-functional res)
1235 (defined-function-functional var)))
1236 res))
1237
1238
1239 (defconstant inlinep-translations
1240 '((inline . :inline)
1241 (notinline . :notinline)
1242 (maybe-inline . :maybe-inline)))
1243
1244
1245 ;;; PROCESS-INLINE-DECLARATION -- Internal
1246 ;;;
1247 ;;; Parse an inline/notinline declaration. If a local function we are
1248 ;;; defining, set its INLINEP. If a global function, add a new FENV entry.
1249 ;;;
1250 (defun process-inline-declaration (spec res fvars)
1251 (let ((sense (cdr (assoc (first spec) inlinep-translations :test #'eq)))
1252 (new-fenv ()))
1253 (dolist (name (rest spec))
1254 (let ((fvar (find name fvars
1255 :key #'(lambda (x)
1256 ;; FVARS doesn't always contain a
1257 ;; LEAF. Sometimes it comes from a
1258 ;; macrolet.
1259 (and (leaf-p x)
1260 (leaf-name x)))
1261 :test #'function-name-eqv-p)))
1262 (if fvar
1263 (setf (functional-inlinep fvar) sense)
1264 (let ((found
1265 (find-lexically-apparent-function
1266 name "in an inline or notinline declaration")))
1267 (etypecase found
1268 (functional
1269 (when (policy nil (>= speed brevity))
1270 (compiler-note _N"Ignoring ~A declaration not at ~
1271 definition of local function:~% ~S"
1272 sense name)))
1273 (global-var
1274 (push (cons name (make-new-inlinep found sense))
1275 new-fenv)))))))
1276
1277 (if new-fenv
1278 (make-lexenv :default res :functions new-fenv)
1279 res)))
1280
1281
1282 ;;; FIND-IN-BINDINGS-OR-FBINDINGS -- Internal
1283 ;;;
1284 ;;; Like FIND-IN-BINDINGS, but looks for #'foo in the fvars.
1285 ;;;
1286 (defun find-in-bindings-or-fbindings (name vars fvars)
1287 (declare (list vars fvars))
1288 (if (consp name)
1289 (destructuring-bind (wot fn-name) name
1290 (unless (eq wot 'function)
1291 (compiler-error _N"Unrecognizable function or variable name: ~S"
1292 name))
1293 (find fn-name fvars
1294 :key #'leaf-name
1295 :test #'function-name-eqv-p))
1296 (find-in-bindings vars name)))
1297
1298
1299 ;;; PROCESS-IGNORE-DECLARATION -- Internal
1300 ;;;
1301 ;;; Process an ignore/ignorable declaration, checking for various losing
1302 ;;; conditions.
1303 ;;;
1304 (defun process-ignore-declaration (spec vars fvars)
1305 (declare (list spec vars fvars))
1306 (dolist (name (rest spec))
1307 (let ((var (find-in-bindings-or-fbindings name vars fvars)))
1308 (cond
1309 ((not var)
1310 (if (or (lexenv-find name variables)
1311 (lexenv-find-function name))
1312 (compiler-note _N"Ignoring free ignore declaration for ~S." name)
1313 (compiler-warning _N"Ignore declaration for unknown variable ~S."
1314 name)))
1315 ((and (consp var)
1316 (eq (car var) 'macro)
1317 ;; Var is '(macro foo). Why must foo be a cons? This
1318 ;; causes (symbol-macrolet ((a 42)) (declare (ignorable
1319 ;; a)) ...) to get a type error from a test below because
1320 ;; var is '(macro . 42) in this case.
1321 #+nil
1322 (consp (cdr var)))
1323 ;; Just ignore the ignore decl.
1324 )
1325 ((functional-p var)
1326 (setf (leaf-ever-used var) t))
1327 ((lambda-var-specvar var)
1328 (compiler-note _N"Declaring special variable ~S to be ignored." name))
1329 ((eq (first spec) 'ignorable)
1330 (setf (leaf-ever-used var) t))
1331 (t
1332 (setf (lambda-var-ignorep var) t)))))
1333 (undefined-value))
1334
1335 (defvar *suppress-values-declaration* nil
1336 "If true, processing of the VALUES declaration is inhibited.")
1337
1338 ;;; PROCESS-1-DECLARATION -- Internal
1339 ;;;
1340 ;;; Process a single declaration spec, agumenting the specified LEXENV
1341 ;;; Res and returning it as a result. Vars and Fvars are as described in
1342 ;;; PROCESS-DECLARATIONS.
1343 ;;;
1344 (defun process-1-declaration (spec res vars fvars cont)
1345 (declare (list spec vars fvars) (type lexenv res) (type continuation cont))
1346 (case (first spec)
1347 (special (process-special-declaration spec res vars))
1348 (ftype
1349 (unless (cdr spec)
1350 (compiler-error _N"No type specified in FTYPE declaration: ~S." spec))
1351 (process-ftype-declaration (second spec) res (cddr spec) fvars))
1352 (function
1353 ;;
1354 ;; Handle old style FUNCTION declaration, which is an abbreviation for
1355 ;; FTYPE. Args are name, arglist, result type.
1356 (cond ((and (<= 3 (length spec) 4) (listp (third spec)))
1357 (process-ftype-declaration `(function ,@(cddr spec)) res
1358 (list (second spec))
1359 fvars))
1360 (t
1361 (process-type-declaration spec res vars))))
1362 ((inline notinline maybe-inline)
1363 (process-inline-declaration spec res fvars))
1364 ((ignore ignorable)
1365 (process-ignore-declaration spec vars fvars)
1366 res)
1367 (optimize
1368 (make-lexenv
1369 :default res
1370 :cookie (process-optimize-declaration spec (lexenv-cookie res))))
1371 (optimize-interface
1372 (make-lexenv
1373 :default res
1374 :interface-cookie (process-optimize-declaration
1375 spec
1376 (lexenv-interface-cookie res))))
1377 (type
1378 (process-type-declaration (cdr spec) res vars))
1379 (pcl::class
1380 (process-type-declaration (list (third spec) (second spec)) res vars))
1381 (values
1382 (if *suppress-values-declaration*
1383 res
1384 (let ((types (cdr spec)))
1385 (do-the-stuff (values-specifier-type (if (eql (length types) 1)
1386 (car types)
1387 `(values ,@types)))
1388 cont res 'values))))
1389 (dynamic-extent
1390 (process-dynamic-extent-declaration spec vars fvars res))
1391 (t
1392 (let ((what (first spec)))
1393 (cond ((member what type-specifier-symbols)
1394 (process-type-declaration spec res vars))
1395 ((and (not (and (symbolp what)
1396 (string= (symbol-name what) "CLASS"))) ; pcl hack
1397 (or (info type kind what)
1398 (and (consp what) (info type translator (car what)))))
1399 (compiler-note _N"Abbreviated type declaration: ~S." spec)
1400 (process-type-declaration spec res vars))
1401 ((info declaration recognized what)
1402 res)
1403 (t
1404 (compiler-warning _N"Unrecognized declaration: ~S." spec)
1405 res))))))
1406
1407
1408 ;;; Process-Declarations -- Interface
1409 ;;;
1410 ;;; Use a list of Declare forms to annotate the lists of Lambda-Var and
1411 ;;; Functional structures which are being bound. In addition to filling in
1412 ;;; slots in the leaf structures, we return a new LEXENV which reflects
1413 ;;; pervasive special and function type declarations, (not)inline declarations
1414 ;;; and optimize declarations. Cont is the continuation affected by VALUES
1415 ;;; declarations.
1416 ;;;
1417 ;;; This is also called in main.lisp when PROCESS-FORM handles a use of
1418 ;;; LOCALLY.
1419 ;;;
1420 (defun process-declarations (decls vars fvars cont &optional
1421 (env *lexical-environment*))
1422 (declare (list decls vars fvars) (type continuation cont))
1423 (dolist (decl decls)
1424 (dolist (spec (rest decl))
1425 (unless (consp spec)
1426 (compiler-error _N"Malformed declaration specifier ~S in ~S."
1427 spec decl))
1428
1429 (setq env (process-1-declaration spec env vars fvars cont))))
1430 env)
1431
1432 ;;; Specvar-For-Binding -- Internal
1433 ;;;
1434 ;;; Return the Specvar for Name to use when we see a local SPECIAL
1435 ;;; declaration. If there is a global variable of that name, then check that
1436 ;;; it isn't a constant and return it. Otherwise, create an anonymous
1437 ;;; GLOBAL-VAR.
1438 ;;;
1439 (defun specvar-for-binding (name)
1440 (cond ((not (eq (info variable where-from name) :assumed))
1441 (let ((found (find-free-variable name)))
1442 (when (heap-alien-info-p found)
1443 (compiler-error _N"Declaring an alien variable to be special: ~S"
1444 name))
1445 (when (or (not (global-var-p found))
1446 (eq (global-var-kind found) :constant))
1447 (compiler-error _N"Declaring a constant to be special: ~S." name))
1448 found))
1449 (t
1450 (make-global-var :kind :special :name name :where-from :declared))))
1451
1452
1453 ;;;; Lambda hackery:
1454
1455 (declaim (start-block ir1-convert-lambda ir1-convert-lambda-body
1456 ir1-convert-aux-bindings varify-lambda-arg
1457 ir1-convert-dynamic-extent-bindings))
1458
1459 ;;; Varify-Lambda-Arg -- Internal
1460 ;;;
1461 ;;; Verify that a thing is a legal name for a variable and return a Var
1462 ;;; structure for it, filling in info if it is globally special. If it is
1463 ;;; losing, we punt with a Compiler-Error. Names-So-Far is an alist of names
1464 ;;; which have previously been bound. If the name is in this list, then we
1465 ;;; error out.
1466 ;;;
1467 (defun varify-lambda-arg (name names-so-far)
1468 (declare (list names-so-far) (values lambda-var)
1469 (inline member))
1470 (unless (symbolp name)
1471 (compiler-error _N"Lambda-variable is not a symbol: ~S." name))
1472 (when (member name names-so-far :test #'eq)
1473 (compiler-error _N"Repeated variable in lambda-list: ~S." name))
1474 (let ((kind (info variable kind name)))
1475 (when (or (keywordp name) (eq kind :constant))
1476 (compiler-error _N"Name of lambda-variable is a constant: ~S." name))
1477 (if (eq kind :special)
1478 (let ((specvar (find-free-variable name)))
1479 (make-lambda-var :name name
1480 :type (leaf-type specvar)
1481 :where-from (leaf-where-from specvar)
1482 :specvar specvar))
1483 (make-lambda-var :name name))))
1484
1485
1486 ;;; Make-Keyword -- Internal
1487 ;;;
1488 ;;; Make the keyword for a keyword arg, checking that the keyword isn't
1489 ;;; already used by one of the Vars.
1490 ;;;
1491 (defun make-keyword (symbol vars keywordify)
1492 (declare (symbol symbol) (list vars) (values symbol))
1493 (let ((key (if (and keywordify (not (keywordp symbol)))
1494 (intern (symbol-name symbol) "KEYWORD")
1495 symbol)))
1496 (dolist (var vars)
1497 (let ((info (lambda-var-arg-info var)))
1498 (when (and info
1499 (eq (arg-info-kind info) :keyword)
1500 (eq (arg-info-keyword info) key))
1501 (compiler-error _N"Multiple uses of keyword ~S in lambda-list." key))))
1502 key))
1503
1504
1505 ;;; IR1-wrap-for-debug -- Internal
1506 ;;;
1507 ;;; Wrap a piece of code in a catch form, so that we can later throw to it
1508 ;;; in the debugger, to return a value.
1509 ;;;
1510 (defun ir1-wrap-for-debug (body)
1511 (let ((new-body `((catch (make-symbol "CMUCL-DEBUG-CATCH-TAG")
1512 ,@body))))
1513 (when (and *compile-print*
1514 *print-debug-tag-conversions*
1515 *print-debug-tag-converted-bodies*)
1516 (format t "new-body: ~S~%" new-body))
1517 new-body))
1518
1519
1520 ;;; IR1-Convert-Lambda -- Internal
1521 ;;;
1522 ;;; Convert a Lambda into a Lambda or Optional-Dispatch leaf. NAME and
1523 ;;; PARENT-FORM are context that is used to drive the context sensitive
1524 ;;; declaration mechanism. If we find an entry in *CONTEXT-DECLARATIONS* that
1525 ;;; matches this context (by returning a non-null value) then we add it into
1526 ;;; the local declarations.
1527 ;;;
1528 (defun ir1-convert-lambda (form &optional
1529 name
1530 parent-form
1531 allow-debug-catch-tag
1532 caller)
1533 (unless (consp form)
1534 (compiler-error _N"Found a ~S when expecting a lambda expression:~% ~S"
1535 (type-of form) form))
1536 (unless (eq (car form) 'lambda)
1537 (compiler-error _N"Expecting a lambda, but form begins with ~S:~% ~S"
1538 (car form) form))
1539 (unless (and (consp (cdr form)) (listp (cadr form)))
1540 (compiler-error _N"Lambda-list absent or not a list:~% ~S" form))
1541
1542 (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
1543 (find-lambda-vars (cadr form))
1544 (multiple-value-bind (body decls)
1545 (system:parse-body (cddr form) *lexical-environment* t)
1546 (let* ((*allow-debug-catch-tag* (and *allow-debug-catch-tag*
1547 allow-debug-catch-tag))
1548 (new-body (if (and parent-form
1549 *allow-debug-catch-tag*
1550 (policy nil (= debug 3))) ; TODO: check the policy settings --jwr
1551 (progn
1552 (when (and *compile-print* *print-debug-tag-conversions*)
1553 (format t (intl:gettext "ir1-convert-lambda: called by: ~S, parent-form: ~S~%")
1554 caller parent-form))
1555 (ir1-wrap-for-debug body))
1556 body))
1557 (*current-function-names*
1558 (if (member parent-form
1559 '(flet labels defun defmacro define-compiler-macro)
1560 :test #'eq)
1561 (list name)
1562 *current-function-names*))
1563 (context-decls
1564 (and parent-form
1565 (loop for fun in *context-declarations*
1566 append (funcall (the function fun)
1567 name parent-form))))
1568 (cont (make-continuation))
1569 (*lexical-environment*
1570 (process-declarations (append context-decls decls)
1571 (append aux-vars vars)
1572 nil cont))
1573 (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
1574 (ir1-convert-hairy-lambda new-body vars keyp
1575 allow-other-keys
1576 aux-vars aux-vals cont)
1577 (ir1-convert-lambda-body new-body vars aux-vars aux-vals
1578 t cont))))
1579 (setf (functional-inline-expansion res) form)
1580 (setf (functional-arg-documentation res) (cadr form))
1581 (setf (leaf-name res)
1582 (or name
1583 ;; PCL-generated lambdas end up here without an explicit NAME.
1584 ;; To avoid ending up with IR1 lambda-nodes that are unnamed,
1585 ;; we extract a name from the "method-name" declaration that
1586 ;; is inserted by PCL. A cleaner solution would be to add a
1587 ;; NAMED-LAMBDA IR1 translator, similar to that used in SBCL,
1588 ;; and make PCL use that instead of LAMBDA.
1589 (let ((decl (find 'pcl::method-name decls :key 'caadr)))
1590 (and decl
1591 (eq 'declare (first decl))
1592 (cons 'pcl::method (cadadr decl))))))
1593 res))))
1594
1595
1596 ;;; Find-Lambda-Vars -- Internal
1597 ;;;
1598 ;;; Parse a lambda-list into a list of Var structures, stripping off any aux
1599 ;;; bindings. Each arg name is checked for legality, and duplicate names are
1600 ;;; checked for. If an arg is globally special, the var is marked as :special
1601 ;;; instead of :lexical. Keyword, optional and rest args are annotated with an
1602 ;;; arg-info structure which contains the extra information. If we hit
1603 ;;; something losing, we bug out with Compiler-Error. These values are
1604 ;;; returned:
1605 ;;; 1] A list of the var structures for each top-level argument.
1606 ;;; 2] A flag indicating whether &key was specified.
1607 ;;; 3] A flag indicating whether other keyword args are allowed.
1608 ;;; 4] A list of the &aux variables.
1609 ;;; 5] A list of the &aux values.
1610 ;;;
1611 (defun find-lambda-vars (list)
1612 (declare (list list) (values list boolean boolean list list))
1613 (multiple-value-bind
1614 (required optional restp rest keyp keys allowp aux
1615 morep more-context more-count)
1616 (parse-lambda-list list)
1617 (collect ((vars)
1618 (names-so-far)
1619 (aux-vars)
1620 (aux-vals))
1621 ;;
1622 ;; Parse-Default deals with defaults and supplied-p args for optionals
1623 ;; and keywords args.
1624 (flet ((parse-default (spec info)
1625 (when (consp (cdr spec))
1626 (setf (arg-info-default info) (second spec))
1627 (when (consp (cddr spec))
1628 (let* ((supplied-p (third spec))
1629 (supplied-var (varify-lambda-arg supplied-p (names-so-far))))
1630 (setf (arg-info-supplied-p info) supplied-var)
1631 (names-so-far supplied-p)
1632 (when (> (length (the list spec)) 3)
1633 (compiler-error _N"Arg specifier is too long: ~S." spec)))))))
1634
1635 (dolist (name required)
1636 (let ((var (varify-lambda-arg name (names-so-far))))
1637 (vars var)
1638 (names-so-far name)))
1639
1640 (dolist (spec optional)
1641 (if (atom spec)
1642 (let ((var (varify-lambda-arg spec (names-so-far))))
1643 (setf (lambda-var-arg-info var) (make-arg-info :kind :optional))
1644 (vars var)
1645 (names-so-far spec))
1646 (let* ((name (first spec))
1647 (var (varify-lambda-arg name (names-so-far)))
1648 (info (make-arg-info :kind :optional)))
1649 (setf (lambda-var-arg-info var) info)
1650 (vars var)
1651 (names-so-far name)
1652 (parse-default spec info))))
1653
1654 (when restp
1655 (let ((var (varify-lambda-arg rest (names-so-far))))
1656 (setf (lambda-var-arg-info var) (make-arg-info :kind :rest))
1657 (vars var)
1658 (names-so-far rest)))
1659
1660 (when morep
1661 (let ((var (varify-lambda-arg more-context (names-so-far))))
1662 (setf (lambda-var-arg-info var)
1663 (make-arg-info :kind :more-context))
1664 (vars var)
1665 (names-so-far more-context))
1666 (let ((var (varify-lambda-arg more-count (names-so-far))))
1667 (setf (lambda-var-arg-info var)
1668 (make-arg-info :kind :more-count))
1669 (vars var)
1670 (names-so-far more-count)))
1671
1672 (dolist (spec keys)
1673 (cond
1674 ((atom spec)
1675 (let ((var (varify-lambda-arg spec (names-so-far))))
1676 (setf (lambda-var-arg-info var)
1677 (make-arg-info :kind :keyword
1678 :keyword (make-keyword spec (vars) t)))
1679 (vars var)
1680 (names-so-far spec)))
1681 ((atom (first spec))
1682 (let* ((name (first spec))
1683 (var (varify-lambda-arg name (names-so-far)))
1684 (info (make-arg-info
1685 :kind :keyword
1686 :keyword (make-keyword name (vars) t))))
1687 (setf (lambda-var-arg-info var) info)
1688 (vars var)
1689 (names-so-far name)
1690 (parse-default spec info)))
1691 (t
1692 (let ((head (first spec)))
1693 (unless (= (length (the list head)) 2)
1694 (error (intl:gettext "Malformed keyword arg specifier: ~S.") spec))
1695 (let* ((name (second head))
1696 (var (varify-lambda-arg name (names-so-far)))
1697 (info (make-arg-info
1698 :kind :keyword
1699 :keyword (make-keyword (first head) (vars) nil))))
1700 (setf (lambda-var-arg-info var) info)
1701 (vars var)
1702 (names-so-far name)
1703 (parse-default spec info))))))
1704
1705 (dolist (spec aux)
1706 (cond ((atom spec)
1707 (let ((var (varify-lambda-arg spec nil)))
1708 (aux-vars var)
1709 (aux-vals nil)
1710 (names-so-far spec)))
1711 (t
1712 (unless (<= 1 (length spec) 2)
1713 (compiler-error _N"Malformed &aux binding specifier: ~S."
1714 spec))
1715 (let* ((name (first spec))
1716 (var (varify-lambda-arg name nil)))
1717 (aux-vars var)
1718 (aux-vals (second spec))
1719 (names-so-far name)))))
1720
1721 (values (vars) keyp allowp (aux-vars) (aux-vals))))))
1722
1723
1724 ;;; IR1-Convert-Aux-Bindings -- Internal
1725 ;;;
1726 ;;; Similar to IR1-Convert-Progn-Body except that we sequentially bind each
1727 ;;; Aux-Var to the corresponding Aux-Val before converting the body. If there
1728 ;;; are no bindings, just convert the body, otherwise do one binding and
1729 ;;; recurse on the rest.
1730 ;;;
1731 ;;; If Interface is true, then we convert bindings with the interface
1732 ;;; policy. For real &aux bindings, and implicit aux bindings introduced by
1733 ;;; keyword bindings, this is always true. It is only false when LET* directly
1734 ;;; calls this function.
1735 ;;;
1736 (defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals interface)
1737 (declare (type continuation start cont) (list body aux-vars aux-vals))
1738 (if (null aux-vars)
1739 (ir1-convert-progn-body start cont body)
1740 (let ((fun-cont (make-continuation))
1741 (fun (ir1-convert-lambda-body body (list (first aux-vars))
1742 (rest aux-vars) (rest aux-vals)
1743 interface)))
1744 (reference-leaf start fun-cont fun)
1745 (let ((*lexical-environment*
1746 (if interface
1747 (make-lexenv
1748 :cookie (make-interface-cookie *lexical-environment*))
1749 *lexical-environment*)))
1750 (ir1-convert-combination-args fun-cont cont
1751 (list (first aux-vals))))))
1752 (values))
1753
1754 (defun ir1-convert-dynamic-extent-bindings (start cont body aux-vars
1755 aux-vals interface)
1756 (declare (type continuation start cont) (list body aux-vars aux-vals))
1757 (if (dynamic-extent-allocation-p aux-vars aux-vals)
1758 (with-dynamic-extent (start cont nnext-cont :bind)
1759 (ir1-convert-aux-bindings nnext-cont cont body aux-vars
1760 aux-vals interface))
1761 (ir1-convert-aux-bindings start cont body aux-vars aux-vals interface))
1762 (values))
1763
1764
1765 ;;; IR1-Convert-Special-Bindings -- Internal
1766 ;;;
1767 ;;; Similar to IR1-Convert-Progn-Body except that code to bind the Specvar
1768 ;;; for each Svar to the value of the variable is wrapped around the body. If
1769 ;;; there are no special bindings, we just convert the body, otherwise we do
1770 ;;; one special binding and recurse on the rest.
1771 ;;;
1772 ;;; We make a cleanup and introduce it into the lexical environment. If
1773 ;;; there are multiple special bindings, the cleanup for the blocks will end up
1774 ;;; being the innermost one. We force Cont to start a block outside of this
1775 ;;; cleanup, causing cleanup code to be emitted when the scope is exited.
1776 ;;;
1777 (defun ir1-convert-special-bindings (start cont body aux-vars aux-vals
1778 interface svars)
1779 (declare (type continuation start cont)
1780 (list body aux-vars aux-vals svars))
1781 (cond
1782 ((null svars)
1783 (ir1-convert-dynamic-extent-bindings start cont body aux-vars aux-vals
1784 interface))
1785 (t
1786 (continuation-starts-block cont)
1787 (let ((cleanup (make-cleanup :kind :special-bind))
1788 (var (first svars))
1789 (next-cont (make-continuation))
1790 (nnext-cont (make-continuation)))
1791 (ir1-convert start next-cont
1792 `(%special-bind ',(lambda-var-specvar var) ,var))
1793 (setf (cleanup-mess-up cleanup) (continuation-use next-cont))
1794 (let ((*lexical-environment* (make-lexenv :cleanup cleanup)))
1795 (ir1-convert next-cont nnext-cont '(%cleanup-point))
1796 (ir1-convert-special-bindings nnext-cont cont body aux-vars aux-vals
1797 interface (rest svars))))))
1798 (values))
1799
1800
1801 ;;; IR1-Convert-Lambda-Body -- Internal
1802 ;;;
1803 ;;; Create a lambda node out of some code, returning the result. The
1804 ;;; bindings are specified by the list of var structures Vars. We deal with
1805 ;;; adding the names to the Lexenv-Variables for the conversion. The result is
1806 ;;; added to the New-Functions in the *Current-Component* and linked to the
1807 ;;; component head and tail.
1808 ;;;
1809 ;;; We detect special bindings here, replacing the original Var in the lambda
1810 ;;; list with a temporary variable. We then pass a list of the special vars to
1811 ;;; IR1-Convert-Special-Bindings, which actually emits the special binding
1812 ;;; code.
1813 ;;;
1814 ;;; We ignore any Arg-Info in the Vars, trusting that someone else is dealing
1815 ;;; with &nonsense.
1816 ;;;
1817 ;;; Aux-Vars is a list of Var structures for variables that are to be
1818 ;;; sequentially bound. Each Aux-Val is a form that is to be evaluated to get
1819 ;;; the initial value for the corresponding Aux-Var. Interface is a flag as T
1820 ;;; when there are real aux values (see let* and ir1-convert-aux-bindings.)
1821 ;;;
1822 (defun ir1-convert-lambda-body (body vars &optional aux-vars aux-vals
1823 interface result)
1824 (declare (list body vars aux-vars aux-vals)
1825 (type (or continuation null) result))
1826 (let* ((bind (make-bind))
1827 (lambda (make-lambda :vars vars :bind bind))
1828 (result (or result (make-continuation)))
1829 (dynamic-extent-rest nil))
1830 (setf (lambda-home lambda) lambda)
1831 (collect ((svars)
1832 (new-venv nil cons))
1833
1834 (dolist (var vars)
1835 (setf (lambda-var-home var) lambda)
1836 (let ((specvar (lambda-var-specvar var)))
1837 (cond (specvar
1838 (svars var)
1839 (new-venv (cons (leaf-name specvar) specvar)))
1840 (t
1841 (new-venv (cons (leaf-name var) var)))))
1842 (let ((info (lambda-var-arg-info var)))
1843 (when (and info
1844 (eq :rest (arg-info-kind info))
1845 (leaf-dynamic-extent var))
1846 (setq dynamic-extent-rest var))))
1847
1848 (let* ((*lexical-environment*
1849 (make-lexenv :variables (new-venv) :lambda lambda
1850 :cleanup nil)))
1851 (setf (bind-lambda bind) lambda)
1852 (setf (node-lexenv bind) *lexical-environment*)
1853
1854 (let ((cont1 (make-continuation))
1855 (cont2 (make-continuation)))
1856 (continuation-starts-block cont1)
1857 (prev-link bind cont1)
1858 (use-continuation bind cont2)
1859 (if dynamic-extent-rest
1860 (with-dynamic-extent (cont2 result nnext-cont :rest)
1861 (ir1-convert-special-bindings nnext-cont result body
1862 aux-vars aux-vals
1863 interface (svars)))
1864 (ir1-convert-special-bindings cont2 result body aux-vars aux-vals
1865 interface (svars))))
1866
1867 (let ((block (continuation-block result)))
1868 (when block
1869 (let ((return (make-return :result result
1870 :lambda lambda))
1871 (tail-set (make-tail-set :functions (list lambda)))
1872 (dummy (make-continuation)))
1873 (setf (lambda-tail-set lambda) tail-set)
1874 (setf (lambda-return lambda) return)
1875 (setf (continuation-dest result) return)
1876 (setf (block-last block) return)
1877 (prev-link return result)
1878 (use-continuation return dummy))
1879 (link-blocks block (component-tail *current-component*))))))
1880
1881 (link-blocks (component-head *current-component*) (node-block bind))
1882 (push lambda (component-new-functions *current-component*))
1883 lambda))
1884
1885
1886 ;;; Convert-Optional-Entry -- Internal
1887 ;;;
1888 ;;; Create the actual entry-point function for an optional entry point. The
1889 ;;; lambda binds copies of each of the Vars, then calls Fun with the argument
1890 ;;; Vals and the Defaults. Presumably the Vals refer to the Vars by name. The
1891 ;;; Vals are passed in in reverse order.
1892 ;;;
1893 ;;; If any of the copies of the vars are referenced more than once, then we
1894 ;;; mark the corresponding var as Ever-Used to inhibit "defined but not read"
1895 ;;; warnings for arguments that are only used by default forms.
1896 ;;;
1897 ;;; We bind *lexical-environment* to change the policy over to the interface
1898 ;;; policy.
1899 ;;;
1900 (defun convert-optional-entry (fun vars vals defaults)
1901 (declare (type clambda fun) (list vars vals defaults))
1902 (let* ((fvars (reverse vars))
1903 (arg-vars (mapcar #'(lambda (var)
1904 (make-lambda-var
1905 :name (leaf-name var)
1906 :type (leaf-type var)
1907 :where-from (leaf-where-from var)
1908 :specvar (lambda-var-specvar var)))
1909 fvars))
1910 (*lexical-environment*
1911 (make-lexenv :cookie (make-interface-cookie *lexical-environment*)))
1912 (fun
1913 (ir1-convert-lambda-body
1914 `((%funcall ,fun ,@(reverse vals) ,@defaults))
1915 arg-vars)))
1916 (mapc #'(lambda (var arg-var)
1917 (when (cdr (leaf-refs arg-var))
1918 (setf (leaf-ever-used var) t)))
1919 fvars arg-vars)
1920 fun))
1921
1922
1923 ;;; Generate-Optional-Default-Entry -- Internal
1924 ;;;
1925 ;;; This function deals with supplied-p vars in optional arguments. If the
1926 ;;; there is no supplied-p arg, then we just call IR1-Convert-Hairy-Args on the
1927 ;;; remaining arguments, and generate a optional entry that calls the result.
1928 ;;; If there is a supplied-p var, then we add it into the default vars and
1929 ;;; throw a T into the entry values. The resulting entry point function is
1930 ;;; returned.
1931 ;;;
1932 (defun generate-optional-default-entry (res default-vars default-vals
1933 entry-vars entry-vals
1934 vars supplied-p-p body
1935 aux-vars aux-vals cont)
1936 (declare (type optional-dispatch res)
1937 (list default-vars default-vals entry-vars entry-vals vars body
1938 aux-vars aux-vals)
1939 (type (or continuation null) cont))
1940 (let* ((arg (first vars))
1941 (arg-name (leaf-name arg))
1942 (info (lambda-var-arg-info arg))
1943 (supplied-p (arg-info-supplied-p info))
1944 (ep (if supplied-p
1945 (ir1-convert-hairy-args
1946 res
1947 (list* supplied-p arg default-vars)
1948 (list* (leaf-name supplied-p) arg-name default-vals)
1949 (cons arg entry-vars)
1950 (list* t arg-name entry-vals)
1951 (rest vars) t body aux-vars aux-vals cont)
1952 (ir1-convert-hairy-args
1953 res
1954 (cons arg default-vars)
1955 (cons arg-name default-vals)
1956 (cons arg entry-vars)
1957 (cons arg-name entry-vals)
1958 (rest vars) supplied-p-p body aux-vars aux-vals cont))))
1959
1960 (convert-optional-entry ep default-vars default-vals
1961 (if supplied-p
1962 (list (arg-info-default info) nil)
1963 (list (arg-info-default info))))))
1964
1965
1966 ;;; Convert-More-Entry -- Internal
1967 ;;;
1968 ;;; Create the More-Entry function for the Optional-Dispatch Res.
1969 ;;; Entry-Vars and Entry-Vals describe the fixed arguments. Rest is the var
1970 ;;; for any Rest arg. Keys is a list of the keyword arg vars.
1971 ;;;
1972 ;;; The most interesting thing that we do is parse keywords. We create a
1973 ;;; bunch of temporary variables to hold the result of the parse, and then loop
1974 ;;; over the supplied arguments, setting the appropriate temps for the supplied
1975 ;;; keyword. Note that it is significant that we iterate over the keywords in
1976 ;;; reverse order --- this implements the CL requirement that (when a keyword
1977 ;;; appears more than once) the first value is used.
1978 ;;;
1979 ;;; If there is no supplied-p var, then we initialize the temp to the
1980 ;;; default and just pass the temp into the main entry. Since non-constant
1981 ;;; keyword args are forcibly given a supplied-p var, we know that the default
1982 ;;; is constant, and thus safe to evaluate out of order.
1983 ;;;
1984 ;;; If there is a supplied-p var, then we create temps for both the value
1985 ;;; and the supplied-p, and pass them into the main entry, letting it worry
1986 ;;; about defaulting.
1987 ;;;
1988 ;;; We deal with :allow-other-keys by delaying unknown keyword errors until
1989 ;;; we have scanned all the keywords.
1990 ;;;
1991 ;;; When converting the function, we bind *lexical-environment* to change
1992 ;;; the compilation policy over to the interface policy, so that keyword args
1993 ;;; will be checked even when type checking isn't on in general.
1994 ;;;
1995 (defun convert-more-entry (res entry-vars entry-vals rest morep keys)
1996 (declare (type optional-dispatch res) (list entry-vars entry-vals keys))
1997 (collect ((arg-vars)
1998 (arg-vals (reverse entry-vals))
1999 (temps)
2000 (body))
2001
2002 (dolist (var (reverse entry-vars))
2003 (arg-vars (make-lambda-var
2004 :name (leaf-name var)
2005 :type (leaf-type var)
2006 :where-from (leaf-where-from var))))
2007
2008 (let* ((n-context (gensym "N-CONTEXT-"))
2009 (context-temp (make-lambda-var :name n-context))
2010 (n-count (gensym "N-COUNT-"))
2011 (count-temp (make-lambda-var :name n-count
2012 :type (specifier-type 'index)))
2013 (*lexical-environment*
2014 (make-lexenv :cookie
2015 (make-interface-cookie *lexical-environment*))))
2016
2017 (arg-vars context-temp count-temp)
2018
2019 (when rest
2020 (arg-vals `(%listify-rest-args ,n-context ,n-count
2021 ,(leaf-dynamic-extent rest))))
2022 (when morep
2023 (arg-vals n-context)
2024 (arg-vals n-count))
2025
2026 (when (optional-dispatch-keyp res)
2027 (let ((n-index (gensym "N-INDEX-"))
2028 (n-key (gensym "N-KEY-"))
2029 (n-value-temp (gensym "N-VALUE-TEMP"))
2030 (n-allowp (gensym "N-ALLOWP-"))
2031 (n-losep (gensym "N-LOSEP-"))
2032 (allowp (or (optional-dispatch-allowp res)
2033 (policy nil (zerop safety)))))
2034
2035 (temps `(,n-index (1- ,n-count)) n-key n-value-temp)
2036 (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp)))
2037
2038 (collect ((tests))
2039 (dolist (key keys)
2040 (let* ((info (lambda-var-arg-info key))
2041 (default (arg-info-default info))
2042 (keyword (arg-info-keyword info))
2043 (supplied-p (arg-info-supplied-p info))
2044 (n-value (gensym "N-VALUE-")))
2045 (temps `(,n-value ,default))
2046 (cond (supplied-p
2047 (let ((n-supplied (gensym "N-SUPPLIED-")))
2048 (temps n-supplied)
2049 (arg-vals n-value n-supplied)
2050 (tests `((eq ,n-key ',keyword)
2051 (setq ,n-supplied t)
2052 (setq ,n-value ,n-value-temp)))))
2053 (t
2054 (arg-vals n-value)
2055 (tests `((eq ,n-key ',keyword)
2056 (setq ,n-value ,n-value-temp)))))))
2057
2058 (unless allowp
2059 (temps n-allowp n-losep)
2060 (tests `((eq ,n-key :allow-other-keys)
2061 (setq ,n-allowp ,n-value-temp)))
2062 (tests `(t
2063 (setq ,n-losep ,n-index))))
2064
2065 (body
2066 `(when (oddp ,n-count)
2067 (%odd-keyword-arguments-error)))
2068
2069 (body
2070 `(locally
2071 (declare (optimize (safety 0)))
2072 (loop
2073 (when (minusp ,n-index) (return))
2074 (setf ,n-value-temp (%more-arg ,n-context ,n-index))
2075 (decf ,n-index)
2076 (setq ,n-key (%more-arg ,n-context ,n-index))
2077 (cond ,@(tests))
2078 (decf ,n-index))))
2079
2080 (unless allowp
2081 (body `(when (and ,n-losep (not ,n-allowp))
2082 (%unknown-keyword-argument-error
2083 (%more-arg ,n-context ,n-losep))))))))
2084
2085 (let ((ep (ir1-convert-lambda-body
2086 `((let ,(temps)
2087 ,@(body)
2088 (%funcall ,(optional-dispatch-main-entry res)
2089 . ,(arg-vals))))
2090 (arg-vars))))
2091 (setf (optional-dispatch-more-entry res) ep))))
2092
2093 (undefined-value))
2094
2095
2096 ;;; IR1-Convert-More -- Internal
2097 ;;;
2098 ;;; Called by IR1-Convert-Hairy-Args when we run into a rest or keyword arg.
2099 ;;; The arguments are similar to that function, but we split off any rest arg
2100 ;;; and pass it in separately. Rest is the rest arg var, or NIL if there is no
2101 ;;; rest arg. Keys is a list of the keyword argument vars.
2102 ;;;
2103 ;;; When there are keyword arguments, we introduce temporary gensym
2104 ;;; variables to hold the values while keyword defaulting is in progress to get
2105 ;;; the required sequential binding semantics.
2106 ;;;
2107 ;;; This gets interesting mainly when there are keyword arguments with
2108 ;;; supplied-p vars or non-constant defaults. In either case, pass in a
2109 ;;; supplied-p var. If the default is non-constant, we introduce an IF in the
2110 ;;; main entry that tests the supplied-p var and decides whether to evaluate
2111 ;;; the default or not. In this case, the real incoming value is NIL, so we
2112 ;;; must union NULL with the declared type when computing the type for the main
2113 ;;; entry's argument.
2114 ;;;
2115 (defun ir1-convert-more (res default-vars default-vals entry-vars entry-vals
2116 rest more-context more-count keys supplied-p-p
2117 body aux-vars aux-vals cont)
2118 (declare (type optional-dispatch res)
2119 (list default-vars default-vals entry-vars entry-vals keys body
2120 aux-vars aux-vals)
2121 (type (or continuation null) cont))
2122 (collect ((main-vars (reverse default-vars))
2123 (main-vals default-vals cons)
2124 (bind-vars)
2125 (bind-vals))
2126 (when rest
2127 (main-vars rest)
2128 (main-vals '()))
2129 (when more-context
2130 (main-vars more-context)
2131 (main-vals nil)
2132 (main-vars more-count)
2133 (main-vals 0))
2134
2135 (dolist (key keys)
2136 (let* ((info (lambda-var-arg-info key))
2137 (default (arg-info-default info))
2138 (hairy-default (not (constantp default)))
2139 (supplied-p (arg-info-supplied-p info))
2140 (n-val (with-standard-io-syntax
2141 (make-symbol (format nil "~A-DEFAULTING-TEMP"
2142 (leaf-name key)))))
2143 (key-type (leaf-type key))
2144 (val-temp (make-lambda-var
2145 :name n-val
2146 :type (if hairy-default
2147 (type-union key-type (specifier-type 'null))
2148 key-type))))
2149 (main-vars val-temp)
2150 (bind-vars key)
2151 (cond ((or hairy-default supplied-p)
2152 (let* ((n-supplied (gensym))
2153 (supplied-temp (make-lambda-var :name n-supplied)))
2154 (unless supplied-p
2155 (setf (arg-info-supplied-p info) supplied-temp))
2156 (when hairy-default
2157 (setf (arg-info-default info) nil))
2158 (main-vars supplied-temp)
2159 (cond (hairy-default
2160 (main-vals nil nil)
2161 (bind-vals `(if ,n-supplied ,n-val ,default)))
2162 (t
2163 (main-vals default nil)
2164 (bind-vals n-val)))
2165 (when supplied-p
2166 (bind-vars supplied-p)
2167 (bind-vals n-supplied))))
2168 (t
2169 (main-vals (arg-info-default info))
2170 (bind-vals n-val)))))
2171
2172 (let* ((main-entry (ir1-convert-lambda-body body (main-vars)
2173 (append (bind-vars) aux-vars)
2174 (append (bind-vals) aux-vals)
2175 t
2176 cont))
2177 (last-entry (convert-optional-entry main-entry default-vars
2178 (main-vals) ())))
2179 (setf (optional-dispatch-main-entry res) main-entry)
2180 (convert-more-entry res entry-vars entry-vals rest more-context keys)
2181
2182 (push (if supplied-p-p
2183 (convert-optional-entry last-entry entry-vars entry-vals ())
2184 last-entry)
2185 (optional-dispatch-entry-points res))
2186 last-entry)))
2187
2188
2189 ;;; IR1-Convert-Hairy-Args -- Internal
2190 ;;;
2191 ;;; This function generates the entry point functions for the
2192 ;;; optional-dispatch Res. We accomplish this by recursion on the list of
2193 ;;; arguments, analyzing the arglist on the way down and generating entry
2194 ;;; points on the way up.
2195 ;;;
2196 ;;; Default-Vars is a reversed list of all the argument vars processed so
2197 ;;; far, including supplied-p vars. Default-Vals is a list of the names of the
2198 ;;; Default-Vars.
2199 ;;;
2200 ;;; Entry-Vars is a reversed list of processed argument vars, excluding
2201 ;;; supplied-p vars. Entry-Vals is a list things that can be evaluated to get
2202 ;;; the values for all the vars from the Entry-Vars. It has the var name for
2203 ;;; each required or optional arg, and has T for each supplied-p arg.
2204 ;;;
2205 ;;; Vars is a list of the Lambda-Var structures for arguments that haven't
2206 ;;; been processed yet. Supplied-p-p is true if a supplied-p argument has
2207 ;;; already been processed; only in this case are the Default-XXX and Entry-XXX
2208 ;;; different.
2209 ;;;
2210 ;;; The result at each point is a lambda which should be called by the above
2211 ;;; level to default the remaining arguments and evaluate the body. We cause
2212 ;;; the body to be evaluated by converting it and returning it as the result
2213 ;;; when the recursion bottoms out.
2214 ;;;
2215 ;;; Each level in the recursion also adds its entry point function to the
2216 ;;; result Optional-Dispatch. For most arguments, the defaulting function and
2217 ;;; the entry point function will be the same, but when supplied-p args are
2218 ;;; present they may be different.
2219 ;;;
2220 ;;; When we run into a rest or keyword arg, we punt out to
2221 ;;; IR1-Convert-More, which finishes for us in this case.
2222 ;;;
2223 (defun ir1-convert-hairy-args (res default-vars default-vals
2224 entry-vars entry-vals
2225 vars supplied-p-p body aux-vars
2226 aux-vals cont)
2227 (declare (type optional-dispatch res)
2228 (list default-vars default-vals entry-vars entry-vals vars body
2229 aux-vars aux-vals)
2230 (type (or continuation null) cont))
2231 (cond ((not vars)
2232 (if (optional-dispatch-keyp res)
2233 ;;
2234 ;; Handle &key with no keys...
2235 (ir1-convert-more res default-vars default-vals
2236 entry-vars entry-vals
2237 nil nil nil vars supplied-p-p body aux-vars
2238 aux-vals cont)
2239 (let ((fun (ir1-convert-lambda-body body (reverse default-vars)
2240 aux-vars aux-vals t cont)))
2241 (setf (optional-dispatch-main-entry res) fun)
2242 (push (if supplied-p-p
2243 (convert-optional-entry fun entry-vars entry-vals ())
2244 fun)
2245 (optional-dispatch-entry-points res))
2246 fun)))
2247 ((not (lambda-var-arg-info (first vars)))
2248 (let* ((arg (first vars))
2249 (nvars (cons arg default-vars))
2250 (nvals (cons (leaf-name arg) default-vals)))
2251 (ir1-convert-hairy-args res nvars nvals nvars nvals
2252 (rest vars) nil body aux-vars aux-vals
2253 cont)))
2254 (t
2255 (let* ((arg (first vars))
2256 (info (lambda-var-arg-info arg))
2257 (kind (arg-info-kind info)))
2258 (ecase kind
2259 (:optional
2260 (let ((ep (generate-optional-default-entry
2261 res default-vars default-vals
2262 entry-vars entry-vals vars supplied-p-p body
2263 aux-vars aux-vals cont)))
2264 (push (if supplied-p-p
2265 (convert-optional-entry ep entry-vars entry-vals ())
2266 ep)
2267 (optional-dispatch-entry-points res))
2268 ep))
2269 (:rest
2270 (ir1-convert-more res default-vars default-vals
2271 entry-vars entry-vals
2272 arg nil nil (rest vars) supplied-p-p body
2273 aux-vars aux-vals cont))
2274 (:more-context
2275 (ir1-convert-more res default-vars default-vals
2276 entry-vars entry-vals
2277 nil arg (second vars) (cddr vars) supplied-p-p
2278 body aux-vars aux-vals cont))
2279 (:keyword
2280 (ir1-convert-more res default-vars default-vals
2281 entry-vars entry-vals
2282 nil nil nil vars supplied-p-p body aux-vars
2283 aux-vals cont)))))))
2284
2285
2286 ;;; IR1-Convert-Hairy-Lambda -- Internal
2287 ;;;
2288 ;;; This function deals with the case where we have to make an
2289 ;;; Optional-Dispatch to represent a lambda. We cons up the result and call
2290 ;;; IR1-Convert-Hairy-Args to do the work. When it is done, we figure out the
2291 ;;; min-args and max-args.
2292 ;;;
2293 (defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont)
2294 (declare (list body vars aux-vars aux-vals) (type continuation cont))
2295 (let ((res (make-optional-dispatch :arglist vars :allowp allowp
2296 :keyp keyp))
2297 (min (or (position-if #'lambda-var-arg-info vars) (length vars))))
2298 (push res (component-new-functions *current-component*))
2299 (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals
2300 cont)
2301 (setf (optional-dispatch-min-args res) min)
2302 (setf (optional-dispatch-max-args res)
2303 (+ (1- (length (optional-dispatch-entry-points res))) min))
2304
2305 (flet ((frob (ep)
2306 (when ep
2307 (setf (functional-kind ep) :optional)
2308 (setf (leaf-ever-used ep) t)
2309 (setf (lambda-optional-dispatch ep) res))))
2310 (dolist (ep (optional-dispatch-entry-points res)) (frob ep))
2311 (frob (optional-dispatch-more-entry res))
2312 (frob (optional-dispatch-main-entry res)))
2313
2314 res))
2315
2316
2317
2318 (declaim (end-block))
2319
2320 ;;;; Control special forms:
2321
2322 (def-ir1-translator progn ((&rest forms) start cont)
2323 "Progn Form*
2324 Evaluates each Form in order, returing the values of the last form. With no
2325 forms, returns NIL."
2326 (ir1-convert-progn-body start cont forms))
2327
2328 (def-ir1-translator if ((test then &optional else) start cont)
2329 "If Predicate Then [Else]
2330 If Predicate evaluates to non-null, evaluate Then and returns its values,
2331 otherwise evaluate Else and return its values. Else defaults to NIL."
2332 (let* ((pred (make-continuation))
2333 (then-cont (make-continuation))
2334 (then-block (continuation-starts-block then-cont))
2335 (else-cont (make-continuation))
2336 (else-block (continuation-starts-block else-cont))
2337 (dummy-cont (make-continuation))
2338 (node (make-if :test pred
2339 :consequent then-block :alternative else-block)))
2340 (setf (continuation-dest pred) node)
2341 (ir1-convert start pred test)
2342 (prev-link node pred)
2343 (use-continuation node dummy-cont)
2344
2345 (let ((start-block (continuation-block pred)))
2346 (setf (block-last start-block) node)
2347 (continuation-starts-block cont)
2348
2349 (link-blocks start-block then-block)
2350 (link-blocks start-block else-block)
2351
2352 (ir1-convert then-cont cont then)
2353 (ir1-convert else-cont cont else))))
2354
2355
2356 ;;;; Block and Tagbody:
2357 ;;;
2358 ;;; We make an Entry node to mark the start and a :Entry cleanup to
2359 ;;; mark its extent. When doing Go or Return-From, we emit an Exit node.
2360 ;;;
2361
2362 ;;; Block IR1 convert -- Internal
2363 ;;;
2364 ;;; Make a :entry cleanup and emit an Entry node, then convert the body in
2365 ;;; the modified environment. We make Cont start a block now, since if it was
2366 ;;; done later, the block would be in the wrong environment.
2367 ;;;
2368 (def-ir1-translator block ((name &rest forms) start cont)
2369 "Block Name Form*
2370 Evaluate the Forms as a PROGN. Within the lexical scope of the body,
2371 (RETURN-FROM Name Value-Form) can be used to exit the form, returning the
2372 result of Value-Form."
2373 (unless (symbolp name)
2374 (compiler-error _N"Block name is not a symbol: ~S." name))
2375 (continuation-starts-block cont)
2376 (let* ((dummy (make-continuation))
2377 (entry (make-entry))
2378 (cleanup (make-cleanup :kind :block :mess-up entry)))
2379 (push entry (lambda-entries (lexenv-lambda *lexical-environment*)))
2380 (setf (entry-cleanup entry) cleanup)
2381 (prev-link entry start)
2382 (use-continuation entry dummy)
2383 (let* ((cont-ref (make-cont-ref :cont cont))
2384 (*lexical-environment*
2385 (make-lexenv :blocks (list (cons name (list entry cont-ref)))
2386 :cleanup cleanup)))
2387 (push cont-ref (continuation-refs cont))
2388 (ir1-convert-progn-body dummy cont forms))))
2389
2390 ;;; We make Cont start a block just so that it will have a block assigned.
2391 ;;; People assume that when they pass a continuation into IR1-Convert as Cont,
2392 ;;; it will have a block when it is done.
2393 ;;;
2394 (def-ir1-translator return-from ((name &optional value)
2395 start cont)
2396 "Return-From Block-Name Value-Form
2397 Evaluate the Value-Form, returning its values from the lexically enclosing
2398 BLOCK Block-Name. This is constrained to be used only within the dynamic
2399 extent of the BLOCK."
2400 (continuation-starts-block cont)
2401 (let* ((found (or (lexenv-find name blocks)
2402 (compiler-error _N"Return for unknown block: ~S." name)))
2403 (value-cont (make-continuation))
2404 (entry (first found))
2405 (exit (make-exit :entry entry :value value-cont)))
2406 (push exit (entry-exits entry))
2407 (setf (continuation-dest value-cont) exit)
2408 (ir1-convert start value-cont value)
2409 (prev-link exit value-cont)
2410 (note-dfo-dependency start entry)
2411 (use-continuation exit (cont-ref-cont (second found)))))
2412
2413
2414 ;;; Parse-Tagbody -- Internal
2415 ;;;
2416 ;;; Return a list of the segments of a tagbody. Each segment looks like
2417 ;;; (<tag> <form>* (go <next tag>)). That is, we break up the tagbody into
2418 ;;; segments of non-tag statements, and explicitly represent the drop-through
2419 ;;; with a GO. The first segment has a dummy NIL tag, since it represents code
2420 ;;; before the first tag. The last segment (which may also be the first
2421 ;;; segment) ends in NIL rather than a GO.
2422 ;;;
2423 (defun parse-tagbody (body)
2424 (declare (list body))
2425 (collect ((segments))
2426 (let ((current (cons nil body)))
2427 (loop
2428 (let ((tag-pos (position-if-not #'listp current :start 1)))
2429 (unless tag-pos
2430 (segments `(,@current nil))
2431 (return))
2432 (let ((tag (elt current tag-pos)))
2433 (when (assoc tag (segments))
2434 (compiler-error _N"Repeated tagbody tag: ~S." tag))
2435 (unless (or (symbolp tag) (integerp tag))
2436 (compiler-error _N"Illegal tagbody statement: ~S." tag))
2437 (segments `(,@(subseq current 0 tag-pos) (go ,tag))))
2438 (setq current (nthcdr tag-pos current)))))
2439 (segments)))
2440
2441
2442 ;;; Tagbody IR1 convert -- Internal
2443 ;;;
2444 ;;; Set up the cleanup, emitting the entry node. Then make a block for each
2445 ;;; tag, building up the tag list for LEXENV-TAGS as we go. Finally, convert
2446 ;;; each segment with the precomputed Start and Cont values.
2447 ;;;
2448 (def-ir1-translator tagbody ((&rest statements) start cont)
2449 "Tagbody {Tag | Statement}*
2450 Define tags for used with GO. The Statements are evaluated in order
2451 (skipping Tags) and NIL is returned. If a statement contains a GO to a
2452 defined Tag within the lexical scope of the form, then control is transferred
2453 to the next statement following that tag. A Tag must an integer or a
2454 symbol. A statement must be a list. Other objects are illegal within the
2455 body."
2456 (continuation-starts-block cont)
2457 (let* ((dummy (make-continuation))
2458 (entry (make-entry))
2459 (segments (parse-tagbody statements))
2460 (cleanup (make-cleanup :kind :tagbody :mess-up entry)))
2461 (push entry (lambda-entries (lexenv-lambda *lexical-environment*)))
2462 (setf (entry-cleanup entry) cleanup)
2463 (prev-link entry start)
2464 (use-continuation entry dummy)
2465
2466 (collect ((tags)
2467 (starts)
2468 (conts))
2469 (starts dummy)
2470 (dolist (segment (rest segments))
2471 (let* ((tag-cont (make-continuation))
2472 (tag-cont-ref (make-cont-ref :cont tag-cont)))
2473 (conts tag-cont)
2474 (starts tag-cont)
2475 (continuation-starts-block tag-cont)
2476 (tags (list (car segment) entry tag-cont-ref))))
2477 (conts cont)
2478
2479 (let ((*lexical-environment*
2480 (make-lexenv :cleanup cleanup :tags (tags))))
2481 (mapc #'(lambda (segment start cont)
2482 (ir1-convert-progn-body start cont (rest segment)))
2483 segments (starts) (conts))))))
2484
2485
2486 ;;; Go IR1 convert -- Internal
2487 ;;;
2488 ;;; Emit an Exit node without any value.
2489 ;;;
2490 (def-ir1-translator go ((tag) start cont)
2491 "Go Tag
2492 Transfer control to the named Tag in the lexically enclosing TAGBODY. This
2493 is constrained to be used only within the dynamic extent of the TAGBODY."
2494 (continuation-starts-block cont)
2495 (let* ((found (or (lexenv-find tag tags :test #'eql)
2496 (compiler-error _N"Go to nonexistent tag: ~S." tag)))
2497 (entry (first found))
2498 (exit (make-exit :entry entry)))
2499 (push exit (entry-exits entry))
2500 (prev-link exit start)
2501 (note-dfo-dependency start entry)
2502 (use-continuation exit (cont-ref-cont (second found)))))
2503
2504
2505 ;;;; Translators for compiler-magic special forms:
2506
2507 (def-ir1-translator compiler-let ((bindings &rest body) start cont)
2508 (collect ((vars)
2509 (values))
2510 (dolist (bind bindings)
2511 (typecase bind
2512 (symbol
2513 (vars bind)
2514 (values nil))
2515 (list
2516 (unless (= (length bind) 2)
2517 (compiler-error _N"Bad compiler-let binding spec: ~S." bind))
2518 (vars (first bind))
2519 (values (eval (second bind))))
2520 (t
2521 (compiler-error _N"Bad compiler-let binding spec: ~S." bind))))
2522 (progv (vars) (values)
2523 (ir1-convert-progn-body start cont body))))
2524
2525
2526 ;;; DO-EVAL-WHEN-STUFF -- Interface
2527 ;;;
2528 ;;; Do stuff to do an EVAL-WHEN. This is split off from the IR1 convert
2529 ;;; method so that it can be shared by the special-case top-level form
2530 ;;; processing code. We play with the dynamic environment and eval stuff, then
2531 ;;; call Fun with a list of forms to be processed at load time.
2532 ;;;
2533
2534 (defun do-eval-when-stuff (situations body fun &optional toplevel-p)
2535 (when (or (not (listp situations))
2536 (set-difference situations
2537 '(compile load eval
2538 :compile-toplevel :load-toplevel :execute)))
2539 (compiler-error _N"Bad Eval-When situation list: ~S." situations))
2540
2541 (if toplevel-p
2542 ;; Can only get here from compile-file
2543 (progn
2544 (when (intersection '(compile :compile-toplevel) situations)
2545 (eval `(progn ,@body)))
2546 ;; Maybe generate code for load-time or run-time eval
2547 (if (or (intersection '(:load-toplevel load) situations)
2548 (and *converting-for-interpreter*
2549 (intersection '(:execute eval) situations)))
2550 (funcall fun body)
2551 (funcall fun '(nil))))
2552 ;; Not toplevel, only :execute counts.
2553 (if (intersection '(eval :execute) situations)
2554 (funcall fun body)
2555 (funcall fun '(nil)))))
2556
2557 (def-ir1-translator eval-when ((situations &rest body) start cont)
2558 "EVAL-WHEN (Situation*) Form*
2559 Evaluate the Forms in the specified Situations, any of :COMPILE-TOPLEVEL,
2560 :LOAD-TOPLEVEL, :EXECUTE."
2561 (do-eval-when-stuff situations body
2562 #'(lambda (forms)
2563 (ir1-convert-progn-body start cont forms))))
2564
2565
2566 (defun make-macrolet-environment (lexenv)
2567 (flet ((local-function-p (fun)
2568 (functional-p (cdr fun)))
2569 (local-variable-p (var)
2570 ;; ??? What is that CT-A-VAL structure that's mentioned in the
2571 ;; description of the VARIABLES slot of LEXENV structure?
2572 ;; Maybe this stuff has to be removed, too.
2573 (leaf-p (cdr var))))
2574 (let ((env (copy-lexenv lexenv)))
2575 ;; CLHS says in the text of its MACROLET description that
2576 ;; consequences are undefined if a local macro definition refers
2577 ;; to local variable or function bindings. A later example
2578 ;; clearly implies these are not accessible. SBCL apparently
2579 ;; follows the example in CLHS. Let's do the same.
2580 (setf (lexenv-functions env)
2581 (remove-if #'local-function-p (lexenv-functions env)))
2582 (setf (lexenv-variables env)
2583 (remove-if #'local-variable-p (lexenv-variables env)))
2584 (setf (lexenv-blocks env) nil)
2585 (setf (lexenv-tags env) nil)
2586 env)))
2587
2588 ;;; DO-MACROLET-STUFF -- Interface
2589 ;;;
2590 ;;; Like DO-EVAL-WHEN-STUFF, only do a macrolet. Fun is not passed any
2591 ;;; arguments.
2592 ;;;
2593 (defun do-macrolet-stuff (definitions fun &optional decls (cont (make-continuation)))
2594 (declare (list definitions) (type function fun))
2595 (let ((whole (gensym))
2596 (environment (gensym)))
2597 (collect ((new-fenv))
2598 (dolist (def definitions)
2599 (let* ((name (first def))
2600 (*current-function-names* (list name))
2601 (arglist (second def))
2602 (body (cddr def)))
2603 (multiple-value-bind
2604 (body local-decs)
2605 (lisp::parse-defmacro arglist whole body name 'macrolet
2606 :environment environment)
2607 (unless (symbolp name)
2608 (compiler-error _N"Macro name ~S is not a symbol." name))
2609 (unless (listp arglist)
2610 (compiler-error _N"Local macro ~S has argument list that is not a list: ~S."
2611 name arglist))
2612 (when (< (length def) 3)
2613 (compiler-error
2614 _N"Local macro ~S is too short to be a legal definition." name))
2615 (new-fenv `(,(first def) macro .
2616 ,(eval:internal-eval
2617 `(lambda (,whole ,environment)
2618 ,@local-decs
2619 (block ,name ,body))
2620 t
2621 (make-macrolet-environment *lexical-environment*)))))))
2622
2623 (let* ((*lexical-environment* (make-lexenv :functions (new-fenv)))
2624 (*lexical-environment* (process-declarations decls nil (new-fenv) cont)))
2625 (funcall fun))))
2626
2627 (undefined-value))
2628
2629
2630 (def-ir1-translator macrolet ((definitions &parse-body (body decls)) start cont)
2631 "MACROLET ({(Name Lambda-List Form*)}*) Body-Form*
2632 Evaluate the Body-Forms in an environment with the specified local macros
2633 defined. Name is the local macro name, Lambda-List is the DEFMACRO style
2634 destructuring lambda list, and the Forms evaluate to the expansion."
2635 (do-macrolet-stuff definitions
2636 #'(lambda ()
2637 (ir1-convert-progn-body start cont body))
2638 decls
2639 cont))
2640
2641
2642 ;;; COMPILER-OPTION-BIND
2643 ;;;
2644 (def-ir1-translator compiler-option-bind ((bindings &body body) start cont)
2645 "Compiler-Option-Bind ({(Name Value-Form)}*) Body-Form*
2646 Establish the specified compiler options for the (lexical) duration of
2647 the body. The Value-Forms are evaluated at compile time."
2648 (let ((*lexical-environment*
2649 (make-lexenv :options
2650 (mapcar #'(lambda (binding)
2651 (unless (and (listp binding)
2652 (cdr binding)
2653 (listp (cdr binding))
2654 (null (cddr binding)))
2655 (compiler-error _N"Bogus binding for ~
2656 COMPILER-OPTION-BIND: ~S"
2657 binding))
2658 (cons (car binding)
2659 (eval (cadr binding))))
2660 bindings))))
2661 (ir1-convert-progn-body start cont body)))
2662
2663
2664 ;;;; %Primitive:
2665 ;;;
2666