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 'special-form-function
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 source-transform-lambda (lambda-list &body body)
104 (let ((n-form (gensym))
107 (multiple-value-bind (body decls)
108 (parse-defmacro lambda-list n-form body "source transform" "form"
110 :error-fun `(lambda (&rest stuff)
111 (declare (ignore stuff))
114 `(lambda (,n-form &aux (,n-env *lexenv*))
118 (defmacro define-source-transform (name lambda-list &body body)
119 `(setf (info :function :source-transform ',name)
120 (source-transform-lambda ,lambda-list ,@body)))
122 ;;;; boolean attribute utilities
124 ;;;; We need to maintain various sets of boolean attributes for known
125 ;;;; functions and VOPs. To save space and allow for quick set
126 ;;;; operations, we represent the attributes as bits in a fixnum.
128 (deftype attributes () 'fixnum)
130 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
132 ;;; Given a list of attribute names and an alist that translates them
133 ;;; to masks, return the OR of the masks.
134 (defun compute-attribute-mask (names alist)
135 (collect ((res 0 logior))
137 (let ((mask (cdr (assoc name alist))))
139 (error "unknown attribute name: ~S" name))
145 ;;; Define a new class of boolean attributes, with the attributes
146 ;;; having the specified ATTRIBUTE-NAMES. NAME is the name of the
147 ;;; class, which is used to generate some macros to manipulate sets of
150 ;;; NAME-attributep attributes attribute-name*
151 ;;; Return true if one of the named attributes is present, false
152 ;;; otherwise. When set with SETF, updates the place Attributes
153 ;;; setting or clearing the specified attributes.
155 ;;; NAME-attributes attribute-name*
156 ;;; Return a set of the named attributes.
159 (def!macro !def-boolean-attribute (name &rest attribute-names)
161 (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
162 (test-name (symbolicate name "-ATTRIBUTEP")))
164 (do ((mask 1 (ash mask 1))
165 (names attribute-names (cdr names)))
167 (alist (cons (car names) mask)))
169 (eval-when (:compile-toplevel :load-toplevel :execute)
170 (defparameter ,translations-name ',(alist)))
171 (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
172 "Automagically generated boolean attribute creation function.
173 See !DEF-BOOLEAN-ATTRIBUTE."
174 (compute-attribute-mask attribute-names ,translations-name))
175 (defmacro ,test-name (attributes &rest attribute-names)
176 "Automagically generated boolean attribute test function.
177 See !DEF-BOOLEAN-ATTRIBUTE."
178 `(logtest ,(compute-attribute-mask attribute-names
180 (the attributes ,attributes)))
181 ;; This definition transforms strangely under UNCROSS, in a
182 ;; way that DEF!MACRO doesn't understand, so we delegate it
183 ;; to a submacro then define the submacro differently when
184 ;; building the xc and when building the target compiler.
185 (!def-boolean-attribute-setter ,test-name
187 ,@attribute-names)))))
189 ;; It seems to be difficult to express in DEF!MACRO machinery what
190 ;; to do with target-vs-host GET-SETF-EXPANSION in here, so we just
191 ;; hack it by hand, passing a different GET-SETF-EXPANSION-FUN-NAME
192 ;; in the host DEFMACRO and target DEFMACRO-MUNDANELY cases.
193 (defun guts-of-!def-boolean-attribute-setter (test-name
196 get-setf-expansion-fun-name)
197 `(define-setf-expander ,test-name (place &rest attributes
199 "Automagically generated boolean attribute setter. See
200 !DEF-BOOLEAN-ATTRIBUTE."
201 #-sb-xc-host (declare (type sb!c::lexenv env))
202 ;; FIXME: It would be better if &ENVIRONMENT arguments were
203 ;; automatically declared to have type LEXENV by the
204 ;; hairy-argument-handling code.
205 (multiple-value-bind (temps values stores set get)
206 (,get-setf-expansion-fun-name place env)
208 (error "multiple store variables for ~S" place))
209 (let ((newval (gensym))
211 (mask (compute-attribute-mask attributes ,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))))))
222 ;; We define the host version here, and the just-like-it-but-different
223 ;; target version later, after DEFMACRO-MUNDANELY has been defined.
224 (defmacro !def-boolean-attribute-setter (test-name
226 &rest attribute-names)
227 (guts-of-!def-boolean-attribute-setter test-name
230 'get-setf-expansion)))
232 ;;; And now for some gratuitous pseudo-abstraction...
235 ;;; Return the union of all the sets of boolean attributes which are its
237 ;;; ATTRIBUTES-INTERSECTION
238 ;;; Return the intersection of all the sets of boolean attributes which
239 ;;; are its arguments.
241 ;;; True if the attributes present in ATTR1 are identical to
243 (defmacro attributes-union (&rest attributes)
245 (logior ,@(mapcar (lambda (x) `(the attributes ,x)) attributes))))
246 (defmacro attributes-intersection (&rest attributes)
248 (logand ,@(mapcar (lambda (x) `(the attributes ,x)) attributes))))
249 (declaim (ftype (function (attributes attributes) boolean) attributes=))
250 #!-sb-fluid (declaim (inline attributes=))
251 (defun attributes= (attr1 attr2)
254 ;;;; lambda-list parsing utilities
256 ;;;; IR1 transforms, optimizers and type inferencers need to be able
257 ;;;; to parse the IR1 representation of a function call using a
258 ;;;; standard function lambda-list.
260 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
262 ;;; Given a DEFTRANSFORM-style lambda-list, generate code that parses
263 ;;; the arguments of a combination with respect to that lambda-list.
264 ;;; BODY is the the list of forms which are to be evaluated within the
265 ;;; bindings. ARGS is the variable that holds list of argument
266 ;;; continuations. ERROR-FORM is a form which is evaluated when the
267 ;;; syntax of the supplied arguments is incorrect or a non-constant
268 ;;; argument keyword is supplied. Defaults and other gunk are ignored.
269 ;;; The second value is a list of all the arguments bound. We make the
270 ;;; variables IGNORABLE so that we don't have to manually declare them
271 ;;; Ignore if their only purpose is to make the syntax work.
272 (defun parse-deftransform (lambda-list body args error-form)
273 (multiple-value-bind (req opt restp rest keyp keys allowp)
274 (parse-lambda-list lambda-list)
275 (let* ((min-args (length req))
276 (max-args (+ min-args (length opt)))
284 (binds `(,arg (nth ,(pos) ,args)))
288 (let ((var (if (atom arg) arg (first arg))))
290 (binds `(,var (nth ,(pos) ,args)))
295 (binds `(,rest (nthcdr ,(pos) ,args))))
298 (if (or (atom spec) (atom (first spec)))
299 (let* ((var (if (atom spec) spec (first spec)))
300 (key (keywordicate var)))
302 (binds `(,var (find-keyword-continuation ,n-keys ,key)))
304 (let* ((head (first spec))
308 (binds `(,var (find-keyword-continuation ,n-keys ,key)))
311 (let ((n-length (gensym))
312 (limited-legal (not (or restp keyp))))
314 `(let ((,n-length (length ,args))
315 ,@(when keyp `((,n-keys (nthcdr ,(pos) ,args)))))
317 ;; FIXME: should be PROPER-LIST-OF-LENGTH-P
319 `(<= ,min-args ,n-length ,max-args)
320 `(<= ,min-args ,n-length))
323 `((check-key-args-constant ,n-keys))
324 `((check-transform-keys ,n-keys ',(keywords))))))
327 (declare (ignorable ,@(vars)))
335 ;;; Define an IR1 transformation for NAME. An IR1 transformation
336 ;;; computes a lambda that replaces the function variable reference
337 ;;; for the call. A transform may pass (decide not to transform the
338 ;;; call) by calling the GIVE-UP-IR1-TRANSFORM function. LAMBDA-LIST
339 ;;; both determines how the current call is parsed and specifies the
340 ;;; LAMBDA-LIST for the resulting lambda.
342 ;;; We parse the call and bind each of the lambda-list variables to
343 ;;; the continuation which represents the value of the argument. When
344 ;;; parsing the call, we ignore the defaults, and always bind the
345 ;;; variables for unsupplied arguments to NIL. If a required argument
346 ;;; is missing, an unknown keyword is supplied, or an argument keyword
347 ;;; is not a constant, then the transform automatically passes. The
348 ;;; DECLARATIONS apply to the bindings made by DEFTRANSFORM at
349 ;;; transformation time, rather than to the variables of the resulting
350 ;;; lambda. Bound-but-not-referenced warnings are suppressed for the
351 ;;; lambda-list variables. The DOC-STRING is used when printing
352 ;;; efficiency notes about the defined transform.
354 ;;; Normally, the body evaluates to a form which becomes the body of
355 ;;; an automatically constructed lambda. We make LAMBDA-LIST the
356 ;;; lambda-list for the lambda, and automatically insert declarations
357 ;;; of the argument and result types. If the second value of the body
358 ;;; is non-null, then it is a list of declarations which are to be
359 ;;; inserted at the head of the lambda. Automatic lambda generation
360 ;;; may be inhibited by explicitly returning a lambda from the body.
362 ;;; The ARG-TYPES and RESULT-TYPE are used to create a function type
363 ;;; which the call must satisfy before transformation is attempted.
364 ;;; The function type specifier is constructed by wrapping (FUNCTION
365 ;;; ...) around these values, so the lack of a restriction may be
366 ;;; specified by omitting the argument or supplying *. The argument
367 ;;; syntax specified in the ARG-TYPES need not be the same as that in
368 ;;; the LAMBDA-LIST, but the transform will never happen if the
369 ;;; syntaxes can't be satisfied simultaneously. If there is an
370 ;;; existing transform for the same function that has the same type,
371 ;;; then it is replaced with the new definition.
373 ;;; These are the legal keyword options:
374 ;;; :RESULT - A variable which is bound to the result continuation.
375 ;;; :NODE - A variable which is bound to the combination node for the call.
376 ;;; :POLICY - A form which is supplied to the POLICY macro to determine
377 ;;; whether this transformation is appropriate. If the result
378 ;;; is false, then the transform automatically gives up.
380 ;;; - The name and argument/result types are actually forms to be
381 ;;; evaluated. Useful for getting closures that transform similar
384 ;;; - Don't actually instantiate a transform, instead just DEFUN
385 ;;; Name with the specified transform definition function. This
386 ;;; may be later instantiated with %DEFTRANSFORM.
388 ;;; - If supplied and non-NIL, note this transform as ``important,''
389 ;;; which means efficiency notes will be generated when this
390 ;;; transform fails even if INHIBIT-WARNINGS=SPEED (but not if
391 ;;; INHIBIT-WARNINGS>SPEED).
392 (defmacro deftransform (name (lambda-list &optional (arg-types '*)
394 &key result policy node defun-only
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))))))))
438 ;;;; DEFKNOWN and DEFOPTIMIZER
440 ;;; This macro should be the way that all implementation independent
441 ;;; information about functions is made known to the compiler.
443 ;;; FIXME: The comment above suggests that perhaps some of my added
444 ;;; FTYPE declarations are in poor taste. Should I change my
445 ;;; declarations, or change the comment, or what?
447 ;;; FIXME: DEFKNOWN is needed only at build-the-system time. Figure
448 ;;; out some way to keep it from appearing in the target system.
450 ;;; Declare the function NAME to be a known function. We construct a
451 ;;; type specifier for the function by wrapping (FUNCTION ...) around
452 ;;; the ARG-TYPES and RESULT-TYPE. ATTRIBUTES is an unevaluated list
453 ;;; of boolean attributes of the function. See their description in
454 ;;; (!DEF-BOOLEAN-ATTRIBUTE IR1). NAME may also be a list of names, in
455 ;;; which case the same information is given to all the names. The
456 ;;; keywords specify the initial values for various optimizers that
457 ;;; the function might have.
458 (defmacro defknown (name arg-types result-type &optional (attributes '(any))
460 (when (and (intersection attributes '(any call unwind))
461 (intersection attributes '(movable)))
462 (error "function cannot have both good and bad attributes: ~S" attributes))
464 (when (member 'any attributes)
465 (setq attributes (union '(call unsafe unwind) attributes)))
466 (when (member 'flushable attributes)
467 (pushnew 'unsafely-flushable attributes))
469 `(%defknown ',(if (and (consp name)
470 (not (legal-fun-name-p name)))
473 '(sfunction ,arg-types ,result-type)
474 (ir1-attributes ,@attributes)
477 ;;; Create a function which parses combination args according to WHAT
478 ;;; and LAMBDA-LIST, where WHAT is either a function name or a list
479 ;;; (FUN-NAME KIND) and does some KIND of optimization.
481 ;;; The FUN-NAME must name a known function. LAMBDA-LIST is used
482 ;;; to parse the arguments to the combination as in DEFTRANSFORM. If
483 ;;; the argument syntax is invalid or there are non-constant keys,
484 ;;; then we simply return NIL.
486 ;;; The function is DEFUN'ed as FUNCTION-KIND-OPTIMIZER. Possible
487 ;;; kinds are DERIVE-TYPE, OPTIMIZER, LTN-ANNOTATE and IR2-CONVERT. If
488 ;;; a symbol is specified instead of a (FUNCTION KIND) list, then we
489 ;;; just do a DEFUN with the symbol as its name, and don't do anything
490 ;;; with the definition. This is useful for creating optimizers to be
491 ;;; passed by name to DEFKNOWN.
493 ;;; If supplied, NODE-VAR is bound to the combination node being
494 ;;; optimized. If additional VARS are supplied, then they are used as
495 ;;; the rest of the optimizer function's lambda-list. LTN-ANNOTATE
496 ;;; methods are passed an additional POLICY argument, and IR2-CONVERT
497 ;;; methods are passed an additional IR2-BLOCK argument.
498 (defmacro defoptimizer (what (lambda-list &optional (n-node (gensym))
501 (let ((name (if (symbolp what) what
502 (symbolicate (first what) "-" (second what) "-OPTIMIZER"))))
504 (let ((n-args (gensym)))
506 (defun ,name (,n-node ,@vars)
507 (let ((,n-args (basic-combination-args ,n-node)))
508 ,(parse-deftransform lambda-list body n-args
509 `(return-from ,name nil))))
511 `((setf (,(symbolicate "FUN-INFO-" (second what))
512 (fun-info-or-lose ',(first what)))
515 ;;;; IR groveling macros
517 ;;; Iterate over the blocks in a component, binding BLOCK-VAR to each
518 ;;; block in turn. The value of ENDS determines whether to iterate
519 ;;; over dummy head and tail blocks:
520 ;;; NIL -- Skip Head and Tail (the default)
521 ;;; :HEAD -- Do head but skip tail
522 ;;; :TAIL -- Do tail but skip head
523 ;;; :BOTH -- Do both head and tail
525 ;;; If supplied, RESULT-FORM is the value to return.
526 (defmacro do-blocks ((block-var component &optional ends result) &body body)
527 (unless (member ends '(nil :head :tail :both))
528 (error "losing ENDS value: ~S" ends))
529 (let ((n-component (gensym))
531 `(let* ((,n-component ,component)
532 (,n-tail ,(if (member ends '(:both :tail))
534 `(component-tail ,n-component))))
535 (do ((,block-var ,(if (member ends '(:both :head))
536 `(component-head ,n-component)
537 `(block-next (component-head ,n-component)))
538 (block-next ,block-var)))
539 ((eq ,block-var ,n-tail) ,result)
541 ;;; like DO-BLOCKS, only iterating over the blocks in reverse order
542 (defmacro do-blocks-backwards ((block-var component &optional ends result) &body body)
543 (unless (member ends '(nil :head :tail :both))
544 (error "losing ENDS value: ~S" ends))
545 (let ((n-component (gensym))
547 `(let* ((,n-component ,component)
548 (,n-head ,(if (member ends '(:both :head))
550 `(component-head ,n-component))))
551 (do ((,block-var ,(if (member ends '(:both :tail))
552 `(component-tail ,n-component)
553 `(block-prev (component-tail ,n-component)))
554 (block-prev ,block-var)))
555 ((eq ,block-var ,n-head) ,result)
558 ;;; Iterate over the uses of CONTINUATION, binding NODE to each one
561 ;;; XXX Could change it not to replicate the code someday perhaps...
562 (defmacro do-uses ((node-var continuation &optional result) &body body)
563 (once-only ((n-cont continuation))
564 `(ecase (continuation-kind ,n-cont)
568 (let ((,node-var (continuation-use ,n-cont)))
571 ((:block-start :deleted-block-start)
572 (dolist (,node-var (block-start-uses (continuation-block ,n-cont))
576 ;;; Iterate over the nodes in BLOCK, binding NODE-VAR to the each node
577 ;;; and CONT-VAR to the node's CONT. The only keyword option is
578 ;;; RESTART-P, which causes iteration to be restarted when a node is
579 ;;; deleted out from under us. (If not supplied, this is an error.)
581 ;;; In the forward case, we terminate on LAST-CONT so that we don't
582 ;;; have to worry about our termination condition being changed when
583 ;;; new code is added during the iteration. In the backward case, we
584 ;;; do NODE-PREV before evaluating the body so that we can keep going
585 ;;; when the current node is deleted.
587 ;;; When RESTART-P is supplied to DO-NODES, we start iterating over
588 ;;; again at the beginning of the block when we run into a
589 ;;; continuation whose block differs from the one we are trying to
590 ;;; iterate over, either because the block was split, or because a
591 ;;; node was deleted out from under us (hence its block is NIL.) If
592 ;;; the block start is deleted, we just punt. With RESTART-P, we are
593 ;;; also more careful about termination, re-indirecting the BLOCK-LAST
595 (defmacro do-nodes ((node-var cont-var block &key restart-p) &body body)
596 (let ((n-block (gensym))
597 (n-last-cont (gensym)))
598 `(let* ((,n-block ,block)
600 `((,n-last-cont (node-cont (block-last ,n-block))))))
601 (do* ((,node-var (continuation-next (block-start ,n-block))
604 ((eq (continuation-block ,cont-var) ,n-block)
605 (aver (continuation-next ,cont-var))
606 (continuation-next ,cont-var))
608 (let ((start (block-start ,n-block)))
609 (unless (eq (continuation-kind start)
612 (continuation-next start))))
613 `(continuation-next ,cont-var)))
614 (,cont-var (node-cont ,node-var) (node-cont ,node-var)))
616 (declare (type node ,node-var))
619 `(eq ,node-var (block-last ,n-block))
620 `(eq ,cont-var ,n-last-cont))
622 ;;; like DO-NODES, only iterating in reverse order
623 (defmacro do-nodes-backwards ((node-var cont-var block) &body body)
624 (let ((n-block (gensym))
628 `(let* ((,n-block ,block)
629 (,n-start (block-start ,n-block))
630 (,n-last (block-last ,n-block)))
631 (do* ((,cont-var (node-cont ,n-last) ,n-next)
632 (,node-var ,n-last (continuation-use ,cont-var))
633 (,n-next (node-prev ,node-var) (node-prev ,node-var)))
636 (when (eq ,n-next ,n-start)
639 ;;; Bind the IR1 context variables to the values associated with NODE,
640 ;;; so that new, extra IR1 conversion related to NODE can be done
641 ;;; after the original conversion pass has finished.
642 (defmacro with-ir1-environment-from-node (node &rest forms)
643 `(flet ((closure-needing-ir1-environment-from-node ()
645 (%with-ir1-environment-from-node
647 #'closure-needing-ir1-environment-from-node)))
648 (defun %with-ir1-environment-from-node (node fun)
649 (declare (type node node) (type function fun))
650 (let ((*current-component* (node-component node))
651 (*lexenv* (node-lexenv node))
652 (*current-path* (node-source-path node)))
653 (aver-live-component *current-component*)
656 ;;; Bind the hashtables used for keeping track of global variables,
657 ;;; functions, etc. Also establish condition handlers.
658 (defmacro with-ir1-namespace (&body forms)
659 `(let ((*free-vars* (make-hash-table :test 'eq))
660 (*free-funs* (make-hash-table :test 'equal))
661 (*constants* (make-hash-table :test 'equal))
662 (*source-paths* (make-hash-table :test 'eq)))
663 (handler-bind ((compiler-error #'compiler-error-handler)
664 (style-warning #'compiler-style-warning-handler)
665 (warning #'compiler-warning-handler))
668 ;;; Look up NAME in the lexical environment namespace designated by
669 ;;; SLOT, returning the <value, T>, or <NIL, NIL> if no entry. The
670 ;;; :TEST keyword may be used to determine the name equality
672 (defmacro lexenv-find (name slot &key test)
673 (once-only ((n-res `(assoc ,name (,(let ((*package* (symbol-package 'lexenv-funs)))
674 (symbolicate "LEXENV-" slot))
676 :test ,(or test '#'eq))))
678 (values (cdr ,n-res) t)
681 (defmacro with-component-last-block ((component block) &body body)
682 (with-unique-names (old-last-block)
683 (once-only ((component component)
685 `(let ((,old-last-block (component-last-block ,component)))
687 (progn (setf (component-last-block ,component)
690 (setf (component-last-block ,component)
691 ,old-last-block))))))
694 ;;;; the EVENT statistics/trace utility
696 ;;; FIXME: This seems to be useful for troubleshooting and
697 ;;; experimentation, not for ordinary use, so it should probably
698 ;;; become conditional on SB-SHOW.
700 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
702 (defstruct (event-info (:copier nil))
703 ;; The name of this event.
704 (name (missing-arg) :type symbol)
705 ;; The string rescribing this event.
706 (description (missing-arg) :type string)
707 ;; The name of the variable we stash this in.
708 (var (missing-arg) :type symbol)
709 ;; The number of times this event has happened.
710 (count 0 :type fixnum)
711 ;; The level of significance of this event.
712 (level (missing-arg) :type unsigned-byte)
713 ;; If true, a function that gets called with the node that the event
715 (action nil :type (or function null)))
717 ;;; A hashtable from event names to event-info structures.
718 (defvar *event-info* (make-hash-table :test 'eq))
720 ;;; Return the event info for Name or die trying.
721 (declaim (ftype (function (t) event-info) event-info-or-lose))
722 (defun event-info-or-lose (name)
723 (let ((res (gethash name *event-info*)))
725 (error "~S is not the name of an event." name))
730 ;;; Return the number of times that EVENT has happened.
731 (declaim (ftype (function (symbol) fixnum) event-count))
732 (defun event-count (name)
733 (event-info-count (event-info-or-lose name)))
735 ;;; Return the function that is called when Event happens. If this is
736 ;;; null, there is no action. The function is passed the node to which
737 ;;; the event happened, or NIL if there is no relevant node. This may
738 ;;; be set with SETF.
739 (declaim (ftype (function (symbol) (or function null)) event-action))
740 (defun event-action (name)
741 (event-info-action (event-info-or-lose name)))
742 (declaim (ftype (function (symbol (or function null)) (or function null))
744 (defun %set-event-action (name new-value)
745 (setf (event-info-action (event-info-or-lose name))
747 (defsetf event-action %set-event-action)
749 ;;; Return the non-negative integer which represents the level of
750 ;;; significance of the event Name. This is used to determine whether
751 ;;; to print a message when the event happens. This may be set with
753 (declaim (ftype (function (symbol) unsigned-byte) event-level))
754 (defun event-level (name)
755 (event-info-level (event-info-or-lose name)))
756 (declaim (ftype (function (symbol unsigned-byte) unsigned-byte) %set-event-level))
757 (defun %set-event-level (name new-value)
758 (setf (event-info-level (event-info-or-lose name))
760 (defsetf event-level %set-event-level)
762 ;;; Define a new kind of event. NAME is a symbol which names the event
763 ;;; and DESCRIPTION is a string which describes the event. Level
764 ;;; (default 0) is the level of significance associated with this
765 ;;; event; it is used to determine whether to print a Note when the
767 (defmacro defevent (name description &optional (level 0))
768 (let ((var-name (symbolicate "*" name "-EVENT-INFO*")))
769 `(eval-when (:compile-toplevel :load-toplevel :execute)
771 (make-event-info :name ',name
772 :description ',description
775 (setf (gethash ',name *event-info*) ,var-name)
778 ;;; the lowest level of event that will print a note when it occurs
779 (declaim (type unsigned-byte *event-note-threshold*))
780 (defvar *event-note-threshold* 1)
782 ;;; Note that the event with the specified NAME has happened. NODE is
783 ;;; evaluated to determine the node to which the event happened.
784 (defmacro event (name &optional node)
785 ;; Increment the counter and do any action. Mumble about the event if
787 `(%event ,(event-info-var (event-info-or-lose name)) ,node))
789 ;;; Print a listing of events and their counts, sorted by the count.
790 ;;; Events that happened fewer than Min-Count times will not be
791 ;;; printed. Stream is the stream to write to.
792 (declaim (ftype (function (&optional unsigned-byte stream) (values)) event-statistics))
793 (defun event-statistics (&optional (min-count 1) (stream *standard-output*))
795 (maphash (lambda (k v)
797 (when (>= (event-info-count v) min-count)
800 (dolist (event (sort (info) #'> :key #'event-info-count))
801 (format stream "~6D: ~A~%" (event-info-count event)
802 (event-info-description event)))
806 (declaim (ftype (function nil (values)) clear-event-statistics))
807 (defun clear-event-statistics ()
808 (maphash (lambda (k v)
810 (setf (event-info-count v) 0))
814 ;;;; functions on directly-linked lists (linked through specialized
815 ;;;; NEXT operations)
817 #!-sb-fluid (declaim (inline find-in position-in))
819 ;;; Find ELEMENT in a null-terminated LIST linked by the accessor
820 ;;; function NEXT. KEY, TEST and TEST-NOT are the same as for generic
821 ;;; sequence functions.
828 (test-not #'eql not-p))
829 (declare (type function next key test test-not))
830 (when (and test-p not-p)
831 (error "It's silly to supply both :TEST and :TEST-NOT arguments."))
833 (do ((current list (funcall next current)))
835 (unless (funcall test-not (funcall key current) element)
837 (do ((current list (funcall next current)))
839 (when (funcall test (funcall key current) element)
842 ;;; Return the position of ELEMENT (or NIL if absent) in a
843 ;;; null-terminated LIST linked by the accessor function NEXT. KEY,
844 ;;; TEST and TEST-NOT are the same as for generic sequence functions.
845 (defun position-in (next
851 (test-not #'eql not-p))
852 (declare (type function next key test test-not))
853 (when (and test-p not-p)
854 (error "It's silly to supply both :TEST and :TEST-NOT arguments."))
856 (do ((current list (funcall next current))
859 (unless (funcall test-not (funcall key current) element)
861 (do ((current list (funcall next current))
864 (when (funcall test (funcall key current) element)
868 ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
869 ;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
871 ;;; (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
872 ;;; arrangement, in order to get it to work in cross-compilation. This
873 ;;; duplication should be removed, perhaps by rewriting the macro in a more
874 ;;; cross-compiler-friendly way, or perhaps just by using some (MACROLET ((FROB
875 ;;; ..)) .. FROB .. FROB) form, or perhaps by completely eliminating this macro
876 ;;; and its partner PUSH-IN, but I don't want to do it now, because the system
877 ;;; isn't running yet, so it'd be too hard to check that my changes were
878 ;;; correct -- WHN 19990806
879 (def!macro deletef-in (next place item &environment env)
880 (multiple-value-bind (temps vals stores store access)
881 (get-setf-expansion place env)
883 (error "multiple store variables for ~S" place))
884 (let ((n-item (gensym))
888 `(let* (,@(mapcar #'list temps vals)
891 (if (eq ,n-place ,n-item)
892 (let ((,(first stores) (,next ,n-place)))
894 (do ((,n-prev ,n-place ,n-current)
895 (,n-current (,next ,n-place)
897 ((eq ,n-current ,n-item)
898 (setf (,next ,n-prev)
899 (,next ,n-current)))))
901 ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
903 ;;; Push ITEM onto a list linked by the accessor function NEXT that is
906 ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
907 ;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
909 ;;; (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
910 ;;; arrangement, in order to get it to work in cross-compilation. This
911 ;;; duplication should be removed, perhaps by rewriting the macro in a more
912 ;;; cross-compiler-friendly way, or perhaps just by using some (MACROLET ((FROB
913 ;;; ..)) .. FROB .. FROB) form, or perhaps by completely eliminating this macro
914 ;;; and its partner DELETEF-IN, but I don't want to do it now, because the
915 ;;; system isn't running yet, so it'd be too hard to check that my changes were
916 ;;; correct -- WHN 19990806
917 (def!macro push-in (next item place &environment env)
918 (multiple-value-bind (temps vals stores store access)
919 (get-setf-expansion place env)
921 (error "multiple store variables for ~S" place))
922 `(let (,@(mapcar #'list temps vals)
923 (,(first stores) ,item))
924 (setf (,next ,(first stores)) ,access)
927 ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
929 (defmacro position-or-lose (&rest args)
930 `(or (position ,@args)
931 (error "shouldn't happen?")))