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
45 ;;; list. START-VAR, NEXT-VAR and RESULT-VAR are bound to the start and
46 ;;; result continuations for the resulting IR1. KIND is the function
47 ;;; kind to associate with NAME.
48 (defmacro def-ir1-translator (name (lambda-list start-var next-var result-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
60 (declaim (ftype (function (ctran ctran (or lvar null) t) (values))
62 (defun ,fn-name (,start-var ,next-var ,result-var ,n-form)
63 (let ((,n-env *lexenv*))
68 `((setf (fdocumentation ',name 'function) ,doc)))
69 ;; FIXME: Evidently "there can only be one!" -- we overwrite any
70 ;; other :IR1-CONVERT value. This deserves a warning, I think.
71 (setf (info :function :ir1-convert ',name) #',fn-name)
72 (setf (info :function :kind ',name) ,kind)
73 ;; It's nice to do this for error checking in the target
74 ;; SBCL, but it's not nice to do this when we're running in
75 ;; the cross-compilation host Lisp, which owns the
76 ;; SYMBOL-FUNCTION of its COMMON-LISP symbols.
78 ,@(when (eq kind :special-form)
79 `((setf (symbol-function ',name)
81 (declare (ignore rest))
82 (error 'special-form-function
85 ;;; (This is similar to DEF-IR1-TRANSLATOR, except that we pass if the
86 ;;; syntax is invalid.)
88 ;;; Define a macro-like source-to-source transformation for the
89 ;;; function NAME. A source transform may "pass" by returning a
90 ;;; non-nil second value. If the transform passes, then the form is
91 ;;; converted as a normal function call. If the supplied arguments are
92 ;;; not compatible with the specified LAMBDA-LIST, then the transform
93 ;;; automatically passes.
95 ;;; Source transforms may only be defined for functions. Source
96 ;;; transformation is not attempted if the function is declared
97 ;;; NOTINLINE. Source transforms should not examine their arguments.
98 ;;; If it matters how the function is used, then DEFTRANSFORM should
99 ;;; be used to define an IR1 transformation.
101 ;;; If the desirability of the transformation depends on the current
102 ;;; OPTIMIZE parameters, then the POLICY macro should be used to
103 ;;; determine when to pass.
104 (defmacro source-transform-lambda (lambda-list &body body)
105 (let ((n-form (gensym))
108 (multiple-value-bind (body decls)
109 (parse-defmacro lambda-list n-form body "source transform" "form"
111 :error-fun `(lambda (&rest stuff)
112 (declare (ignore stuff))
116 `(lambda (,n-form &aux (,n-env *lexenv*))
120 (defmacro define-source-transform (name lambda-list &body body)
121 `(setf (info :function :source-transform ',name)
122 (source-transform-lambda ,lambda-list ,@body)))
124 ;;;; boolean attribute utilities
126 ;;;; We need to maintain various sets of boolean attributes for known
127 ;;;; functions and VOPs. To save space and allow for quick set
128 ;;;; operations, we represent the attributes as bits in a fixnum.
130 (deftype attributes () 'fixnum)
132 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
134 ;;; Given a list of attribute names and an alist that translates them
135 ;;; to masks, return the OR of the masks.
136 (defun compute-attribute-mask (names alist)
137 (collect ((res 0 logior))
139 (let ((mask (cdr (assoc name alist))))
141 (error "unknown attribute name: ~S" name))
147 ;;; Define a new class of boolean attributes, with the attributes
148 ;;; having the specified ATTRIBUTE-NAMES. NAME is the name of the
149 ;;; class, which is used to generate some macros to manipulate sets of
152 ;;; NAME-attributep attributes attribute-name*
153 ;;; Return true if one of the named attributes is present, false
154 ;;; otherwise. When set with SETF, updates the place Attributes
155 ;;; setting or clearing the specified attributes.
157 ;;; NAME-attributes attribute-name*
158 ;;; Return a set of the named attributes.
161 (def!macro !def-boolean-attribute (name &rest attribute-names)
163 (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
164 (test-name (symbolicate name "-ATTRIBUTEP"))
165 (decoder-name (symbolicate "DECODE-" name "-ATTRIBUTES")))
167 (do ((mask 1 (ash mask 1))
168 (names attribute-names (cdr names)))
170 (alist (cons (car names) mask)))
172 (eval-when (:compile-toplevel :load-toplevel :execute)
173 (defparameter ,translations-name ',(alist)))
174 (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
175 "Automagically generated boolean attribute creation function.
176 See !DEF-BOOLEAN-ATTRIBUTE."
177 (compute-attribute-mask attribute-names ,translations-name))
178 (defmacro ,test-name (attributes &rest attribute-names)
179 "Automagically generated boolean attribute test function.
180 See !DEF-BOOLEAN-ATTRIBUTE."
181 `(logtest ,(compute-attribute-mask attribute-names
183 (the attributes ,attributes)))
184 ;; This definition transforms strangely under UNCROSS, in a
185 ;; way that DEF!MACRO doesn't understand, so we delegate it
186 ;; to a submacro then define the submacro differently when
187 ;; building the xc and when building the target compiler.
188 (!def-boolean-attribute-setter ,test-name
191 (defun ,decoder-name (attributes)
192 (loop for (name . mask) in ,translations-name
193 when (logtest mask attributes)
196 ;; It seems to be difficult to express in DEF!MACRO machinery what
197 ;; to do with target-vs-host GET-SETF-EXPANSION in here, so we just
198 ;; hack it by hand, passing a different GET-SETF-EXPANSION-FUN-NAME
199 ;; in the host DEFMACRO and target DEFMACRO-MUNDANELY cases.
200 (defun guts-of-!def-boolean-attribute-setter (test-name
203 get-setf-expansion-fun-name)
204 `(define-setf-expander ,test-name (place &rest attributes
206 "Automagically generated boolean attribute setter. See
207 !DEF-BOOLEAN-ATTRIBUTE."
208 #-sb-xc-host (declare (type sb!c::lexenv env))
209 ;; FIXME: It would be better if &ENVIRONMENT arguments were
210 ;; automatically declared to have type LEXENV by the
211 ;; hairy-argument-handling code.
212 (multiple-value-bind (temps values stores set get)
213 (,get-setf-expansion-fun-name place env)
215 (error "multiple store variables for ~S" place))
216 (let ((newval (gensym))
218 (mask (compute-attribute-mask attributes ,translations-name)))
219 (values `(,@temps ,n-place)
222 `(let ((,(first stores)
224 (logior ,n-place ,mask)
225 (logand ,n-place ,(lognot mask)))))
228 `(,',test-name ,n-place ,@attributes))))))
229 ;; We define the host version here, and the just-like-it-but-different
230 ;; target version later, after DEFMACRO-MUNDANELY has been defined.
231 (defmacro !def-boolean-attribute-setter (test-name
233 &rest attribute-names)
234 (guts-of-!def-boolean-attribute-setter test-name
237 'get-setf-expansion)))
239 ;;; And now for some gratuitous pseudo-abstraction...
242 ;;; Return the union of all the sets of boolean attributes which are its
244 ;;; ATTRIBUTES-INTERSECTION
245 ;;; Return the intersection of all the sets of boolean attributes which
246 ;;; are its arguments.
248 ;;; True if the attributes present in ATTR1 are identical to
250 (defmacro attributes-union (&rest attributes)
252 (logior ,@(mapcar (lambda (x) `(the attributes ,x)) attributes))))
253 (defmacro attributes-intersection (&rest attributes)
255 (logand ,@(mapcar (lambda (x) `(the attributes ,x)) attributes))))
256 (declaim (ftype (function (attributes attributes) boolean) attributes=))
257 #!-sb-fluid (declaim (inline attributes=))
258 (defun attributes= (attr1 attr2)
261 ;;;; lambda-list parsing utilities
263 ;;;; IR1 transforms, optimizers and type inferencers need to be able
264 ;;;; to parse the IR1 representation of a function call using a
265 ;;;; standard function lambda-list.
267 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
269 ;;; Given a DEFTRANSFORM-style lambda-list, generate code that parses
270 ;;; the arguments of a combination with respect to that
271 ;;; lambda-list. BODY is the the list of forms which are to be
272 ;;; evaluated within the bindings. ARGS is the variable that holds
273 ;;; list of argument lvars. ERROR-FORM is a form which is evaluated
274 ;;; when the syntax of the supplied arguments is incorrect or a
275 ;;; non-constant argument keyword is supplied. Defaults and other gunk
276 ;;; are ignored. The second value is a list of all the arguments
277 ;;; bound. We make the variables IGNORABLE so that we don't have to
278 ;;; manually declare them Ignore if their only purpose is to make the
280 (defun parse-deftransform (lambda-list body args error-form)
281 (multiple-value-bind (req opt restp rest keyp keys allowp)
282 (parse-lambda-list lambda-list)
283 (let* ((min-args (length req))
284 (max-args (+ min-args (length opt)))
292 (binds `(,arg (nth ,(pos) ,args)))
296 (let ((var (if (atom arg) arg (first arg))))
298 (binds `(,var (nth ,(pos) ,args)))
303 (binds `(,rest (nthcdr ,(pos) ,args))))
306 (if (or (atom spec) (atom (first spec)))
307 (let* ((var (if (atom spec) spec (first spec)))
308 (key (keywordicate var)))
310 (binds `(,var (find-keyword-lvar ,n-keys ,key)))
312 (let* ((head (first spec))
316 (binds `(,var (find-keyword-lvar ,n-keys ,key)))
319 (let ((n-length (gensym))
320 (limited-legal (not (or restp keyp))))
322 `(let ((,n-length (length ,args))
323 ,@(when keyp `((,n-keys (nthcdr ,(pos) ,args)))))
325 ;; FIXME: should be PROPER-LIST-OF-LENGTH-P
327 `(<= ,min-args ,n-length ,max-args)
328 `(<= ,min-args ,n-length))
331 `((check-key-args-constant ,n-keys))
332 `((check-transform-keys ,n-keys ',(keywords))))))
335 (declare (ignorable ,@(vars)))
343 ;;; Define an IR1 transformation for NAME. An IR1 transformation
344 ;;; computes a lambda that replaces the function variable reference
345 ;;; for the call. A transform may pass (decide not to transform the
346 ;;; call) by calling the GIVE-UP-IR1-TRANSFORM function. LAMBDA-LIST
347 ;;; both determines how the current call is parsed and specifies the
348 ;;; LAMBDA-LIST for the resulting lambda.
350 ;;; We parse the call and bind each of the lambda-list variables to
351 ;;; the lvar which represents the value of the argument. When parsing
352 ;;; the call, we ignore the defaults, and always bind the variables
353 ;;; for unsupplied arguments to NIL. If a required argument is
354 ;;; missing, an unknown keyword is supplied, or an argument keyword is
355 ;;; not a constant, then the transform automatically passes. The
356 ;;; DECLARATIONS apply to the bindings made by DEFTRANSFORM at
357 ;;; transformation time, rather than to the variables of the resulting
358 ;;; lambda. Bound-but-not-referenced warnings are suppressed for the
359 ;;; lambda-list variables. The DOC-STRING is used when printing
360 ;;; efficiency notes about the defined transform.
362 ;;; Normally, the body evaluates to a form which becomes the body of
363 ;;; an automatically constructed lambda. We make LAMBDA-LIST the
364 ;;; lambda-list for the lambda, and automatically insert declarations
365 ;;; of the argument and result types. If the second value of the body
366 ;;; is non-null, then it is a list of declarations which are to be
367 ;;; inserted at the head of the lambda. Automatic lambda generation
368 ;;; may be inhibited by explicitly returning a lambda from the body.
370 ;;; The ARG-TYPES and RESULT-TYPE are used to create a function type
371 ;;; which the call must satisfy before transformation is attempted.
372 ;;; The function type specifier is constructed by wrapping (FUNCTION
373 ;;; ...) around these values, so the lack of a restriction may be
374 ;;; specified by omitting the argument or supplying *. The argument
375 ;;; syntax specified in the ARG-TYPES need not be the same as that in
376 ;;; the LAMBDA-LIST, but the transform will never happen if the
377 ;;; syntaxes can't be satisfied simultaneously. If there is an
378 ;;; existing transform for the same function that has the same type,
379 ;;; then it is replaced with the new definition.
381 ;;; These are the legal keyword options:
382 ;;; :RESULT - A variable which is bound to the result lvar.
383 ;;; :NODE - A variable which is bound to the combination node for the call.
384 ;;; :POLICY - A form which is supplied to the POLICY macro to determine
385 ;;; whether this transformation is appropriate. If the result
386 ;;; is false, then the transform automatically gives up.
388 ;;; - The name and argument/result types are actually forms to be
389 ;;; evaluated. Useful for getting closures that transform similar
392 ;;; - Don't actually instantiate a transform, instead just DEFUN
393 ;;; Name with the specified transform definition function. This
394 ;;; may be later instantiated with %DEFTRANSFORM.
396 ;;; - If supplied and non-NIL, note this transform as ``important,''
397 ;;; which means efficiency notes will be generated when this
398 ;;; transform fails even if INHIBIT-WARNINGS=SPEED (but not if
399 ;;; INHIBIT-WARNINGS>SPEED).
400 (defmacro deftransform (name (lambda-list &optional (arg-types '*)
402 &key result policy node defun-only
404 &body body-decls-doc)
405 (when (and eval-name defun-only)
406 (error "can't specify both DEFUN-ONLY and EVAL-NAME"))
407 (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
408 (let ((n-args (gensym))
409 (n-node (or node (gensym)))
412 (decls-body `(,@decls ,@body)))
413 (multiple-value-bind (parsed-form vars)
414 (parse-deftransform lambda-list
416 `((unless (policy ,n-node ,policy)
417 (give-up-ir1-transform))
421 '(give-up-ir1-transform))
424 (let* ((,n-args (basic-combination-args ,n-node))
426 `((,result (node-lvar ,n-node)))))
427 (multiple-value-bind (,n-lambda ,n-decls)
429 (if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda))
431 `(lambda ,',lambda-list
432 (declare (ignorable ,@',vars))
436 `(defun ,name ,@(when doc `(,doc)) ,@stuff)
438 ,(if eval-name name `',name)
440 ``(function ,,arg-types ,,result-type)
441 `'(function ,arg-types ,result-type))
444 ,(if important t nil))))))))
446 ;;;; DEFKNOWN and DEFOPTIMIZER
448 ;;; This macro should be the way that all implementation independent
449 ;;; information about functions is made known to the compiler.
451 ;;; FIXME: The comment above suggests that perhaps some of my added
452 ;;; FTYPE declarations are in poor taste. Should I change my
453 ;;; declarations, or change the comment, or what?
455 ;;; FIXME: DEFKNOWN is needed only at build-the-system time. Figure
456 ;;; out some way to keep it from appearing in the target system.
458 ;;; Declare the function NAME to be a known function. We construct a
459 ;;; type specifier for the function by wrapping (FUNCTION ...) around
460 ;;; the ARG-TYPES and RESULT-TYPE. ATTRIBUTES is an unevaluated list
461 ;;; of boolean attributes of the function. See their description in
462 ;;; (!DEF-BOOLEAN-ATTRIBUTE IR1). NAME may also be a list of names, in
463 ;;; which case the same information is given to all the names. The
464 ;;; keywords specify the initial values for various optimizers that
465 ;;; the function might have.
466 (defmacro defknown (name arg-types result-type &optional (attributes '(any))
468 (when (and (intersection attributes '(any call unwind))
469 (intersection attributes '(movable)))
470 (error "function cannot have both good and bad attributes: ~S" attributes))
472 (when (member 'any attributes)
473 (setq attributes (union '(call unsafe unwind) attributes)))
474 (when (member 'flushable attributes)
475 (pushnew 'unsafely-flushable attributes))
477 `(%defknown ',(if (and (consp name)
478 (not (legal-fun-name-p name)))
481 '(sfunction ,arg-types ,result-type)
482 (ir1-attributes ,@attributes)
485 ;;; Create a function which parses combination args according to WHAT
486 ;;; and LAMBDA-LIST, where WHAT is either a function name or a list
487 ;;; (FUN-NAME KIND) and does some KIND of optimization.
489 ;;; The FUN-NAME must name a known function. LAMBDA-LIST is used
490 ;;; to parse the arguments to the combination as in DEFTRANSFORM. If
491 ;;; the argument syntax is invalid or there are non-constant keys,
492 ;;; then we simply return NIL.
494 ;;; The function is DEFUN'ed as FUNCTION-KIND-OPTIMIZER. Possible
495 ;;; kinds are DERIVE-TYPE, OPTIMIZER, LTN-ANNOTATE and IR2-CONVERT. If
496 ;;; a symbol is specified instead of a (FUNCTION KIND) list, then we
497 ;;; just do a DEFUN with the symbol as its name, and don't do anything
498 ;;; with the definition. This is useful for creating optimizers to be
499 ;;; passed by name to DEFKNOWN.
501 ;;; If supplied, NODE-VAR is bound to the combination node being
502 ;;; optimized. If additional VARS are supplied, then they are used as
503 ;;; the rest of the optimizer function's lambda-list. LTN-ANNOTATE
504 ;;; methods are passed an additional POLICY argument, and IR2-CONVERT
505 ;;; methods are passed an additional IR2-BLOCK argument.
506 (defmacro defoptimizer (what (lambda-list &optional (n-node (gensym))
509 (let ((name (if (symbolp what) what
510 (symbolicate (first what) "-" (second what) "-OPTIMIZER"))))
512 (let ((n-args (gensym)))
514 (defun ,name (,n-node ,@vars)
515 (let ((,n-args (basic-combination-args ,n-node)))
516 ,(parse-deftransform lambda-list body n-args
517 `(return-from ,name nil))))
519 `((setf (,(symbolicate "FUN-INFO-" (second what))
520 (fun-info-or-lose ',(first what)))
523 ;;;; IR groveling macros
525 ;;; Iterate over the blocks in a component, binding BLOCK-VAR to each
526 ;;; block in turn. The value of ENDS determines whether to iterate
527 ;;; over dummy head and tail blocks:
528 ;;; NIL -- Skip Head and Tail (the default)
529 ;;; :HEAD -- Do head but skip tail
530 ;;; :TAIL -- Do tail but skip head
531 ;;; :BOTH -- Do both head and tail
533 ;;; If supplied, RESULT-FORM is the value to return.
534 (defmacro do-blocks ((block-var component &optional ends result) &body body)
535 (unless (member ends '(nil :head :tail :both))
536 (error "losing ENDS value: ~S" ends))
537 (let ((n-component (gensym))
539 `(let* ((,n-component ,component)
540 (,n-tail ,(if (member ends '(:both :tail))
542 `(component-tail ,n-component))))
543 (do ((,block-var ,(if (member ends '(:both :head))
544 `(component-head ,n-component)
545 `(block-next (component-head ,n-component)))
546 (block-next ,block-var)))
547 ((eq ,block-var ,n-tail) ,result)
549 ;;; like DO-BLOCKS, only iterating over the blocks in reverse order
550 (defmacro do-blocks-backwards ((block-var component &optional ends result) &body body)
551 (unless (member ends '(nil :head :tail :both))
552 (error "losing ENDS value: ~S" ends))
553 (let ((n-component (gensym))
555 `(let* ((,n-component ,component)
556 (,n-head ,(if (member ends '(:both :head))
558 `(component-head ,n-component))))
559 (do ((,block-var ,(if (member ends '(:both :tail))
560 `(component-tail ,n-component)
561 `(block-prev (component-tail ,n-component)))
562 (block-prev ,block-var)))
563 ((eq ,block-var ,n-head) ,result)
566 ;;; Iterate over the uses of LVAR, binding NODE to each one
569 ;;; XXX Could change it not to replicate the code someday perhaps...
570 (defmacro do-uses ((node-var lvar &optional result) &body body)
571 (with-unique-names (uses)
572 `(let ((,uses (lvar-uses ,lvar)))
574 (dolist (,node-var ,uses ,result)
577 (let ((,node-var ,uses))
580 ;;; Iterate over the nodes in BLOCK, binding NODE-VAR to the each node
581 ;;; and LVAR-VAR to the node's LVAR. The only keyword option is
582 ;;; RESTART-P, which causes iteration to be restarted when a node is
583 ;;; deleted out from under us. (If not supplied, this is an error.)
585 ;;; In the forward case, we terminate when NODE does not have NEXT, so
586 ;;; that we do not have to worry about our termination condition being
587 ;;; changed when new code is added during the iteration. In the
588 ;;; backward case, we do NODE-PREV before evaluating the body so that
589 ;;; we can keep going when the current node is deleted.
591 ;;; When RESTART-P is supplied to DO-NODES, we start iterating over
592 ;;; again at the beginning of the block when we run into a ctran whose
593 ;;; block differs from the one we are trying to iterate over, either
594 ;;; because the block was split, or because a node was deleted out
595 ;;; from under us (hence its block is NIL.) If the block start is
596 ;;; deleted, we just punt. With RESTART-P, we are also more careful
597 ;;; about termination, re-indirecting the BLOCK-LAST each time.
598 (defmacro do-nodes ((node-var lvar-var block &key restart-p)
600 (with-unique-names (n-block n-start)
601 `(do* ((,n-block ,block)
602 (,n-start (block-start ,n-block))
604 (,node-var (ctran-next ,n-start)
606 `(let ((next (node-next ,node-var)))
610 ((eq (ctran-block next) ,n-block)
613 (let ((start (block-start ,n-block)))
614 (unless (eq (ctran-kind start)
617 (ctran-next start)))))
618 `(acond ((node-next ,node-var)
622 `((,lvar-var (when (valued-node-p ,node-var)
623 (node-lvar ,node-var))
624 (when (valued-node-p ,node-var)
625 (node-lvar ,node-var))))))
629 `((when (block-delete-p ,n-block)
632 ;;; Like DO-NODES, only iterating in reverse order. Should be careful
633 ;;; with block being split under us.
634 (defmacro do-nodes-backwards ((node-var lvar block &key restart-p) &body body)
635 (let ((n-block (gensym))
637 `(loop with ,n-block = ,block
638 for ,node-var = (block-last ,n-block) then
640 `(if (eq ,n-block (ctran-block ,n-prev))
642 (block-last ,n-block))
643 `(ctran-use ,n-prev))
644 for ,n-prev = (when ,node-var (node-prev ,node-var))
645 and ,lvar = (when (and ,node-var (valued-node-p ,node-var))
646 (node-lvar ,node-var))
648 `(and ,node-var (not (block-to-be-deleted-p ,n-block)))
653 (defmacro do-nodes-carefully ((node-var block) &body body)
654 (with-unique-names (n-block n-ctran)
655 `(loop with ,n-block = ,block
656 for ,n-ctran = (block-start ,n-block) then (node-next ,node-var)
657 for ,node-var = (and ,n-ctran (ctran-next ,n-ctran))
661 ;;; Bind the IR1 context variables to the values associated with NODE,
662 ;;; so that new, extra IR1 conversion related to NODE can be done
663 ;;; after the original conversion pass has finished.
664 (defmacro with-ir1-environment-from-node (node &rest forms)
665 `(flet ((closure-needing-ir1-environment-from-node ()
667 (%with-ir1-environment-from-node
669 #'closure-needing-ir1-environment-from-node)))
670 (defun %with-ir1-environment-from-node (node fun)
671 (declare (type node node) (type function fun))
672 (let ((*current-component* (node-component node))
673 (*lexenv* (node-lexenv node))
674 (*current-path* (node-source-path node)))
675 (aver-live-component *current-component*)
678 ;;; Bind the hashtables used for keeping track of global variables,
679 ;;; functions, etc. Also establish condition handlers.
680 (defmacro with-ir1-namespace (&body forms)
681 `(let ((*free-vars* (make-hash-table :test 'eq))
682 (*free-funs* (make-hash-table :test 'equal))
683 (*constants* (make-hash-table :test 'equal))
684 (*source-paths* (make-hash-table :test 'eq)))
685 (handler-bind ((compiler-error #'compiler-error-handler)
686 (style-warning #'compiler-style-warning-handler)
687 (warning #'compiler-warning-handler))
690 ;;; Look up NAME in the lexical environment namespace designated by
691 ;;; SLOT, returning the <value, T>, or <NIL, NIL> if no entry. The
692 ;;; :TEST keyword may be used to determine the name equality
694 (defmacro lexenv-find (name slot &key test)
695 (once-only ((n-res `(assoc ,name (,(let ((*package* (symbol-package 'lexenv-funs)))
696 (symbolicate "LEXENV-" slot))
698 :test ,(or test '#'eq))))
700 (values (cdr ,n-res) t)
703 (defmacro with-component-last-block ((component block) &body body)
704 (with-unique-names (old-last-block)
705 (once-only ((component component)
707 `(let ((,old-last-block (component-last-block ,component)))
709 (progn (setf (component-last-block ,component)
712 (setf (component-last-block ,component)
713 ,old-last-block))))))
716 ;;;; the EVENT statistics/trace utility
718 ;;; FIXME: This seems to be useful for troubleshooting and
719 ;;; experimentation, not for ordinary use, so it should probably
720 ;;; become conditional on SB-SHOW.
722 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
724 (defstruct (event-info (:copier nil))
725 ;; The name of this event.
726 (name (missing-arg) :type symbol)
727 ;; The string rescribing this event.
728 (description (missing-arg) :type string)
729 ;; The name of the variable we stash this in.
730 (var (missing-arg) :type symbol)
731 ;; The number of times this event has happened.
732 (count 0 :type fixnum)
733 ;; The level of significance of this event.
734 (level (missing-arg) :type unsigned-byte)
735 ;; If true, a function that gets called with the node that the event
737 (action nil :type (or function null)))
739 ;;; A hashtable from event names to event-info structures.
740 (defvar *event-info* (make-hash-table :test 'eq))
742 ;;; Return the event info for Name or die trying.
743 (declaim (ftype (function (t) event-info) event-info-or-lose))
744 (defun event-info-or-lose (name)
745 (let ((res (gethash name *event-info*)))
747 (error "~S is not the name of an event." name))
752 ;;; Return the number of times that EVENT has happened.
753 (declaim (ftype (function (symbol) fixnum) event-count))
754 (defun event-count (name)
755 (event-info-count (event-info-or-lose name)))
757 ;;; Return the function that is called when Event happens. If this is
758 ;;; null, there is no action. The function is passed the node to which
759 ;;; the event happened, or NIL if there is no relevant node. This may
760 ;;; be set with SETF.
761 (declaim (ftype (function (symbol) (or function null)) event-action))
762 (defun event-action (name)
763 (event-info-action (event-info-or-lose name)))
764 (declaim (ftype (function (symbol (or function null)) (or function null))
766 (defun %set-event-action (name new-value)
767 (setf (event-info-action (event-info-or-lose name))
769 (defsetf event-action %set-event-action)
771 ;;; Return the non-negative integer which represents the level of
772 ;;; significance of the event Name. This is used to determine whether
773 ;;; to print a message when the event happens. This may be set with
775 (declaim (ftype (function (symbol) unsigned-byte) event-level))
776 (defun event-level (name)
777 (event-info-level (event-info-or-lose name)))
778 (declaim (ftype (function (symbol unsigned-byte) unsigned-byte) %set-event-level))
779 (defun %set-event-level (name new-value)
780 (setf (event-info-level (event-info-or-lose name))
782 (defsetf event-level %set-event-level)
784 ;;; Define a new kind of event. NAME is a symbol which names the event
785 ;;; and DESCRIPTION is a string which describes the event. Level
786 ;;; (default 0) is the level of significance associated with this
787 ;;; event; it is used to determine whether to print a Note when the
789 (defmacro defevent (name description &optional (level 0))
790 (let ((var-name (symbolicate "*" name "-EVENT-INFO*")))
791 `(eval-when (:compile-toplevel :load-toplevel :execute)
793 (make-event-info :name ',name
794 :description ',description
797 (setf (gethash ',name *event-info*) ,var-name)
800 ;;; the lowest level of event that will print a note when it occurs
801 (declaim (type unsigned-byte *event-note-threshold*))
802 (defvar *event-note-threshold* 1)
804 ;;; Note that the event with the specified NAME has happened. NODE is
805 ;;; evaluated to determine the node to which the event happened.
806 (defmacro event (name &optional node)
807 ;; Increment the counter and do any action. Mumble about the event if
809 `(%event ,(event-info-var (event-info-or-lose name)) ,node))
811 ;;; Print a listing of events and their counts, sorted by the count.
812 ;;; Events that happened fewer than Min-Count times will not be
813 ;;; printed. Stream is the stream to write to.
814 (declaim (ftype (function (&optional unsigned-byte stream) (values)) event-statistics))
815 (defun event-statistics (&optional (min-count 1) (stream *standard-output*))
817 (maphash (lambda (k v)
819 (when (>= (event-info-count v) min-count)
822 (dolist (event (sort (info) #'> :key #'event-info-count))
823 (format stream "~6D: ~A~%" (event-info-count event)
824 (event-info-description event)))
828 (declaim (ftype (function nil (values)) clear-event-statistics))
829 (defun clear-event-statistics ()
830 (maphash (lambda (k v)
832 (setf (event-info-count v) 0))
836 ;;;; functions on directly-linked lists (linked through specialized
837 ;;;; NEXT operations)
839 #!-sb-fluid (declaim (inline find-in position-in))
841 ;;; Find ELEMENT in a null-terminated LIST linked by the accessor
842 ;;; function NEXT. KEY, TEST and TEST-NOT are the same as for generic
843 ;;; sequence functions.
850 (test-not #'eql not-p))
851 (declare (type function next key test test-not))
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 #'eql not-p))
874 (declare (type function next key test test-not))
875 (when (and test-p not-p)
876 (error "It's silly to supply both :TEST and :TEST-NOT arguments."))
878 (do ((current list (funcall next current))
881 (unless (funcall test-not (funcall key current) element)
883 (do ((current list (funcall next current))
886 (when (funcall test (funcall key current) element)
890 ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
891 ;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
893 ;;; (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
894 ;;; arrangement, in order to get it to work in cross-compilation. This
895 ;;; duplication should be removed, perhaps by rewriting the macro in a more
896 ;;; cross-compiler-friendly way, or perhaps just by using some (MACROLET ((FROB
897 ;;; ..)) .. FROB .. FROB) form, or perhaps by completely eliminating this macro
898 ;;; and its partner PUSH-IN, but I don't want to do it now, because the system
899 ;;; isn't running yet, so it'd be too hard to check that my changes were
900 ;;; correct -- WHN 19990806
901 (def!macro deletef-in (next place item &environment env)
902 (multiple-value-bind (temps vals stores store access)
903 (get-setf-expansion place env)
905 (error "multiple store variables for ~S" place))
906 (let ((n-item (gensym))
910 `(let* (,@(mapcar #'list temps vals)
913 (if (eq ,n-place ,n-item)
914 (let ((,(first stores) (,next ,n-place)))
916 (do ((,n-prev ,n-place ,n-current)
917 (,n-current (,next ,n-place)
919 ((eq ,n-current ,n-item)
920 (setf (,next ,n-prev)
921 (,next ,n-current)))))
923 ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
925 ;;; Push ITEM onto a list linked by the accessor function NEXT that is
928 ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
929 ;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
931 ;;; (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
932 ;;; arrangement, in order to get it to work in cross-compilation. This
933 ;;; duplication should be removed, perhaps by rewriting the macro in a more
934 ;;; cross-compiler-friendly way, or perhaps just by using some (MACROLET ((FROB
935 ;;; ..)) .. FROB .. FROB) form, or perhaps by completely eliminating this macro
936 ;;; and its partner DELETEF-IN, but I don't want to do it now, because the
937 ;;; system isn't running yet, so it'd be too hard to check that my changes were
938 ;;; correct -- WHN 19990806
939 (def!macro push-in (next item place &environment env)
940 (multiple-value-bind (temps vals stores store access)
941 (get-setf-expansion place env)
943 (error "multiple store variables for ~S" place))
944 `(let (,@(mapcar #'list temps vals)
945 (,(first stores) ,item))
946 (setf (,next ,(first stores)) ,access)
949 ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
951 (defmacro position-or-lose (&rest args)
952 `(or (position ,@args)
953 (error "shouldn't happen?")))