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) &body body)
635 (let ((n-block (gensym))
637 `(loop with ,n-block = ,block
638 for ,node-var = (block-last ,n-block) then (ctran-use ,n-prev)
639 for ,n-prev = (when ,node-var (node-prev ,node-var))
640 and ,lvar = (when (and ,node-var (valued-node-p ,node-var))
641 (node-lvar ,node-var))
646 (defmacro do-nodes-carefully ((node-var block) &body body)
647 (with-unique-names (n-block n-ctran)
648 `(loop with ,n-block = ,block
649 for ,n-ctran = (block-start ,n-block) then (node-next ,node-var)
650 for ,node-var = (and ,n-ctran (ctran-next ,n-ctran))
654 ;;; Bind the IR1 context variables to the values associated with NODE,
655 ;;; so that new, extra IR1 conversion related to NODE can be done
656 ;;; after the original conversion pass has finished.
657 (defmacro with-ir1-environment-from-node (node &rest forms)
658 `(flet ((closure-needing-ir1-environment-from-node ()
660 (%with-ir1-environment-from-node
662 #'closure-needing-ir1-environment-from-node)))
663 (defun %with-ir1-environment-from-node (node fun)
664 (declare (type node node) (type function fun))
665 (let ((*current-component* (node-component node))
666 (*lexenv* (node-lexenv node))
667 (*current-path* (node-source-path node)))
668 (aver-live-component *current-component*)
671 ;;; Bind the hashtables used for keeping track of global variables,
672 ;;; functions, etc. Also establish condition handlers.
673 (defmacro with-ir1-namespace (&body forms)
674 `(let ((*free-vars* (make-hash-table :test 'eq))
675 (*free-funs* (make-hash-table :test 'equal))
676 (*constants* (make-hash-table :test 'equal))
677 (*source-paths* (make-hash-table :test 'eq)))
678 (handler-bind ((compiler-error #'compiler-error-handler)
679 (style-warning #'compiler-style-warning-handler)
680 (warning #'compiler-warning-handler))
683 ;;; Look up NAME in the lexical environment namespace designated by
684 ;;; SLOT, returning the <value, T>, or <NIL, NIL> if no entry. The
685 ;;; :TEST keyword may be used to determine the name equality
687 (defmacro lexenv-find (name slot &key test)
688 (once-only ((n-res `(assoc ,name (,(let ((*package* (symbol-package 'lexenv-funs)))
689 (symbolicate "LEXENV-" slot))
691 :test ,(or test '#'eq))))
693 (values (cdr ,n-res) t)
696 (defmacro with-component-last-block ((component block) &body body)
697 (with-unique-names (old-last-block)
698 (once-only ((component component)
700 `(let ((,old-last-block (component-last-block ,component)))
702 (progn (setf (component-last-block ,component)
705 (setf (component-last-block ,component)
706 ,old-last-block))))))
709 ;;;; the EVENT statistics/trace utility
711 ;;; FIXME: This seems to be useful for troubleshooting and
712 ;;; experimentation, not for ordinary use, so it should probably
713 ;;; become conditional on SB-SHOW.
715 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
717 (defstruct (event-info (:copier nil))
718 ;; The name of this event.
719 (name (missing-arg) :type symbol)
720 ;; The string rescribing this event.
721 (description (missing-arg) :type string)
722 ;; The name of the variable we stash this in.
723 (var (missing-arg) :type symbol)
724 ;; The number of times this event has happened.
725 (count 0 :type fixnum)
726 ;; The level of significance of this event.
727 (level (missing-arg) :type unsigned-byte)
728 ;; If true, a function that gets called with the node that the event
730 (action nil :type (or function null)))
732 ;;; A hashtable from event names to event-info structures.
733 (defvar *event-info* (make-hash-table :test 'eq))
735 ;;; Return the event info for Name or die trying.
736 (declaim (ftype (function (t) event-info) event-info-or-lose))
737 (defun event-info-or-lose (name)
738 (let ((res (gethash name *event-info*)))
740 (error "~S is not the name of an event." name))
745 ;;; Return the number of times that EVENT has happened.
746 (declaim (ftype (function (symbol) fixnum) event-count))
747 (defun event-count (name)
748 (event-info-count (event-info-or-lose name)))
750 ;;; Return the function that is called when Event happens. If this is
751 ;;; null, there is no action. The function is passed the node to which
752 ;;; the event happened, or NIL if there is no relevant node. This may
753 ;;; be set with SETF.
754 (declaim (ftype (function (symbol) (or function null)) event-action))
755 (defun event-action (name)
756 (event-info-action (event-info-or-lose name)))
757 (declaim (ftype (function (symbol (or function null)) (or function null))
759 (defun %set-event-action (name new-value)
760 (setf (event-info-action (event-info-or-lose name))
762 (defsetf event-action %set-event-action)
764 ;;; Return the non-negative integer which represents the level of
765 ;;; significance of the event Name. This is used to determine whether
766 ;;; to print a message when the event happens. This may be set with
768 (declaim (ftype (function (symbol) unsigned-byte) event-level))
769 (defun event-level (name)
770 (event-info-level (event-info-or-lose name)))
771 (declaim (ftype (function (symbol unsigned-byte) unsigned-byte) %set-event-level))
772 (defun %set-event-level (name new-value)
773 (setf (event-info-level (event-info-or-lose name))
775 (defsetf event-level %set-event-level)
777 ;;; Define a new kind of event. NAME is a symbol which names the event
778 ;;; and DESCRIPTION is a string which describes the event. Level
779 ;;; (default 0) is the level of significance associated with this
780 ;;; event; it is used to determine whether to print a Note when the
782 (defmacro defevent (name description &optional (level 0))
783 (let ((var-name (symbolicate "*" name "-EVENT-INFO*")))
784 `(eval-when (:compile-toplevel :load-toplevel :execute)
786 (make-event-info :name ',name
787 :description ',description
790 (setf (gethash ',name *event-info*) ,var-name)
793 ;;; the lowest level of event that will print a note when it occurs
794 (declaim (type unsigned-byte *event-note-threshold*))
795 (defvar *event-note-threshold* 1)
797 ;;; Note that the event with the specified NAME has happened. NODE is
798 ;;; evaluated to determine the node to which the event happened.
799 (defmacro event (name &optional node)
800 ;; Increment the counter and do any action. Mumble about the event if
802 `(%event ,(event-info-var (event-info-or-lose name)) ,node))
804 ;;; Print a listing of events and their counts, sorted by the count.
805 ;;; Events that happened fewer than Min-Count times will not be
806 ;;; printed. Stream is the stream to write to.
807 (declaim (ftype (function (&optional unsigned-byte stream) (values)) event-statistics))
808 (defun event-statistics (&optional (min-count 1) (stream *standard-output*))
810 (maphash (lambda (k v)
812 (when (>= (event-info-count v) min-count)
815 (dolist (event (sort (info) #'> :key #'event-info-count))
816 (format stream "~6D: ~A~%" (event-info-count event)
817 (event-info-description event)))
821 (declaim (ftype (function nil (values)) clear-event-statistics))
822 (defun clear-event-statistics ()
823 (maphash (lambda (k v)
825 (setf (event-info-count v) 0))
829 ;;;; functions on directly-linked lists (linked through specialized
830 ;;;; NEXT operations)
832 #!-sb-fluid (declaim (inline find-in position-in))
834 ;;; Find ELEMENT in a null-terminated LIST linked by the accessor
835 ;;; function NEXT. KEY, TEST and TEST-NOT are the same as for generic
836 ;;; sequence functions.
843 (test-not #'eql not-p))
844 (declare (type function next key test test-not))
845 (when (and test-p not-p)
846 (error "It's silly to supply both :TEST and :TEST-NOT arguments."))
848 (do ((current list (funcall next current)))
850 (unless (funcall test-not (funcall key current) element)
852 (do ((current list (funcall next current)))
854 (when (funcall test (funcall key current) element)
857 ;;; Return the position of ELEMENT (or NIL if absent) in a
858 ;;; null-terminated LIST linked by the accessor function NEXT. KEY,
859 ;;; TEST and TEST-NOT are the same as for generic sequence functions.
860 (defun position-in (next
866 (test-not #'eql not-p))
867 (declare (type function next key test test-not))
868 (when (and test-p not-p)
869 (error "It's silly to supply both :TEST and :TEST-NOT arguments."))
871 (do ((current list (funcall next current))
874 (unless (funcall test-not (funcall key current) element)
876 (do ((current list (funcall next current))
879 (when (funcall test (funcall key current) element)
883 ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
884 ;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
886 ;;; (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
887 ;;; arrangement, in order to get it to work in cross-compilation. This
888 ;;; duplication should be removed, perhaps by rewriting the macro in a more
889 ;;; cross-compiler-friendly way, or perhaps just by using some (MACROLET ((FROB
890 ;;; ..)) .. FROB .. FROB) form, or perhaps by completely eliminating this macro
891 ;;; and its partner PUSH-IN, but I don't want to do it now, because the system
892 ;;; isn't running yet, so it'd be too hard to check that my changes were
893 ;;; correct -- WHN 19990806
894 (def!macro deletef-in (next place item &environment env)
895 (multiple-value-bind (temps vals stores store access)
896 (get-setf-expansion place env)
898 (error "multiple store variables for ~S" place))
899 (let ((n-item (gensym))
903 `(let* (,@(mapcar #'list temps vals)
906 (if (eq ,n-place ,n-item)
907 (let ((,(first stores) (,next ,n-place)))
909 (do ((,n-prev ,n-place ,n-current)
910 (,n-current (,next ,n-place)
912 ((eq ,n-current ,n-item)
913 (setf (,next ,n-prev)
914 (,next ,n-current)))))
916 ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
918 ;;; Push ITEM onto a list linked by the accessor function NEXT that is
921 ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
922 ;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
924 ;;; (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
925 ;;; arrangement, in order to get it to work in cross-compilation. This
926 ;;; duplication should be removed, perhaps by rewriting the macro in a more
927 ;;; cross-compiler-friendly way, or perhaps just by using some (MACROLET ((FROB
928 ;;; ..)) .. FROB .. FROB) form, or perhaps by completely eliminating this macro
929 ;;; and its partner DELETEF-IN, but I don't want to do it now, because the
930 ;;; system isn't running yet, so it'd be too hard to check that my changes were
931 ;;; correct -- WHN 19990806
932 (def!macro push-in (next item place &environment env)
933 (multiple-value-bind (temps vals stores store access)
934 (get-setf-expansion place env)
936 (error "multiple store variables for ~S" place))
937 `(let (,@(mapcar #'list temps vals)
938 (,(first stores) ,item))
939 (setf (,next ,(first stores)) ,access)
942 ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
944 (defmacro position-or-lose (&rest args)
945 `(or (position ,@args)
946 (error "shouldn't happen?")))