1 ;;;; miscellaneous types and macros used in writing the compiler
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 (declaim (special *wild-type* *universal-type* *compiler-error-context*))
16 ;;; An INLINEP value describes how a function is called. The values
17 ;;; have these meanings:
18 ;;; NIL No declaration seen: do whatever you feel like, but don't
19 ;;; dump an inline expansion.
20 ;;; :NOTINLINE NOTINLINE declaration seen: always do full function call.
21 ;;; :INLINE INLINE declaration seen: save expansion, expanding to it
24 ;;; Retain expansion, but only use it opportunistically.
25 (deftype inlinep () '(member :inline :maybe-inline :notinline nil))
27 ;;;; source-hacking defining forms
29 ;;; to be passed to PARSE-DEFMACRO when we want compiler errors
30 ;;; instead of real errors
31 #!-sb-fluid (declaim (inline convert-condition-into-compiler-error))
32 (defun convert-condition-into-compiler-error (datum &rest stuff)
34 (apply #'compiler-error datum stuff)
37 (apply #'make-condition datum stuff)
40 ;;; Parse a DEFMACRO-style lambda-list, setting things up so that a
41 ;;; compiler error happens if the syntax is invalid.
43 ;;; Define a function that converts a special form or other magical
44 ;;; thing into IR1. LAMBDA-LIST is a defmacro style lambda list.
45 ;;; START-VAR and CONT-VAR are bound to the start and result
46 ;;; continuations for the resulting IR1. KIND is the function kind to
47 ;;; associate with NAME.
48 (defmacro def-ir1-translator (name (lambda-list start-var cont-var
49 &key (kind :special-form))
51 (let ((fn-name (symbolicate "IR1-CONVERT-" name))
54 (multiple-value-bind (body decls doc)
55 (parse-defmacro lambda-list n-form body name "special form"
57 :error-fun 'convert-condition-into-compiler-error)
59 (declaim (ftype (function (continuation continuation t) (values))
61 (defun ,fn-name (,start-var ,cont-var ,n-form)
62 (let ((,n-env *lexenv*))
67 `((setf (fdocumentation ',name 'function) ,doc)))
68 ;; FIXME: Evidently "there can only be one!" -- we overwrite any
69 ;; other :IR1-CONVERT value. This deserves a warning, I think.
70 (setf (info :function :ir1-convert ',name) #',fn-name)
71 (setf (info :function :kind ',name) ,kind)
72 ;; It's nice to do this for error checking in the target
73 ;; SBCL, but it's not nice to do this when we're running in
74 ;; the cross-compilation host Lisp, which owns the
75 ;; SYMBOL-FUNCTION of its COMMON-LISP symbols.
77 ,@(when (eq kind :special-form)
78 `((setf (symbol-function ',name)
80 (declare (ignore rest))
81 (error "can't FUNCALL the SYMBOL-FUNCTION of ~
82 special forms")))))))))
84 ;;; (This is similar to DEF-IR1-TRANSLATOR, except that we pass if the
85 ;;; syntax is invalid.)
87 ;;; Define a macro-like source-to-source transformation for the
88 ;;; function NAME. A source transform may "pass" by returning a
89 ;;; non-nil second value. If the transform passes, then the form is
90 ;;; converted as a normal function call. If the supplied arguments are
91 ;;; not compatible with the specified LAMBDA-LIST, then the transform
92 ;;; automatically passes.
94 ;;; Source transforms may only be defined for functions. Source
95 ;;; transformation is not attempted if the function is declared
96 ;;; NOTINLINE. Source transforms should not examine their arguments.
97 ;;; If it matters how the function is used, then DEFTRANSFORM should
98 ;;; be used to define an IR1 transformation.
100 ;;; If the desirability of the transformation depends on the current
101 ;;; OPTIMIZE parameters, then the POLICY macro should be used to
102 ;;; determine when to pass.
103 (defmacro define-source-transform (name lambda-list &body body)
110 (apply #'symbolicate "SOURCE-TRANSFORM" (pieces)))
111 (symbolicate "SOURCE-TRANSFORM-" name)))
114 (multiple-value-bind (body decls)
115 (parse-defmacro lambda-list n-form body name "form"
117 :error-fun `(lambda (&rest stuff)
118 (declare (ignore stuff))
119 (return-from ,fn-name
122 (defun ,fn-name (,n-form)
123 (let ((,n-env *lexenv*))
126 (setf (info :function :source-transform ',name) #',fn-name)))))
128 ;;;; boolean attribute utilities
130 ;;;; We need to maintain various sets of boolean attributes for known
131 ;;;; functions and VOPs. To save space and allow for quick set
132 ;;;; operations, we represent the attributes as bits in a fixnum.
134 (deftype attributes () 'fixnum)
136 (eval-when (:compile-toplevel :load-toplevel :execute)
138 ;;; Given a list of attribute names and an alist that translates them
139 ;;; to masks, return the OR of the masks.
140 (defun compute-attribute-mask (names alist)
141 (collect ((res 0 logior))
143 (let ((mask (cdr (assoc name alist))))
145 (error "unknown attribute name: ~S" name))
151 ;;; Define a new class of boolean attributes, with the attributes
152 ;;; having the specified Attribute-Names. Name is the name of the
153 ;;; class, which is used to generate some macros to manipulate sets of
156 ;;; NAME-attributep attributes attribute-name*
157 ;;; Return true if one of the named attributes is present, false
158 ;;; otherwise. When set with SETF, updates the place Attributes
159 ;;; setting or clearing the specified attributes.
161 ;;; NAME-attributes attribute-name*
162 ;;; Return a set of the named attributes.
164 ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
165 ;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
167 ;;; (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
168 ;;; arrangement, in order to get it to work in cross-compilation. This
169 ;;; duplication should be removed, perhaps by rewriting the macro in a
170 ;;; more cross-compiler-friendly way, or perhaps just by using some
171 ;;; (MACROLET ((FROB ..)) .. FROB .. FROB) form, but I don't want to
172 ;;; do it now, because the system isn't running yet, so it'd be too
173 ;;; hard to check that my changes were correct -- WHN 19990806
174 (def!macro def-boolean-attribute (name &rest attribute-names)
176 (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
177 (test-name (symbolicate name "-ATTRIBUTEP")))
179 (do ((mask 1 (ash mask 1))
180 (names attribute-names (cdr names)))
182 (alist (cons (car names) mask)))
186 (eval-when (:compile-toplevel :load-toplevel :execute)
187 (defparameter ,translations-name ',(alist)))
189 (defmacro ,test-name (attributes &rest attribute-names)
190 "Automagically generated boolean attribute test function. See
191 Def-Boolean-Attribute."
192 `(logtest ,(compute-attribute-mask attribute-names
194 (the attributes ,attributes)))
196 (define-setf-expander ,test-name (place &rest attributes
198 "Automagically generated boolean attribute setter. See
199 Def-Boolean-Attribute."
200 #-sb-xc-host (declare (type sb!c::lexenv env))
201 ;; FIXME: It would be better if &ENVIRONMENT arguments
202 ;; were automatically declared to have type LEXENV by the
203 ;; hairy-argument-handling code.
204 (multiple-value-bind (temps values stores set get)
205 (get-setf-expansion place env)
207 (error "multiple store variables for ~S" place))
208 (let ((newval (gensym))
210 (mask (compute-attribute-mask attributes
211 ,translations-name)))
212 (values `(,@temps ,n-place)
215 `(let ((,(first stores)
217 (logior ,n-place ,mask)
218 (logand ,n-place ,(lognot mask)))))
221 `(,',test-name ,n-place ,@attributes)))))
223 (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
224 "Automagically generated boolean attribute creation function. See
225 Def-Boolean-Attribute."
226 (compute-attribute-mask attribute-names ,translations-name))))))
227 ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
229 ;;; And now for some gratuitous pseudo-abstraction...
232 ;;; Return the union of all the sets of boolean attributes which are its
234 ;;; ATTRIBUTES-INTERSECTION
235 ;;; Return the intersection of all the sets of boolean attributes which
236 ;;; are its arguments.
238 ;;; True if the attributes present in Attr1 are identical to
240 (defmacro attributes-union (&rest attributes)
242 (logior ,@(mapcar (lambda (x) `(the attributes ,x)) attributes))))
243 (defmacro attributes-intersection (&rest attributes)
245 (logand ,@(mapcar (lambda (x) `(the attributes ,x)) attributes))))
246 (declaim (ftype (function (attributes attributes) boolean) attributes=))
247 #!-sb-fluid (declaim (inline attributes=))
248 (defun attributes= (attr1 attr2)
251 ;;;; lambda-list parsing utilities
253 ;;;; IR1 transforms, optimizers and type inferencers need to be able
254 ;;;; to parse the IR1 representation of a function call using a
255 ;;;; standard function lambda-list.
257 (eval-when (:compile-toplevel :load-toplevel :execute)
259 ;;; Given a DEFTRANSFORM-style lambda-list, generate code that parses
260 ;;; the arguments of a combination with respect to that lambda-list.
261 ;;; BODY is the the list of forms which are to be evaluated within the
262 ;;; bindings. ARGS is the variable that holds list of argument
263 ;;; continuations. ERROR-FORM is a form which is evaluated when the
264 ;;; syntax of the supplied arguments is incorrect or a non-constant
265 ;;; argument keyword is supplied. Defaults and other gunk are ignored.
266 ;;; The second value is a list of all the arguments bound. We make the
267 ;;; variables IGNORABLE so that we don't have to manually declare them
268 ;;; Ignore if their only purpose is to make the syntax work.
269 (defun parse-deftransform (lambda-list body args error-form)
270 (multiple-value-bind (req opt restp rest keyp keys allowp)
271 (parse-lambda-list lambda-list)
272 (let* ((min-args (length req))
273 (max-args (+ min-args (length opt)))
281 (binds `(,arg (nth ,(pos) ,args)))
285 (let ((var (if (atom arg) arg (first arg))))
287 (binds `(,var (nth ,(pos) ,args)))
292 (binds `(,rest (nthcdr ,(pos) ,args))))
295 (if (or (atom spec) (atom (first spec)))
296 (let* ((var (if (atom spec) spec (first spec)))
297 (key (keywordicate var)))
299 (binds `(,var (find-keyword-continuation ,n-keys ,key)))
301 (let* ((head (first spec))
305 (binds `(,var (find-keyword-continuation ,n-keys ,key)))
308 (let ((n-length (gensym))
309 (limited-legal (not (or restp keyp))))
311 `(let ((,n-length (length ,args))
312 ,@(when keyp `((,n-keys (nthcdr ,(pos) ,args)))))
314 ;; FIXME: should be PROPER-LIST-OF-LENGTH-P
316 `(<= ,min-args ,n-length ,max-args)
317 `(<= ,min-args ,n-length))
320 `((check-key-args-constant ,n-keys))
321 `((check-transform-keys ,n-keys ',(keywords))))))
324 (declare (ignorable ,@(vars)))
332 ;;; Define an IR1 transformation for NAME. An IR1 transformation
333 ;;; computes a lambda that replaces the function variable reference
334 ;;; for the call. A transform may pass (decide not to transform the
335 ;;; call) by calling the GIVE-UP-IR1-TRANSFORM function. LAMBDA-LIST
336 ;;; both determines how the current call is parsed and specifies the
337 ;;; LAMBDA-LIST for the resulting lambda.
339 ;;; We parse the call and bind each of the lambda-list variables to
340 ;;; the continuation which represents the value of the argument. When
341 ;;; parsing the call, we ignore the defaults, and always bind the
342 ;;; variables for unsupplied arguments to NIL. If a required argument
343 ;;; is missing, an unknown keyword is supplied, or an argument keyword
344 ;;; is not a constant, then the transform automatically passes. The
345 ;;; DECLARATIONS apply to the bindings made by DEFTRANSFORM at
346 ;;; transformation time, rather than to the variables of the resulting
347 ;;; lambda. Bound-but-not-referenced warnings are suppressed for the
348 ;;; lambda-list variables. The DOC-STRING is used when printing
349 ;;; efficiency notes about the defined transform.
351 ;;; Normally, the body evaluates to a form which becomes the body of
352 ;;; an automatically constructed lambda. We make LAMBDA-LIST the
353 ;;; lambda-list for the lambda, and automatically insert declarations
354 ;;; of the argument and result types. If the second value of the body
355 ;;; is non-null, then it is a list of declarations which are to be
356 ;;; inserted at the head of the lambda. Automatic lambda generation
357 ;;; may be inhibited by explicitly returning a lambda from the body.
359 ;;; The ARG-TYPES and RESULT-TYPE are used to create a function type
360 ;;; which the call must satisfy before transformation is attempted.
361 ;;; The function type specifier is constructed by wrapping (FUNCTION
362 ;;; ...) around these values, so the lack of a restriction may be
363 ;;; specified by omitting the argument or supplying *. The argument
364 ;;; syntax specified in the ARG-TYPES need not be the same as that in
365 ;;; the LAMBDA-LIST, but the transform will never happen if the
366 ;;; syntaxes can't be satisfied simultaneously. If there is an
367 ;;; existing transform for the same function that has the same type,
368 ;;; then it is replaced with the new definition.
370 ;;; These are the legal keyword options:
371 ;;; :RESULT - A variable which is bound to the result continuation.
372 ;;; :NODE - A variable which is bound to the combination node for the call.
373 ;;; :POLICY - A form which is supplied to the POLICY macro to determine
374 ;;; whether this transformation is appropriate. If the result
375 ;;; is false, then the transform automatically gives up.
377 ;;; - The name and argument/result types are actually forms to be
378 ;;; evaluated. Useful for getting closures that transform similar
381 ;;; - Don't actually instantiate a transform, instead just DEFUN
382 ;;; Name with the specified transform definition function. This
383 ;;; may be later instantiated with %DEFTRANSFORM.
385 ;;; - If supplied and non-NIL, note this transform as ``important,''
386 ;;; which means efficiency notes will be generated when this
387 ;;; transform fails even if INHIBIT-WARNINGS=SPEED (but not if
388 ;;; INHIBIT-WARNINGS>SPEED).
389 ;;; :WHEN {:NATIVE | :BYTE | :BOTH}
390 ;;; - Indicates whether this transform applies to native code,
391 ;;; byte-code or both (default :native.)
392 (defmacro deftransform (name (lambda-list &optional (arg-types '*)
394 &key result policy node defun-only
395 eval-name important (when :native))
396 &body body-decls-doc)
397 (when (and eval-name defun-only)
398 (error "can't specify both DEFUN-ONLY and EVAL-NAME"))
399 (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
400 (let ((n-args (gensym))
401 (n-node (or node (gensym)))
404 (decls-body `(,@decls ,@body)))
405 (multiple-value-bind (parsed-form vars)
406 (parse-deftransform lambda-list
408 `((unless (policy ,n-node ,policy)
409 (give-up-ir1-transform))
413 '(give-up-ir1-transform))
416 (let* ((,n-args (basic-combination-args ,n-node))
418 `((,result (node-cont ,n-node)))))
419 (multiple-value-bind (,n-lambda ,n-decls)
421 (if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda))
423 `(lambda ,',lambda-list
424 (declare (ignorable ,@',vars))
428 `(defun ,name ,@(when doc `(,doc)) ,@stuff)
430 ,(if eval-name name `',name)
432 ``(function ,,arg-types ,,result-type)
433 `'(function ,arg-types ,result-type))
436 ,(if important t nil)
439 ;;;; DEFKNOWN and DEFOPTIMIZER
441 ;;; This macro should be the way that all implementation independent
442 ;;; information about functions is made known to the compiler.
444 ;;; FIXME: The comment above suggests that perhaps some of my added
445 ;;; FTYPE declarations are in poor taste. Should I change my
446 ;;; declarations, or change the comment, or what?
448 ;;; FIXME: DEFKNOWN is needed only at build-the-system time. Figure
449 ;;; out some way to keep it from appearing in the target system.
451 ;;; Declare the function NAME to be a known function. We construct a
452 ;;; type specifier for the function by wrapping (FUNCTION ...) around
453 ;;; the ARG-TYPES and RESULT-TYPE. ATTRIBUTES is an unevaluated list
454 ;;; of boolean attributes of the function. These attributes are
458 ;;; May call functions that are passed as arguments. In order
459 ;;; to determine what other effects are present, we must find
460 ;;; the effects of all arguments that may be functions.
463 ;;; May incorporate arguments in the result or somehow pass
467 ;;; May fail to return during correct execution. Errors
471 ;;; The (default) worst case. Includes all the other bad
472 ;;; things, plus any other possible bad thing.
475 ;;; May be constant-folded. The function has no side effects,
476 ;;; but may be affected by side effects on the arguments. E.g.
480 ;;; May be eliminated if value is unused. The function has
481 ;;; no side effects except possibly CONS. If a function is
482 ;;; defined to signal errors, then it is not flushable even
483 ;;; if it is movable or foldable.
486 ;;; May be moved with impunity. Has no side effects except
487 ;;; possibly CONS, and is affected only by its arguments.
490 ;;; A true predicate likely to be open-coded. This is a
491 ;;; hint to IR1 conversion that it should ensure calls always
492 ;;; appear as an IF test. Not usually specified to DEFKNOWN,
493 ;;; since this is implementation dependent, and is usually
494 ;;; automatically set by the DEFINE-VOP :CONDITIONAL option.
496 ;;; NAME may also be a list of names, in which case the same
497 ;;; information is given to all the names. The keywords specify the
498 ;;; initial values for various optimizers that the function might
500 (defmacro defknown (name arg-types result-type &optional (attributes '(any))
502 (when (and (intersection attributes '(any call unwind))
503 (intersection attributes '(movable)))
504 (error "function cannot have both good and bad attributes: ~S" attributes))
506 `(%defknown ',(if (and (consp name)
507 (not (eq (car name) 'setf)))
510 '(function ,arg-types ,result-type)
511 (ir1-attributes ,@(if (member 'any attributes)
512 (union '(call unsafe unwind) attributes)
516 ;;; Create a function which parses combination args according to WHAT
517 ;;; and LAMBDA-LIST, where WHAT is either a function name or a list
518 ;;; (FUN-NAME KIND) and does some KIND of optimization.
520 ;;; The FUN-NAME must name a known function. LAMBDA-LIST is used
521 ;;; to parse the arguments to the combination as in DEFTRANSFORM. If
522 ;;; the argument syntax is invalid or there are non-constant keys,
523 ;;; then we simply return NIL.
525 ;;; The function is DEFUN'ed as FUNCTION-KIND-OPTIMIZER. Possible
526 ;;; kinds are DERIVE-TYPE, OPTIMIZER, LTN-ANNOTATE and IR2-CONVERT. If
527 ;;; a symbol is specified instead of a (FUNCTION KIND) list, then we
528 ;;; just do a DEFUN with the symbol as its name, and don't do anything
529 ;;; with the definition. This is useful for creating optimizers to be
530 ;;; passed by name to DEFKNOWN.
532 ;;; If supplied, NODE-VAR is bound to the combination node being
533 ;;; optimized. If additional VARS are supplied, then they are used as
534 ;;; the rest of the optimizer function's lambda-list. LTN-ANNOTATE
535 ;;; methods are passed an additional POLICY argument, and IR2-CONVERT
536 ;;; methods are passed an additional IR2-BLOCK argument.
537 (defmacro defoptimizer (what (lambda-list &optional (n-node (gensym))
540 (let ((name (if (symbolp what) what
541 (symbolicate (first what) "-" (second what) "-OPTIMIZER"))))
543 (let ((n-args (gensym)))
545 (defun ,name (,n-node ,@vars)
546 (let ((,n-args (basic-combination-args ,n-node)))
547 ,(parse-deftransform lambda-list body n-args
548 `(return-from ,name nil))))
550 `((setf (,(symbolicate "FUN-INFO-" (second what))
551 (fun-info-or-lose ',(first what)))
554 ;;;; IR groveling macros
556 ;;; Iterate over the blocks in a component, binding BLOCK-VAR to each
557 ;;; block in turn. The value of ENDS determines whether to iterate
558 ;;; over dummy head and tail blocks:
559 ;;; NIL -- Skip Head and Tail (the default)
560 ;;; :HEAD -- Do head but skip tail
561 ;;; :TAIL -- Do tail but skip head
562 ;;; :BOTH -- Do both head and tail
564 ;;; If supplied, RESULT-FORM is the value to return.
565 (defmacro do-blocks ((block-var component &optional ends result) &body body)
566 (unless (member ends '(nil :head :tail :both))
567 (error "losing ENDS value: ~S" ends))
568 (let ((n-component (gensym))
570 `(let* ((,n-component ,component)
571 (,n-tail ,(if (member ends '(:both :tail))
573 `(component-tail ,n-component))))
574 (do ((,block-var ,(if (member ends '(:both :head))
575 `(component-head ,n-component)
576 `(block-next (component-head ,n-component)))
577 (block-next ,block-var)))
578 ((eq ,block-var ,n-tail) ,result)
580 ;;; like DO-BLOCKS, only iterating over the blocks in reverse order
581 (defmacro do-blocks-backwards ((block-var component &optional ends result) &body body)
582 (unless (member ends '(nil :head :tail :both))
583 (error "losing ENDS value: ~S" ends))
584 (let ((n-component (gensym))
586 `(let* ((,n-component ,component)
587 (,n-head ,(if (member ends '(:both :head))
589 `(component-head ,n-component))))
590 (do ((,block-var ,(if (member ends '(:both :tail))
591 `(component-tail ,n-component)
592 `(block-prev (component-tail ,n-component)))
593 (block-prev ,block-var)))
594 ((eq ,block-var ,n-head) ,result)
597 ;;; Iterate over the uses of CONTINUATION, binding NODE to each one
600 ;;; XXX Could change it not to replicate the code someday perhaps...
601 (defmacro do-uses ((node-var continuation &optional result) &body body)
602 (once-only ((n-cont continuation))
603 `(ecase (continuation-kind ,n-cont)
607 (let ((,node-var (continuation-use ,n-cont)))
610 ((:block-start :deleted-block-start)
611 (dolist (,node-var (block-start-uses (continuation-block ,n-cont))
615 ;;; Iterate over the nodes in BLOCK, binding NODE-VAR to the each node
616 ;;; and CONT-VAR to the node's CONT. The only keyword option is
617 ;;; RESTART-P, which causes iteration to be restarted when a node is
618 ;;; deleted out from under us. (If not supplied, this is an error.)
620 ;;; In the forward case, we terminate on LAST-CONT so that we don't
621 ;;; have to worry about our termination condition being changed when
622 ;;; new code is added during the iteration. In the backward case, we
623 ;;; do NODE-PREV before evaluating the body so that we can keep going
624 ;;; when the current node is deleted.
626 ;;; When RESTART-P is supplied to DO-NODES, we start iterating over
627 ;;; again at the beginning of the block when we run into a
628 ;;; continuation whose block differs from the one we are trying to
629 ;;; iterate over, either because the block was split, or because a
630 ;;; node was deleted out from under us (hence its block is NIL.) If
631 ;;; the block start is deleted, we just punt. With RESTART-P, we are
632 ;;; also more careful about termination, re-indirecting the BLOCK-LAST
634 (defmacro do-nodes ((node-var cont-var block &key restart-p) &body body)
635 (let ((n-block (gensym))
636 (n-last-cont (gensym)))
637 `(let* ((,n-block ,block)
639 `((,n-last-cont (node-cont (block-last ,n-block))))))
640 (do* ((,node-var (continuation-next (block-start ,n-block))
643 ((eq (continuation-block ,cont-var) ,n-block)
644 (aver (continuation-next ,cont-var))
645 (continuation-next ,cont-var))
647 (let ((start (block-start ,n-block)))
648 (unless (eq (continuation-kind start)
651 (continuation-next start))))
652 `(continuation-next ,cont-var)))
653 (,cont-var (node-cont ,node-var) (node-cont ,node-var)))
657 `(eq ,node-var (block-last ,n-block))
658 `(eq ,cont-var ,n-last-cont))
660 ;;; like DO-NODES, only iterating in reverse order
661 (defmacro do-nodes-backwards ((node-var cont-var block) &body body)
662 (let ((n-block (gensym))
666 `(let* ((,n-block ,block)
667 (,n-start (block-start ,n-block))
668 (,n-last (block-last ,n-block)))
669 (do* ((,cont-var (node-cont ,n-last) ,n-next)
670 (,node-var ,n-last (continuation-use ,cont-var))
671 (,n-next (node-prev ,node-var) (node-prev ,node-var)))
674 (when (eq ,n-next ,n-start)
677 ;;; Bind the IR1 context variables to the values associated with NODE,
678 ;;; so that new, extra IR1 conversion related to NODE can be done
679 ;;; after the original conversion pass has finished.
680 (defmacro with-ir1-environment-from-node (node &rest forms)
681 `(flet ((closure-needing-ir1-environment-from-node ()
683 (%with-ir1-environment-from-node
685 #'closure-needing-ir1-environment-from-node)))
686 (defun %with-ir1-environment-from-node (node fun)
687 (declare (type node node) (type function fun))
688 (let ((*current-component* (node-component node))
689 (*lexenv* (node-lexenv node))
690 (*current-path* (node-source-path node)))
691 (aver-live-component *current-component*)
694 ;;; Bind the hashtables used for keeping track of global variables,
695 ;;; functions, etc. Also establish condition handlers.
696 (defmacro with-ir1-namespace (&body forms)
697 `(let ((*free-vars* (make-hash-table :test 'eq))
698 (*free-funs* (make-hash-table :test 'equal))
699 (*constants* (make-hash-table :test 'equal))
700 (*source-paths* (make-hash-table :test 'eq)))
701 (handler-bind ((compiler-error #'compiler-error-handler)
702 (style-warning #'compiler-style-warning-handler)
703 (warning #'compiler-warning-handler))
706 ;;; Look up NAME in the lexical environment namespace designated by
707 ;;; SLOT, returning the <value, T>, or <NIL, NIL> if no entry. The
708 ;;; :TEST keyword may be used to determine the name equality
710 (defmacro lexenv-find (name slot &key test)
711 (once-only ((n-res `(assoc ,name (,(symbolicate "LEXENV-" slot) *lexenv*)
712 :test ,(or test '#'eq))))
714 (values (cdr ,n-res) t)
717 ;;;; the EVENT statistics/trace utility
719 ;;; FIXME: This seems to be useful for troubleshooting and
720 ;;; experimentation, not for ordinary use, so it should probably
721 ;;; become conditional on SB-SHOW.
723 (eval-when (:compile-toplevel :load-toplevel :execute)
725 (defstruct (event-info (:copier nil))
726 ;; The name of this event.
727 (name (missing-arg) :type symbol)
728 ;; The string rescribing this event.
729 (description (missing-arg) :type string)
730 ;; The name of the variable we stash this in.
731 (var (missing-arg) :type symbol)
732 ;; The number of times this event has happened.
733 (count 0 :type fixnum)
734 ;; The level of significance of this event.
735 (level (missing-arg) :type unsigned-byte)
736 ;; If true, a function that gets called with the node that the event
738 (action nil :type (or function null)))
740 ;;; A hashtable from event names to event-info structures.
741 (defvar *event-info* (make-hash-table :test 'eq))
743 ;;; Return the event info for Name or die trying.
744 (declaim (ftype (function (t) event-info) event-info-or-lose))
745 (defun event-info-or-lose (name)
746 (let ((res (gethash name *event-info*)))
748 (error "~S is not the name of an event." name))
753 ;;; Return the number of times that EVENT has happened.
754 (declaim (ftype (function (symbol) fixnum) event-count))
755 (defun event-count (name)
756 (event-info-count (event-info-or-lose name)))
758 ;;; Return the function that is called when Event happens. If this is
759 ;;; null, there is no action. The function is passed the node to which
760 ;;; the event happened, or NIL if there is no relevant node. This may
761 ;;; be set with SETF.
762 (declaim (ftype (function (symbol) (or function null)) event-action))
763 (defun event-action (name)
764 (event-info-action (event-info-or-lose name)))
765 (declaim (ftype (function (symbol (or function null)) (or function null))
767 (defun %set-event-action (name new-value)
768 (setf (event-info-action (event-info-or-lose name))
770 (defsetf event-action %set-event-action)
772 ;;; Return the non-negative integer which represents the level of
773 ;;; significance of the event Name. This is used to determine whether
774 ;;; to print a message when the event happens. This may be set with
776 (declaim (ftype (function (symbol) unsigned-byte) event-level))
777 (defun event-level (name)
778 (event-info-level (event-info-or-lose name)))
779 (declaim (ftype (function (symbol unsigned-byte) unsigned-byte) %set-event-level))
780 (defun %set-event-level (name new-value)
781 (setf (event-info-level (event-info-or-lose name))
783 (defsetf event-level %set-event-level)
785 ;;; Define a new kind of event. Name is a symbol which names the event
786 ;;; and Description is a string which describes the event. Level
787 ;;; (default 0) is the level of significance associated with this
788 ;;; event; it is used to determine whether to print a Note when the
790 (defmacro defevent (name description &optional (level 0))
791 (let ((var-name (symbolicate "*" name "-EVENT-INFO*")))
792 `(eval-when (:compile-toplevel :load-toplevel :execute)
794 (make-event-info :name ',name
795 :description ',description
798 (setf (gethash ',name *event-info*) ,var-name)
801 ;;; the lowest level of event that will print a note when it occurs
802 (declaim (type unsigned-byte *event-note-threshold*))
803 (defvar *event-note-threshold* 1)
805 ;;; Note that the event with the specified Name has happened. Node is
806 ;;; evaluated to determine the node to which the event happened.
807 (defmacro event (name &optional node)
808 ;; Increment the counter and do any action. Mumble about the event if
810 `(%event ,(event-info-var (event-info-or-lose name)) ,node))
812 ;;; Print a listing of events and their counts, sorted by the count.
813 ;;; Events that happened fewer than Min-Count times will not be
814 ;;; printed. Stream is the stream to write to.
815 (declaim (ftype (function (&optional unsigned-byte stream) (values)) event-statistics))
816 (defun event-statistics (&optional (min-count 1) (stream *standard-output*))
818 (maphash (lambda (k v)
820 (when (>= (event-info-count v) min-count)
823 (dolist (event (sort (info) #'> :key #'event-info-count))
824 (format stream "~6D: ~A~%" (event-info-count event)
825 (event-info-description event)))
829 (declaim (ftype (function nil (values)) clear-event-statistics))
830 (defun clear-event-statistics ()
831 (maphash (lambda (k v)
833 (setf (event-info-count v) 0))
837 ;;;; functions on directly-linked lists (linked through specialized
838 ;;;; NEXT operations)
840 #!-sb-fluid (declaim (inline find-in position-in map-in))
842 ;;; Find Element in a null-terminated List linked by the accessor
843 ;;; function Next. Key, Test and Test-Not are the same as for generic
844 ;;; sequence functions.
851 (test-not nil not-p))
852 (when (and test-p not-p)
853 (error "It's silly to supply both :TEST and :TEST-NOT arguments."))
855 (do ((current list (funcall next current)))
857 (unless (funcall test-not (funcall key current) element)
859 (do ((current list (funcall next current)))
861 (when (funcall test (funcall key current) element)
864 ;;; Return the position of Element (or NIL if absent) in a
865 ;;; null-terminated List linked by the accessor function Next. Key,
866 ;;; Test and Test-Not are the same as for generic sequence functions.
867 (defun position-in (next
873 (test-not nil not-p))
874 (when (and test-p not-p)
875 (error "It's silly to supply both :TEST and :TEST-NOT arguments."))
877 (do ((current list (funcall next current))
880 (unless (funcall test-not (funcall key current) element)
882 (do ((current list (funcall next current))
885 (when (funcall test (funcall key current) element)
888 ;;; Map FUNCTION over the elements in a null-terminated LIST linked by the
889 ;;; accessor function NEXT, returning an ordinary list of the results.
890 (defun map-in (next function list)
892 (do ((current list (funcall next current)))
894 (res (funcall function current)))
897 ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
898 ;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
900 ;;; (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
901 ;;; arrangement, in order to get it to work in cross-compilation. This
902 ;;; duplication should be removed, perhaps by rewriting the macro in a more
903 ;;; cross-compiler-friendly way, or perhaps just by using some (MACROLET ((FROB
904 ;;; ..)) .. FROB .. FROB) form, or perhaps by completely eliminating this macro
905 ;;; and its partner PUSH-IN, but I don't want to do it now, because the system
906 ;;; isn't running yet, so it'd be too hard to check that my changes were
907 ;;; correct -- WHN 19990806
908 (def!macro deletef-in (next place item &environment env)
909 (multiple-value-bind (temps vals stores store access)
910 (get-setf-expansion place env)
912 (error "multiple store variables for ~S" place))
913 (let ((n-item (gensym))
917 `(let* (,@(mapcar #'list temps vals)
920 (if (eq ,n-place ,n-item)
921 (let ((,(first stores) (,next ,n-place)))
923 (do ((,n-prev ,n-place ,n-current)
924 (,n-current (,next ,n-place)
926 ((eq ,n-current ,n-item)
927 (setf (,next ,n-prev)
928 (,next ,n-current)))))
930 ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
932 ;;; Push ITEM onto a list linked by the accessor function NEXT that is
935 ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
936 ;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
938 ;;; (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
939 ;;; arrangement, in order to get it to work in cross-compilation. This
940 ;;; duplication should be removed, perhaps by rewriting the macro in a more
941 ;;; cross-compiler-friendly way, or perhaps just by using some (MACROLET ((FROB
942 ;;; ..)) .. FROB .. FROB) form, or perhaps by completely eliminating this macro
943 ;;; and its partner DELETEF-IN, but I don't want to do it now, because the
944 ;;; system isn't running yet, so it'd be too hard to check that my changes were
945 ;;; correct -- WHN 19990806
946 (def!macro push-in (next item place &environment env)
947 (multiple-value-bind (temps vals stores store access)
948 (get-setf-expansion place env)
950 (error "multiple store variables for ~S" place))
951 `(let (,@(mapcar #'list temps vals)
952 (,(first stores) ,item))
953 (setf (,next ,(first stores)) ,access)
956 ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
958 (defmacro position-or-lose (&rest args)
959 `(or (position ,@args)
960 (error "shouldn't happen?")))