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 ;;; Parse a DEFMACRO-style lambda-list, setting things up so that a
30 ;;; compiler error happens if the syntax is invalid.
32 ;;; Define a function that converts a special form or other magical
33 ;;; thing into IR1. LAMBDA-LIST is a defmacro style lambda
34 ;;; list. START-VAR, NEXT-VAR and RESULT-VAR are bound to the start and
35 ;;; result continuations for the resulting IR1. KIND is the function
36 ;;; kind to associate with NAME.
37 (defmacro def-ir1-translator (name (lambda-list start-var next-var result-var)
39 (let ((fn-name (symbolicate "IR1-CONVERT-" name))
42 (multiple-value-bind (body decls doc)
43 (parse-defmacro lambda-list n-form body name "special form"
45 :error-fun 'compiler-error
48 (declaim (ftype (function (ctran ctran (or lvar null) t) (values))
50 (defun ,fn-name (,start-var ,next-var ,result-var ,n-form
51 &aux (,n-env *lexenv*))
52 (declare (ignorable ,start-var ,next-var ,result-var))
57 `((setf (fdocumentation ',name 'function) ,doc)))
58 ;; FIXME: Evidently "there can only be one!" -- we overwrite any
59 ;; other :IR1-CONVERT value. This deserves a warning, I think.
60 (setf (info :function :ir1-convert ',name) #',fn-name)
61 ;; FIXME: rename this to SPECIAL-OPERATOR, to update it to
63 (setf (info :function :kind ',name) :special-form)
64 ;; It's nice to do this for error checking in the target
65 ;; SBCL, but it's not nice to do this when we're running in
66 ;; the cross-compilation host Lisp, which owns the
67 ;; SYMBOL-FUNCTION of its COMMON-LISP symbols.
69 (let ((fun (lambda (&rest rest)
70 (declare (ignore rest))
71 (error 'special-form-function :name ',name))))
72 (setf (%simple-fun-arglist fun) ',lambda-list)
73 (setf (symbol-function ',name) fun))
76 ;;; (This is similar to DEF-IR1-TRANSLATOR, except that we pass if the
77 ;;; syntax is invalid.)
79 ;;; Define a macro-like source-to-source transformation for the
80 ;;; function NAME. A source transform may "pass" by returning a
81 ;;; non-nil second value. If the transform passes, then the form is
82 ;;; converted as a normal function call. If the supplied arguments are
83 ;;; not compatible with the specified LAMBDA-LIST, then the transform
84 ;;; automatically passes.
86 ;;; Source transforms may only be defined for functions. Source
87 ;;; transformation is not attempted if the function is declared
88 ;;; NOTINLINE. Source transforms should not examine their arguments.
89 ;;; If it matters how the function is used, then DEFTRANSFORM should
90 ;;; be used to define an IR1 transformation.
92 ;;; If the desirability of the transformation depends on the current
93 ;;; OPTIMIZE parameters, then the POLICY macro should be used to
94 ;;; determine when to pass.
95 (defmacro source-transform-lambda (lambda-list &body body)
96 (let ((n-form (gensym))
99 (multiple-value-bind (body decls)
100 (parse-defmacro lambda-list n-form body "source transform" "form"
102 :error-fun `(lambda (&rest stuff)
103 (declare (ignore stuff))
107 `(lambda (,n-form &aux (,n-env *lexenv*))
111 (defmacro define-source-transform (name lambda-list &body body)
112 `(setf (info :function :source-transform ',name)
113 (source-transform-lambda ,lambda-list ,@body)))
115 ;;;; boolean attribute utilities
117 ;;;; We need to maintain various sets of boolean attributes for known
118 ;;;; functions and VOPs. To save space and allow for quick set
119 ;;;; operations, we represent the attributes as bits in a fixnum.
121 (deftype attributes () 'fixnum)
123 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
125 ;;; Given a list of attribute names and an alist that translates them
126 ;;; to masks, return the OR of the masks.
127 (defun compute-attribute-mask (names alist)
128 (collect ((res 0 logior))
130 (let ((mask (cdr (assoc name alist))))
132 (error "unknown attribute name: ~S" name))
138 ;;; Define a new class of boolean attributes, with the attributes
139 ;;; having the specified ATTRIBUTE-NAMES. NAME is the name of the
140 ;;; class, which is used to generate some macros to manipulate sets of
143 ;;; NAME-attributep attributes attribute-name*
144 ;;; Return true if one of the named attributes is present, false
145 ;;; otherwise. When set with SETF, updates the place Attributes
146 ;;; setting or clearing the specified attributes.
148 ;;; NAME-attributes attribute-name*
149 ;;; Return a set of the named attributes.
152 (def!macro !def-boolean-attribute (name &rest attribute-names)
154 (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
155 (test-name (symbolicate name "-ATTRIBUTEP"))
156 (decoder-name (symbolicate "DECODE-" name "-ATTRIBUTES")))
158 (do ((mask 1 (ash mask 1))
159 (names attribute-names (cdr names)))
161 (alist (cons (car names) mask)))
163 (eval-when (:compile-toplevel :load-toplevel :execute)
164 (defparameter ,translations-name ',(alist)))
165 (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
166 "Automagically generated boolean attribute creation function.
167 See !DEF-BOOLEAN-ATTRIBUTE."
168 (compute-attribute-mask attribute-names ,translations-name))
169 (defmacro ,test-name (attributes &rest attribute-names)
170 "Automagically generated boolean attribute test function.
171 See !DEF-BOOLEAN-ATTRIBUTE."
172 `(logtest ,(compute-attribute-mask attribute-names
174 (the attributes ,attributes)))
175 ;; This definition transforms strangely under UNCROSS, in a
176 ;; way that DEF!MACRO doesn't understand, so we delegate it
177 ;; to a submacro then define the submacro differently when
178 ;; building the xc and when building the target compiler.
179 (!def-boolean-attribute-setter ,test-name
182 (defun ,decoder-name (attributes)
183 (loop for (name . mask) in ,translations-name
184 when (logtest mask attributes)
187 ;; It seems to be difficult to express in DEF!MACRO machinery what
188 ;; to do with target-vs-host GET-SETF-EXPANSION in here, so we just
189 ;; hack it by hand, passing a different GET-SETF-EXPANSION-FUN-NAME
190 ;; in the host DEFMACRO and target DEFMACRO-MUNDANELY cases.
191 (defun guts-of-!def-boolean-attribute-setter (test-name
194 get-setf-expansion-fun-name)
195 `(define-setf-expander ,test-name (place &rest attributes
197 "Automagically generated boolean attribute setter. See
198 !DEF-BOOLEAN-ATTRIBUTE."
199 #-sb-xc-host (declare (type sb!c::lexenv env))
200 ;; FIXME: It would be better if &ENVIRONMENT arguments were
201 ;; automatically declared to have type LEXENV by the
202 ;; hairy-argument-handling code.
203 (multiple-value-bind (temps values stores set get)
204 (,get-setf-expansion-fun-name place env)
206 (error "multiple store variables for ~S" place))
207 (let ((newval (gensym))
209 (mask (compute-attribute-mask attributes ,translations-name)))
210 (values `(,@temps ,n-place)
213 `(let ((,(first stores)
215 (logior ,n-place ,mask)
216 (logand ,n-place ,(lognot mask)))))
219 `(,',test-name ,n-place ,@attributes))))))
220 ;; We define the host version here, and the just-like-it-but-different
221 ;; target version later, after DEFMACRO-MUNDANELY has been defined.
222 (defmacro !def-boolean-attribute-setter (test-name
224 &rest attribute-names)
225 (guts-of-!def-boolean-attribute-setter test-name
228 'get-setf-expansion)))
230 ;;; And now for some gratuitous pseudo-abstraction...
233 ;;; Return the union of all the sets of boolean attributes which are its
235 ;;; ATTRIBUTES-INTERSECTION
236 ;;; Return the intersection of all the sets of boolean attributes which
237 ;;; are its arguments.
239 ;;; True if the attributes present in ATTR1 are identical to
241 (defmacro attributes-union (&rest attributes)
243 (logior ,@(mapcar (lambda (x) `(the attributes ,x)) attributes))))
244 (defmacro attributes-intersection (&rest attributes)
246 (logand ,@(mapcar (lambda (x) `(the attributes ,x)) attributes))))
247 (declaim (ftype (function (attributes attributes) boolean) attributes=))
248 #!-sb-fluid (declaim (inline attributes=))
249 (defun attributes= (attr1 attr2)
252 ;;;; lambda-list parsing utilities
254 ;;;; IR1 transforms, optimizers and type inferencers need to be able
255 ;;;; to parse the IR1 representation of a function call using a
256 ;;;; standard function lambda-list.
258 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
260 ;;; Given a DEFTRANSFORM-style lambda-list, generate code that parses
261 ;;; the arguments of a combination with respect to that
262 ;;; lambda-list. BODY is the the list of forms which are to be
263 ;;; evaluated within the bindings. ARGS is the variable that holds
264 ;;; list of argument lvars. ERROR-FORM is a form which is evaluated
265 ;;; when the syntax of the supplied arguments is incorrect or a
266 ;;; non-constant argument keyword is supplied. Defaults and other gunk
267 ;;; are ignored. The second value is a list of all the arguments
268 ;;; bound. We make the variables IGNORABLE so that we don't have to
269 ;;; manually declare them Ignore if their only purpose is to make the
271 (defun parse-deftransform (lambda-list body args error-form)
272 (multiple-value-bind (req opt restp rest keyp keys allowp)
273 (parse-lambda-list lambda-list)
274 (let* ((min-args (length req))
275 (max-args (+ min-args (length opt)))
283 (binds `(,arg (nth ,(pos) ,args)))
287 (let ((var (if (atom arg) arg (first arg))))
289 (binds `(,var (nth ,(pos) ,args)))
294 (binds `(,rest (nthcdr ,(pos) ,args))))
297 (if (or (atom spec) (atom (first spec)))
298 (let* ((var (if (atom spec) spec (first spec)))
299 (key (keywordicate var)))
301 (binds `(,var (find-keyword-lvar ,n-keys ,key)))
303 (let* ((head (first spec))
307 (binds `(,var (find-keyword-lvar ,n-keys ,key)))
310 (let ((n-length (gensym))
311 (limited-legal (not (or restp keyp))))
313 `(let ((,n-length (length ,args))
314 ,@(when keyp `((,n-keys (nthcdr ,(pos) ,args)))))
316 ;; FIXME: should be PROPER-LIST-OF-LENGTH-P
318 `(<= ,min-args ,n-length ,max-args)
319 `(<= ,min-args ,n-length))
322 `((check-key-args-constant ,n-keys))
323 `((check-transform-keys ,n-keys ',(keywords))))))
326 (declare (ignorable ,@(vars)))
334 ;;; Define an IR1 transformation for NAME. An IR1 transformation
335 ;;; computes a lambda that replaces the function variable reference
336 ;;; for the call. A transform may pass (decide not to transform the
337 ;;; call) by calling the GIVE-UP-IR1-TRANSFORM function. LAMBDA-LIST
338 ;;; both determines how the current call is parsed and specifies the
339 ;;; LAMBDA-LIST for the resulting lambda.
341 ;;; We parse the call and bind each of the lambda-list variables to
342 ;;; the lvar which represents the value of the argument. When parsing
343 ;;; the call, we ignore the defaults, and always bind the variables
344 ;;; for unsupplied arguments to NIL. If a required argument is
345 ;;; missing, an unknown keyword is supplied, or an argument keyword is
346 ;;; not a constant, then the transform automatically passes. The
347 ;;; DECLARATIONS apply to the bindings made by DEFTRANSFORM at
348 ;;; transformation time, rather than to the variables of the resulting
349 ;;; lambda. Bound-but-not-referenced warnings are suppressed for the
350 ;;; lambda-list variables. The DOC-STRING is used when printing
351 ;;; efficiency notes about the defined transform.
353 ;;; Normally, the body evaluates to a form which becomes the body of
354 ;;; an automatically constructed lambda. We make LAMBDA-LIST the
355 ;;; lambda-list for the lambda, and automatically insert declarations
356 ;;; of the argument and result types. If the second value of the body
357 ;;; is non-null, then it is a list of declarations which are to be
358 ;;; inserted at the head of the lambda. Automatic lambda generation
359 ;;; may be inhibited by explicitly returning a lambda from the body.
361 ;;; The ARG-TYPES and RESULT-TYPE are used to create a function type
362 ;;; which the call must satisfy before transformation is attempted.
363 ;;; The function type specifier is constructed by wrapping (FUNCTION
364 ;;; ...) around these values, so the lack of a restriction may be
365 ;;; specified by omitting the argument or supplying *. The argument
366 ;;; syntax specified in the ARG-TYPES need not be the same as that in
367 ;;; the LAMBDA-LIST, but the transform will never happen if the
368 ;;; syntaxes can't be satisfied simultaneously. If there is an
369 ;;; existing transform for the same function that has the same type,
370 ;;; then it is replaced with the new definition.
372 ;;; These are the legal keyword options:
373 ;;; :RESULT - A variable which is bound to the result lvar.
374 ;;; :NODE - A variable which is bound to the combination node for the call.
375 ;;; :POLICY - A form which is supplied to the POLICY macro to determine
376 ;;; whether this transformation is appropriate. If the result
377 ;;; is false, then the transform automatically gives up.
379 ;;; - The name and argument/result types are actually forms to be
380 ;;; evaluated. Useful for getting closures that transform similar
383 ;;; - Don't actually instantiate a transform, instead just DEFUN
384 ;;; Name with the specified transform definition function. This
385 ;;; may be later instantiated with %DEFTRANSFORM.
387 ;;; - If supplied and non-NIL, note this transform as ``important,''
388 ;;; which means efficiency notes will be generated when this
389 ;;; transform fails even if INHIBIT-WARNINGS=SPEED (but not if
390 ;;; INHIBIT-WARNINGS>SPEED).
391 (defmacro deftransform (name (lambda-list &optional (arg-types '*)
393 &key result policy node defun-only
395 &body body-decls-doc)
396 (when (and eval-name defun-only)
397 (error "can't specify both DEFUN-ONLY and EVAL-NAME"))
398 (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
399 (let ((n-args (gensym))
400 (n-node (or node (gensym)))
403 (decls-body `(,@decls ,@body)))
404 (multiple-value-bind (parsed-form vars)
405 (parse-deftransform lambda-list
407 `((unless (policy ,n-node ,policy)
408 (give-up-ir1-transform))
412 '(give-up-ir1-transform))
415 (let* ((,n-args (basic-combination-args ,n-node))
417 `((,result (node-lvar ,n-node)))))
418 (multiple-value-bind (,n-lambda ,n-decls)
420 (if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda))
422 `(lambda ,',lambda-list
423 (declare (ignorable ,@',vars))
427 `(defun ,name ,@(when doc `(,doc)) ,@stuff)
429 ,(if eval-name name `',name)
431 ``(function ,,arg-types ,,result-type)
432 `'(function ,arg-types ,result-type))
435 ,(if important t nil))))))))
437 ;;;; DEFKNOWN and DEFOPTIMIZER
439 ;;; This macro should be the way that all implementation independent
440 ;;; information about functions is made known to the compiler.
442 ;;; FIXME: The comment above suggests that perhaps some of my added
443 ;;; FTYPE declarations are in poor taste. Should I change my
444 ;;; declarations, or change the comment, or what?
446 ;;; FIXME: DEFKNOWN is needed only at build-the-system time. Figure
447 ;;; out some way to keep it from appearing in the target system.
449 ;;; Declare the function NAME to be a known function. We construct a
450 ;;; type specifier for the function by wrapping (FUNCTION ...) around
451 ;;; the ARG-TYPES and RESULT-TYPE. ATTRIBUTES is an unevaluated list
452 ;;; of boolean attributes of the function. See their description in
453 ;;; (!DEF-BOOLEAN-ATTRIBUTE IR1). NAME may also be a list of names, in
454 ;;; which case the same information is given to all the names. The
455 ;;; keywords specify the initial values for various optimizers that
456 ;;; the function might have.
457 (defmacro defknown (name arg-types result-type &optional (attributes '(any))
459 (when (and (intersection attributes '(any call unwind))
460 (intersection attributes '(movable)))
461 (error "function cannot have both good and bad attributes: ~S" attributes))
463 (when (member 'any attributes)
464 (setq attributes (union '(call unsafe unwind) attributes)))
465 (when (member 'flushable attributes)
466 (pushnew 'unsafely-flushable attributes))
468 `(%defknown ',(if (and (consp name)
469 (not (legal-fun-name-p name)))
472 '(sfunction ,arg-types ,result-type)
473 (ir1-attributes ,@attributes)
476 ;;; Create a function which parses combination args according to WHAT
477 ;;; and LAMBDA-LIST, where WHAT is either a function name or a list
478 ;;; (FUN-NAME KIND) and does some KIND of optimization.
480 ;;; The FUN-NAME must name a known function. LAMBDA-LIST is used
481 ;;; to parse the arguments to the combination as in DEFTRANSFORM. If
482 ;;; the argument syntax is invalid or there are non-constant keys,
483 ;;; then we simply return NIL.
485 ;;; The function is DEFUN'ed as FUNCTION-KIND-OPTIMIZER. Possible
486 ;;; kinds are DERIVE-TYPE, OPTIMIZER, LTN-ANNOTATE and IR2-CONVERT. If
487 ;;; a symbol is specified instead of a (FUNCTION KIND) list, then we
488 ;;; just do a DEFUN with the symbol as its name, and don't do anything
489 ;;; with the definition. This is useful for creating optimizers to be
490 ;;; passed by name to DEFKNOWN.
492 ;;; If supplied, NODE-VAR is bound to the combination node being
493 ;;; optimized. If additional VARS are supplied, then they are used as
494 ;;; the rest of the optimizer function's lambda-list. LTN-ANNOTATE
495 ;;; methods are passed an additional POLICY argument, and IR2-CONVERT
496 ;;; methods are passed an additional IR2-BLOCK argument.
497 (defmacro defoptimizer (what (lambda-list &optional (n-node (gensym))
500 (let ((name (if (symbolp what) what
501 (symbolicate (first what) "-" (second what) "-OPTIMIZER"))))
503 (let ((n-args (gensym)))
505 (defun ,name (,n-node ,@vars)
506 (declare (ignorable ,@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 LVAR, binding NODE to each one
561 ;;; XXX Could change it not to replicate the code someday perhaps...
562 (defmacro do-uses ((node-var lvar &optional result) &body body)
563 (with-unique-names (uses)
564 `(let ((,uses (lvar-uses ,lvar)))
566 (dolist (,node-var ,uses ,result)
569 (let ((,node-var ,uses))
572 ;;; Iterate over the nodes in BLOCK, binding NODE-VAR to the each node
573 ;;; and LVAR-VAR to the node's LVAR. The only keyword option is
574 ;;; RESTART-P, which causes iteration to be restarted when a node is
575 ;;; deleted out from under us. (If not supplied, this is an error.)
577 ;;; In the forward case, we terminate when NODE does not have NEXT, so
578 ;;; that we do not have to worry about our termination condition being
579 ;;; changed when new code is added during the iteration. In the
580 ;;; backward case, we do NODE-PREV before evaluating the body so that
581 ;;; we can keep going when the current node is deleted.
583 ;;; When RESTART-P is supplied to DO-NODES, we start iterating over
584 ;;; again at the beginning of the block when we run into a ctran whose
585 ;;; block differs from the one we are trying to iterate over, either
586 ;;; because the block was split, or because a node was deleted out
587 ;;; from under us (hence its block is NIL.) If the block start is
588 ;;; deleted, we just punt. With RESTART-P, we are also more careful
589 ;;; about termination, re-indirecting the BLOCK-LAST each time.
590 (defmacro do-nodes ((node-var lvar-var block &key restart-p)
592 (with-unique-names (n-block n-start)
593 `(do* ((,n-block ,block)
594 (,n-start (block-start ,n-block))
596 (,node-var (ctran-next ,n-start)
598 `(let ((next (node-next ,node-var)))
602 ((eq (ctran-block next) ,n-block)
605 (let ((start (block-start ,n-block)))
606 (unless (eq (ctran-kind start)
609 (ctran-next start)))))
610 `(acond ((node-next ,node-var)
614 `((,lvar-var (when (valued-node-p ,node-var)
615 (node-lvar ,node-var))
616 (when (valued-node-p ,node-var)
617 (node-lvar ,node-var))))))
621 `((when (block-delete-p ,n-block)
624 ;;; Like DO-NODES, only iterating in reverse order. Should be careful
625 ;;; with block being split under us.
626 (defmacro do-nodes-backwards ((node-var lvar block &key restart-p) &body body)
627 (let ((n-block (gensym))
629 `(loop with ,n-block = ,block
630 for ,node-var = (block-last ,n-block) then
632 `(if (eq ,n-block (ctran-block ,n-prev))
634 (block-last ,n-block))
635 `(ctran-use ,n-prev))
636 for ,n-prev = (when ,node-var (node-prev ,node-var))
637 and ,lvar = (when (and ,node-var (valued-node-p ,node-var))
638 (node-lvar ,node-var))
640 `(and ,node-var (not (block-to-be-deleted-p ,n-block)))
645 (defmacro do-nodes-carefully ((node-var block) &body body)
646 (with-unique-names (n-block n-ctran)
647 `(loop with ,n-block = ,block
648 for ,n-ctran = (block-start ,n-block) then (node-next ,node-var)
649 for ,node-var = (and ,n-ctran (ctran-next ,n-ctran))
653 ;;; Bind the IR1 context variables to the values associated with NODE,
654 ;;; so that new, extra IR1 conversion related to NODE can be done
655 ;;; after the original conversion pass has finished.
656 (defmacro with-ir1-environment-from-node (node &rest forms)
657 `(flet ((closure-needing-ir1-environment-from-node ()
659 (%with-ir1-environment-from-node
661 #'closure-needing-ir1-environment-from-node)))
662 (defun %with-ir1-environment-from-node (node fun)
663 (declare (type node node) (type function fun))
664 (let ((*current-component* (node-component node))
665 (*lexenv* (node-lexenv node))
666 (*current-path* (node-source-path node)))
667 (aver-live-component *current-component*)
670 ;;; Bind the hashtables used for keeping track of global variables,
671 ;;; functions, etc. Also establish condition handlers.
672 (defmacro with-ir1-namespace (&body forms)
673 `(let ((*free-vars* (make-hash-table :test 'eq))
674 (*free-funs* (make-hash-table :test 'equal))
675 (*constants* (make-hash-table :test 'equal))
676 (*source-paths* (make-hash-table :test 'eq)))
677 (handler-bind ((compiler-error #'compiler-error-handler)
678 (style-warning #'compiler-style-warning-handler)
679 (warning #'compiler-warning-handler))
682 ;;; Look up NAME in the lexical environment namespace designated by
683 ;;; SLOT, returning the <value, T>, or <NIL, NIL> if no entry. The
684 ;;; :TEST keyword may be used to determine the name equality
686 (defmacro lexenv-find (name slot &key test)
687 (once-only ((n-res `(assoc ,name (,(let ((*package* (symbol-package 'lexenv-funs)))
688 (symbolicate "LEXENV-" slot))
690 :test ,(or test '#'eq))))
692 (values (cdr ,n-res) t)
695 (defmacro with-component-last-block ((component block) &body body)
696 (with-unique-names (old-last-block)
697 (once-only ((component component)
699 `(let ((,old-last-block (component-last-block ,component)))
701 (progn (setf (component-last-block ,component)
704 (setf (component-last-block ,component)
705 ,old-last-block))))))
708 ;;;; the EVENT statistics/trace utility
710 ;;; FIXME: This seems to be useful for troubleshooting and
711 ;;; experimentation, not for ordinary use, so it should probably
712 ;;; become conditional on SB-SHOW.
714 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
716 (defstruct (event-info (:copier nil))
717 ;; The name of this event.
718 (name (missing-arg) :type symbol)
719 ;; The string rescribing this event.
720 (description (missing-arg) :type string)
721 ;; The name of the variable we stash this in.
722 (var (missing-arg) :type symbol)
723 ;; The number of times this event has happened.
724 (count 0 :type fixnum)
725 ;; The level of significance of this event.
726 (level (missing-arg) :type unsigned-byte)
727 ;; If true, a function that gets called with the node that the event
729 (action nil :type (or function null)))
731 ;;; A hashtable from event names to event-info structures.
732 (defvar *event-info* (make-hash-table :test 'eq))
734 ;;; Return the event info for Name or die trying.
735 (declaim (ftype (function (t) event-info) event-info-or-lose))
736 (defun event-info-or-lose (name)
737 (let ((res (gethash name *event-info*)))
739 (error "~S is not the name of an event." name))
744 ;;; Return the number of times that EVENT has happened.
745 (declaim (ftype (function (symbol) fixnum) event-count))
746 (defun event-count (name)
747 (event-info-count (event-info-or-lose name)))
749 ;;; Return the function that is called when Event happens. If this is
750 ;;; null, there is no action. The function is passed the node to which
751 ;;; the event happened, or NIL if there is no relevant node. This may
752 ;;; be set with SETF.
753 (declaim (ftype (function (symbol) (or function null)) event-action))
754 (defun event-action (name)
755 (event-info-action (event-info-or-lose name)))
756 (declaim (ftype (function (symbol (or function null)) (or function null))
758 (defun %set-event-action (name new-value)
759 (setf (event-info-action (event-info-or-lose name))
761 (defsetf event-action %set-event-action)
763 ;;; Return the non-negative integer which represents the level of
764 ;;; significance of the event Name. This is used to determine whether
765 ;;; to print a message when the event happens. This may be set with
767 (declaim (ftype (function (symbol) unsigned-byte) event-level))
768 (defun event-level (name)
769 (event-info-level (event-info-or-lose name)))
770 (declaim (ftype (function (symbol unsigned-byte) unsigned-byte) %set-event-level))
771 (defun %set-event-level (name new-value)
772 (setf (event-info-level (event-info-or-lose name))
774 (defsetf event-level %set-event-level)
776 ;;; Define a new kind of event. NAME is a symbol which names the event
777 ;;; and DESCRIPTION is a string which describes the event. Level
778 ;;; (default 0) is the level of significance associated with this
779 ;;; event; it is used to determine whether to print a Note when the
781 (defmacro defevent (name description &optional (level 0))
782 (let ((var-name (symbolicate "*" name "-EVENT-INFO*")))
783 `(eval-when (:compile-toplevel :load-toplevel :execute)
785 (make-event-info :name ',name
786 :description ',description
789 (setf (gethash ',name *event-info*) ,var-name)
792 ;;; the lowest level of event that will print a note when it occurs
793 (declaim (type unsigned-byte *event-note-threshold*))
794 (defvar *event-note-threshold* 1)
796 ;;; Note that the event with the specified NAME has happened. NODE is
797 ;;; evaluated to determine the node to which the event happened.
798 (defmacro event (name &optional node)
799 ;; Increment the counter and do any action. Mumble about the event if
801 `(%event ,(event-info-var (event-info-or-lose name)) ,node))
803 ;;; Print a listing of events and their counts, sorted by the count.
804 ;;; Events that happened fewer than Min-Count times will not be
805 ;;; printed. Stream is the stream to write to.
806 (declaim (ftype (function (&optional unsigned-byte stream) (values)) event-statistics))
807 (defun event-statistics (&optional (min-count 1) (stream *standard-output*))
809 (maphash (lambda (k v)
811 (when (>= (event-info-count v) min-count)
814 (dolist (event (sort (info) #'> :key #'event-info-count))
815 (format stream "~6D: ~A~%" (event-info-count event)
816 (event-info-description event)))
820 (declaim (ftype (function nil (values)) clear-event-statistics))
821 (defun clear-event-statistics ()
822 (maphash (lambda (k v)
824 (setf (event-info-count v) 0))
828 ;;;; functions on directly-linked lists (linked through specialized
829 ;;;; NEXT operations)
831 #!-sb-fluid (declaim (inline find-in position-in))
833 ;;; Find ELEMENT in a null-terminated LIST linked by the accessor
834 ;;; function NEXT. KEY, TEST and TEST-NOT are the same as for generic
835 ;;; sequence functions.
842 (test-not #'eql not-p))
843 (declare (type function next key test test-not))
844 (when (and test-p not-p)
845 (error "It's silly to supply both :TEST and :TEST-NOT arguments."))
847 (do ((current list (funcall next current)))
849 (unless (funcall test-not (funcall key current) element)
851 (do ((current list (funcall next current)))
853 (when (funcall test (funcall key current) element)
856 ;;; Return the position of ELEMENT (or NIL if absent) in a
857 ;;; null-terminated LIST linked by the accessor function NEXT. KEY,
858 ;;; TEST and TEST-NOT are the same as for generic sequence functions.
859 (defun position-in (next
865 (test-not #'eql not-p))
866 (declare (type function next key test test-not))
867 (when (and test-p not-p)
868 (error "It's silly to supply both :TEST and :TEST-NOT arguments."))
870 (do ((current list (funcall next current))
873 (unless (funcall test-not (funcall key current) element)
875 (do ((current list (funcall next current))
878 (when (funcall test (funcall key current) element)
882 ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
883 ;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
885 ;;; (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
886 ;;; arrangement, in order to get it to work in cross-compilation. This
887 ;;; duplication should be removed, perhaps by rewriting the macro in a more
888 ;;; cross-compiler-friendly way, or perhaps just by using some (MACROLET ((FROB
889 ;;; ..)) .. FROB .. FROB) form, or perhaps by completely eliminating this macro
890 ;;; and its partner PUSH-IN, but I don't want to do it now, because the system
891 ;;; isn't running yet, so it'd be too hard to check that my changes were
892 ;;; correct -- WHN 19990806
893 (def!macro deletef-in (next place item &environment env)
894 (multiple-value-bind (temps vals stores store access)
895 (get-setf-expansion place env)
897 (error "multiple store variables for ~S" place))
898 (let ((n-item (gensym))
902 `(let* (,@(mapcar #'list temps vals)
905 (if (eq ,n-place ,n-item)
906 (let ((,(first stores) (,next ,n-place)))
908 (do ((,n-prev ,n-place ,n-current)
909 (,n-current (,next ,n-place)
911 ((eq ,n-current ,n-item)
912 (setf (,next ,n-prev)
913 (,next ,n-current)))))
915 ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
917 ;;; Push ITEM onto a list linked by the accessor function NEXT that is
920 ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
921 ;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
923 ;;; (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
924 ;;; arrangement, in order to get it to work in cross-compilation. This
925 ;;; duplication should be removed, perhaps by rewriting the macro in a more
926 ;;; cross-compiler-friendly way, or perhaps just by using some (MACROLET ((FROB
927 ;;; ..)) .. FROB .. FROB) form, or perhaps by completely eliminating this macro
928 ;;; and its partner DELETEF-IN, but I don't want to do it now, because the
929 ;;; system isn't running yet, so it'd be too hard to check that my changes were
930 ;;; correct -- WHN 19990806
931 (def!macro push-in (next item place &environment env)
932 (multiple-value-bind (temps vals stores store access)
933 (get-setf-expansion place env)
935 (error "multiple store variables for ~S" place))
936 `(let (,@(mapcar #'list temps vals)
937 (,(first stores) ,item))
938 (setf (,next ,(first stores)) ,access)
941 ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
943 (defmacro position-or-lose (&rest args)
944 `(or (position ,@args)
945 (error "shouldn't happen?")))