/[cmucl]/src/compiler/macros.lisp
ViewVC logotype

Contents of /src/compiler/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30 - (hide annotations)
Tue Mar 24 20:35:35 1992 UTC (22 years, 1 month ago) by wlott
Branch: MAIN
Changes since 1.29: +2 -1 lines
Added (DECLARE (IGNORABLE STREAM)) to the guts of the defprinter expansion
to supress bound-but-not-used warnings.
1 wlott 1.1 ;;; -*- Package: C; Log: C.Log -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.23 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 wlott 1.30 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/macros.lisp,v 1.30 1992/03/24 20:35:35 wlott Exp $")
11 ram 1.23 ;;;
12 wlott 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; Random types and macros used in writing the compiler.
15     ;;;
16     ;;; Written by Rob MacLachlan
17     ;;;
18     (in-package 'c)
19    
20     (export '(lisp::with-compilation-unit) "LISP")
21    
22 wlott 1.12 (export '(policy symbolicate def-ir1-translator def-source-transform
23     def-primitive-translator deftransform defknown defoptimizer
24     derive-type optimizer ltn-annotate ir2-convert attributes
25     def-boolean-attribute attributes-union attributes-intersection
26     attributes=))
27    
28 wlott 1.1 (proclaim '(special *wild-type* *universal-type* *compiler-error-context*))
29    
30     ;;;; Deftypes:
31    
32     ;;;
33     ;;; Should be standard:
34     (deftype boolean () '(member t nil))
35    
36     ;;;
37     ;;; Inlinep is used to determine how a function is called. The values have
38     ;;; these meanings:
39     ;;; Nil No declaration seen: do whatever you feel like, but don't dump
40     ;;; an inline expansion.
41     ;;;
42     ;;; :Notinline Notinline declaration seen: always do full function call.
43     ;;;
44     ;;; :Inline Inline declaration seen: save expansion, expanding to it if
45     ;;; policy favors.
46     ;;;
47     ;;; :Maybe-Inline
48     ;;; Retain expansion, but only use it opportunistically.
49     ;;;
50     (deftype inlinep () '(member :inline :maybe-inline :notinline nil))
51    
52    
53     ;;;; The Policy macro:
54    
55 ram 1.7 (proclaim '(special *lexical-environment*))
56 wlott 1.1
57 ram 1.22 (eval-when (compile load eval)
58 wlott 1.1 (defconstant policy-parameter-slots
59     '((speed . cookie-speed) (space . cookie-space) (safety . cookie-safety)
60     (cspeed . cookie-cspeed) (brevity . cookie-brevity)
61     (debug . cookie-debug)))
62    
63     ;;; Find-Used-Parameters -- Internal
64     ;;;
65     ;;; Find all the policy parameters which are actually mentioned in Stuff,
66     ;;; returning the names in a list. We assume everything is evaluated.
67     ;;;
68     (defun find-used-parameters (stuff)
69     (if (atom stuff)
70     (if (assoc stuff policy-parameter-slots) (list stuff) ())
71     (collect ((res () nunion))
72     (dolist (arg (cdr stuff) (res))
73     (res (find-used-parameters arg))))))
74    
75     ); Eval-When (Compile Load Eval)
76    
77     ;;; Policy -- Public
78     ;;;
79     ;;; This macro provides some syntactic sugar for querying the settings of
80     ;;; the compiler policy parameters.
81     ;;;
82     (defmacro policy (node &rest conditions)
83     "Policy Node Condition*
84     Test whether some conditions apply to the current compiler policy for Node.
85     Each condition is a predicate form which accesses the policy values by
86     referring to them as the variables SPEED, SPACE, SAFETY, CSPEED, BREVITY and
87     DEBUG. The results of all the conditions are combined with AND and returned
88     as the result.
89    
90     Node is a form which is evaluated to obtain the node which the policy is for.
91     If Node is NIL, then we use the current policy as defined by *default-cookie*
92     and *current-cookie*. This option is only well defined during IR1
93     conversion."
94     (let* ((form `(and ,@conditions))
95 ram 1.7 (n-cookie (gensym))
96 wlott 1.1 (binds (mapcar
97     #'(lambda (name)
98     (let ((slot (cdr (assoc name policy-parameter-slots))))
99 ram 1.7 `(,name (,slot ,n-cookie))))
100 wlott 1.1 (find-used-parameters form))))
101 ram 1.7 `(let* ((,n-cookie (lexenv-cookie
102     ,(if node
103     `(node-lexenv ,node)
104     '*lexical-environment*)))
105     ,@binds)
106     ,form)))
107 wlott 1.1
108    
109     ;;;; Source-hacking defining forms:
110    
111 ram 1.22 (eval-when (compile load eval)
112 wlott 1.1
113     ;;; Symbolicate -- Interface
114     ;;;
115     ;;; Concatenate together the names of some strings and symbols, producing
116     ;;; a symbol in the current package.
117     ;;;
118     (proclaim '(function symbolicate (&rest (or string symbol)) symbol))
119     (defun symbolicate (&rest things)
120     (values (intern (reduce #'(lambda (x y)
121     (concatenate 'string (string x) (string y)))
122     things))))
123    
124     ); Eval-When (Compile Load Eval)
125    
126 ram 1.10 ;;; SPECIAL-FORM-FUNCTION -- Internal
127     ;;;
128     ;;; This function is stored in the SYMBOL-FUNCTION of special form names so
129     ;;; that they are FBOUND.
130     ;;;
131     (defun special-form-function (&rest stuff)
132     (declare (ignore stuff))
133     (error "Can't funcall the SYMBOL-FUNCTION of special forms."))
134    
135 wlott 1.19 ;;; CONVERT-CONDITION-INTO-COMPILER-ERROR -- Internal
136 wlott 1.16 ;;;
137 wlott 1.19 ;;; Passed to parse-defmacro when we want compiler errors instead of real
138     ;;; errors.
139     ;;;
140     (proclaim '(inline convert-condition-into-compiler-error))
141     (defun convert-condition-into-compiler-error (datum &rest stuff)
142     (if (stringp datum)
143     (apply #'compiler-error datum stuff)
144     (compiler-error "~A"
145     (if (symbolp datum)
146     (apply #'make-condition datum stuff)
147     datum))))
148 wlott 1.16
149 wlott 1.1 ;;; Def-IR1-Translator -- Interface
150     ;;;
151     ;;; Parse defmacro style lambda-list, setting things up so that a compiler
152     ;;; error happens if the syntax is invalid.
153     ;;;
154     (defmacro def-ir1-translator (name (lambda-list start-var cont-var
155     &key (kind :special-form))
156     &body body)
157     "Def-IR1-Translator Name (Lambda-List Start-Var Cont-Var {Key Value}*)
158     [Doc-String] Form*
159     Define a function that converts a Special-Form or other magical thing into
160     IR1. Lambda-List is a defmacro style lambda list. Start-Var and Cont-Var
161     are bound to the start and result continuations for the resulting IR1.
162     This keyword is defined:
163     Kind
164     The function kind to associate with Name (default :special-form)."
165     (let ((fn-name (symbolicate "IR1-CONVERT-" name))
166     (n-form (gensym))
167     (n-env (gensym)))
168 wlott 1.15 (multiple-value-bind
169     (body decls doc)
170 wlott 1.17 (lisp::parse-defmacro lambda-list n-form body name "special form"
171 wlott 1.15 :doc-string-allowed t
172 wlott 1.16 :environment n-env
173 wlott 1.19 :error-fun 'convert-condition-into-compiler-error)
174 wlott 1.1 `(progn
175     (proclaim '(function ,fn-name (continuation continuation t) void))
176     (defun ,fn-name (,start-var ,cont-var ,n-form)
177 ram 1.7 (let ((,n-env *lexical-environment*))
178 wlott 1.1 ,@decls
179 wlott 1.16 ,body))
180 wlott 1.1 ,@(when doc
181     `((setf (documentation ',name 'function) ,doc)))
182     (setf (info function ir1-convert ',name) #',fn-name)
183 ram 1.10 (setf (info function kind ',name) ,kind)
184     #+new-compiler
185     ,@(when (eq kind :special-form)
186     `((setf (symbol-function ',name) #'special-form-function)))))))
187 wlott 1.1
188    
189     ;;; Def-Source-Transform -- Interface
190     ;;;
191     ;;; Similar to Def-IR1-Translator, except that we pass if the syntax is
192     ;;; invalid.
193     ;;;
194     (defmacro def-source-transform (name lambda-list &body body)
195     "Def-Source-Transform Name Lambda-List Form*
196     Define a macro-like source-to-source transformation for the function Name.
197     A source transform may \"pass\" by returning a non-nil second value. If the
198     transform passes, then the form is converted as a normal function call. If
199     the supplied arguments are not compatible with the specified lambda-list,
200     then the transform automatically passes.
201    
202     Source-Transforms may only be defined for functions. Source transformation
203     is not attempted if the function is declared Notinline. Source transforms
204     should not examine their arguments. If it matters how the function is used,
205     then Deftransform should be used to define an IR1 transformation.
206    
207     If the desirability of the transformation depends on the current Optimize
208     parameters, then the Policy macro should be used to determine when to pass."
209     (let ((fn-name (symbolicate "SOURCE-TRANSFORM-" name))
210     (n-form (gensym))
211     (n-env (gensym)))
212 wlott 1.15 (multiple-value-bind
213     (body decls)
214 wlott 1.17 (lisp::parse-defmacro lambda-list n-form body name "form"
215 wlott 1.16 :environment n-env
216     :error-fun `(lambda (&rest stuff)
217     (declare (ignore stuff))
218     (return-from ,fn-name
219     (values nil t))))
220 wlott 1.1 `(progn
221     (defun ,fn-name (,n-form)
222 ram 1.7 (let ((,n-env *lexical-environment*))
223 wlott 1.1 ,@decls
224 wlott 1.16 ,body))
225 wlott 1.1 (setf (info function source-transform ',name) #',fn-name)))))
226    
227    
228     (defmacro def-primitive-translator (name lambda-list &body body)
229     "Def-Primitive-Translator Name Lambda-List Form*
230     Define a function that converts a use of (%PRIMITIVE Name ...) into Lisp
231     code. Lambda-List is a defmacro style lambda list."
232     (let ((fn-name (symbolicate "PRIMITIVE-TRANSLATE-" name))
233     (n-form (gensym))
234     (n-env (gensym)))
235 wlott 1.15 (multiple-value-bind
236     (body decls)
237 wlott 1.17 (lisp::parse-defmacro lambda-list n-form body name "%primitive"
238 wlott 1.16 :environment n-env
239 wlott 1.19 :error-fun 'convert-condition-into-compiler-error)
240 wlott 1.1 `(progn
241     (defun ,fn-name (,n-form)
242 ram 1.7 (let ((,n-env *lexical-environment*))
243 wlott 1.1 ,@decls
244 wlott 1.16 ,body))
245 wlott 1.1 (setf (gethash ',name *primitive-translators*) ',fn-name)))))
246    
247    
248     ;;;; Lambda-list parsing utilities:
249     ;;;
250     ;;; IR1 transforms, optimizers and type inferencers need to be able to parse
251     ;;; the IR1 representation of a function call using a standard function
252     ;;; lambda-list.
253    
254    
255 ram 1.22 (eval-when (compile load eval)
256 wlott 1.1
257     ;;; Parse-Deftransform -- Internal
258     ;;;
259     ;;; Given a deftransform style lambda-list, generate code that parses the
260     ;;; arguments of a combination with respect to that lambda-list. Body is the
261     ;;; the list of forms which are to be evaluated within the bindings. Args is
262     ;;; the variable that holds list of argument continuations. Error-Form is a
263     ;;; form which is evaluated when the syntax of the supplied arguments is
264     ;;; incorrect or a non-constant argument keyword is supplied. Defaults and
265     ;;; other gunk are ignored. The second value is a list of all the arguments
266     ;;; bound. We make the variables IGNORABLE so that we don't have to manually
267     ;;; declare them Ignore if their only purpose is to make the syntax work.
268     ;;;
269     (proclaim '(function parse-deftransform (list list symbol t) list))
270     (defun parse-deftransform (lambda-list body args error-form)
271     (multiple-value-bind (req opt restp rest keyp keys allowp)
272     (parse-lambda-list lambda-list)
273     (let* ((min-args (length req))
274     (max-args (+ min-args (length opt)))
275     (n-keys (gensym)))
276     (collect ((binds)
277     (vars)
278     (pos 0 +)
279     (keywords))
280     (dolist (arg req)
281     (vars arg)
282     (binds `(,arg (nth ,(pos) ,args)))
283     (pos 1))
284    
285     (dolist (arg opt)
286     (let ((var (if (atom arg) arg (first arg))))
287     (vars var)
288     (binds `(,var (nth ,(pos) ,args)))
289     (pos 1)))
290    
291     (when restp
292     (vars rest)
293     (binds `(,rest (nthcdr ,(pos) ,args))))
294    
295     (dolist (spec keys)
296     (if (or (atom spec) (atom (first spec)))
297     (let* ((var (if (atom spec) spec (first spec)))
298     (key (intern (symbol-name var) "KEYWORD")))
299     (vars var)
300     (binds `(,var (find-keyword-continuation ,n-keys ,key)))
301     (keywords key))
302     (let* ((head (first spec))
303     (var (second head))
304     (key (first head)))
305     (vars var)
306     (binds `(,var (find-keyword-continuation ,n-keys ,key)))
307     (keywords key))))
308    
309     (let ((n-length (gensym))
310     (limited-legal (not (or restp keyp))))
311     (values
312     `(let ((,n-length (length ,args))
313     ,@(when keyp `((,n-keys (nthcdr ,(pos) ,args)))))
314     (unless (and
315     ,(if limited-legal
316     `(<= ,min-args ,n-length ,max-args)
317     `(<= ,min-args ,n-length))
318     ,@(when keyp
319     (if allowp
320     `((check-keywords-constant ,n-keys))
321     `((check-transform-keys ,n-keys ',(keywords))))))
322     ,error-form)
323     (let ,(binds)
324     ;;; ### Bootstrap hack...
325     #+new-compiler
326     (declare (ignorable ,@(vars)))
327     #-new-compiler
328     (progn ,@(vars))
329     ,@body))
330     (vars)))))))
331    
332     ); Eval-When (Compile Load Eval)
333    
334    
335     ;;;; Utilities used at run-time for parsing keyword args in IR1:
336    
337     ;;; Find-Keyword-Continuation -- Internal
338     ;;;
339     ;;; This function is used by the result of Parse-Deftransform to find the
340     ;;; continuation for the value of the keyword argument Key in the list of
341     ;;; continuations Args. It returns the continuation if the keyword is present,
342     ;;; or NIL otherwise. The legality and constantness of the keywords should
343     ;;; already have been checked.
344     ;;;
345     (proclaim '(function find-keyword-continuation (list keyword) (or continuation null)))
346     (defun find-keyword-continuation (args key)
347     (do ((arg args (cddr arg)))
348     ((null arg) nil)
349     (when (eq (continuation-value (first arg)) key)
350     (return (second arg)))))
351    
352    
353     ;;; Check-Keywords-Constant -- Internal
354     ;;;
355     ;;; This function is used by the result of Parse-Deftransform to verify that
356     ;;; alternating continuations in Args are constant and that there is an even
357     ;;; number of args.
358     ;;;
359     (proclaim '(function check-keywords-constant (list) boolean))
360     (defun check-keywords-constant (args)
361     (do ((arg args (cddr arg)))
362     ((null arg) t)
363     (unless (and (rest arg)
364     (constant-continuation-p (first arg)))
365     (return nil))))
366    
367    
368     ;;; Check-Transform-Keys -- Internal
369     ;;;
370     ;;; This function is used by the result of Parse-Deftransform to verify that
371     ;;; the list of continuations Args is a well-formed keyword arglist and that
372     ;;; only keywords present in the list Keys are supplied.
373     ;;;
374     (proclaim '(function check-transform-keys (list list) boolean))
375     (defun check-transform-keys (args keys)
376     (and (check-keywords-constant args)
377     (do ((arg args (cddr arg)))
378     ((null arg) t)
379     (unless (member (continuation-value (first arg)) keys)
380     (return nil)))))
381    
382    
383     ;;;; Deftransform:
384    
385     ;;; Deftransform -- Interface
386     ;;;
387     ;;; Parse the lambda-list and generate code to test the policy and
388     ;;; automatically create the result lambda.
389     ;;;
390 wlott 1.29 (defmacro deftransform (name (lambda-list &optional (arg-types '*)
391     (result-type '*)
392 ram 1.21 &key result policy node defun-only
393 wlott 1.29 eval-name important)
394 ram 1.25 &body (body decls doc))
395 wlott 1.1 "Deftransform Name (Lambda-List [Arg-Types] [Result-Type] {Key Value}*)
396 ram 1.25 Declaration* [Doc-String] Form*
397 wlott 1.1 Define an IR1 transformation for Name. An IR1 transformation computes a
398     lambda that replaces the function variable reference for the call. A
399     transform may pass (decide not to transform the call) by calling the Give-Up
400     function. Lambda-List both determines how the current call is parsed and
401     specifies the Lambda-List for the resulting lambda.
402    
403     We parse the call and bind each of the lambda-list variables to the
404     continuation which represents the value of the argument. When parsing the
405     call, we ignore the defaults, and always bind the variables for unsupplied
406     arguments to NIL. If a required argument is missing, an unknown keyword is
407     supplied, or an argument keyword is not a constant, then the transform
408     automatically passes. The Declarations apply to the bindings made by
409     Deftransform at transformation time, rather than to the variables of the
410     resulting lambda. Bound-but-not-referenced warnings are suppressed for the
411 ram 1.25 lambda-list variables. The Doc-String is used when printing efficiency notes
412     about the defined transform.
413 wlott 1.1
414     Normally, the body evaluates to a form which becomes the body of an
415     automatically constructed lambda. We make Lambda-List the lambda-list for
416     the lambda, and automatically insert declarations of the argument and result
417     types. If the second value of the body is non-null, then it is a list of
418     declarations which are to be inserted at the head of the lambda. Automatic
419     lambda generation may be inhibited by explicitly returning a lambda from the
420     body.
421    
422     The Arg-Types and Result-Type are used to create a function type which the
423     call must satisfy before transformation is attempted. The function type
424     specifier is constructed by wrapping (FUNCTION ...) around these values, so
425     the lack of a restriction may be specified by omitting the argument or
426     supplying *. The argument syntax specified in the Arg-Types need not be the
427     same as that in the Lambda-List, but the transform will never happen if
428     the syntaxes can't be satisfied simultaneously. If there is an existing
429     transform for the same function that has the same type, then it is replaced
430     with the new definition.
431    
432     These are the legal keyword options:
433     :Result - A variable which is bound to the result continuation.
434     :Node - A variable which is bound to the combination node for the call.
435     :Policy - A form which is supplied to the Policy macro to determine whether
436     this transformation is appropriate. If the result is false, then
437     the transform automatically passes.
438 ram 1.21 :Eval-Name
439 ram 1.26 - The name and argument/result types are actually forms to be
440     evaluated. Useful for getting closures that transform similar
441     functions.
442 wlott 1.1 :Defun-Only
443     - Don't actually instantiate a transform, instead just DEFUN
444     Name with the specified transform definition function. This may
445 wlott 1.29 be later instantiated with %Deftransform.
446     :Important
447     - If supplied and non-NIL, note this transform as ``important,''
448     which means effeciency notes will be generated when this
449     transform fails even if brevity=speed (but not if brevity>speed)"
450 wlott 1.1
451 ram 1.21 (when (and eval-name defun-only)
452     (error "Can't specify both DEFUN-ONLY and EVAL-NAME."))
453 wlott 1.1 (let ((n-args (gensym))
454     (n-node (or node (gensym)))
455     (n-decls (gensym))
456 ram 1.25 (n-lambda (gensym))
457     (body `(,@decls ,@body)))
458 wlott 1.1 (multiple-value-bind (parsed-form vars)
459     (parse-deftransform
460     lambda-list
461     (if policy
462 ram 1.11 `((unless (policy ,n-node ,policy) (give-up))
463 wlott 1.1 ,@body)
464     body)
465     n-args '(give-up))
466     (let ((stuff
467     `((,n-node)
468     (let* ((,n-args (basic-combination-args ,n-node))
469     ,@(when result
470     `((,result (node-cont ,n-node)))))
471     (multiple-value-bind (,n-lambda ,n-decls)
472     ,parsed-form
473     (if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda))
474     ,n-lambda
475     `(lambda ,',lambda-list
476     (declare (ignorable ,@',vars))
477     ,@,n-decls
478     ,,n-lambda)))))))
479     (if defun-only
480 ram 1.25 `(defun ,name ,@(when doc `(,doc)) ,@stuff)
481 wlott 1.1 `(%deftransform
482 ram 1.21 ,(if eval-name name `',name)
483 ram 1.26 ,(if eval-name
484     ``(function ,,arg-types ,,result-type)
485     `'(function ,arg-types ,result-type))
486 ram 1.25 #'(lambda ,@stuff)
487 wlott 1.29 ,doc
488     ,(if important t nil)))))))
489 wlott 1.1
490     ;;;; Defknown, Defoptimizer:
491    
492     ;;; Defknown -- Interface
493     ;;;
494     ;;; This macro should be the way that all implementation independent
495     ;;; information about functions is made known to the compiler.
496     ;;;
497     (defmacro defknown (name arg-types result-type &optional (attributes '(any))
498     &rest keys)
499     "Defknown Name Arg-Types Result-Type [Attributes] {Key Value}*
500     Declare the function Name to be a known function. We construct a type
501     specifier for the function by wrapping (FUNCTION ...) around the Arg-Types
502     and Result-Type. Attributes is a an unevaluated list of the boolean
503     attributes that the function has. These attributes are meaningful here:
504     call
505     May call functions that are passed as arguments. In order to determine
506     what other effects are present, we must find the effects of all arguments
507     that may be functions.
508    
509     unsafe
510     May incorporate arguments in the result or somehow pass them upward.
511    
512     unwind
513     May fail to return during correct execution. Errors are O.K.
514    
515     any
516     The (default) worst case. Includes all the other bad things, plus any
517     other possible bad thing.
518    
519     foldable
520     May be constant-folded. The function has no side effects, but may be
521     affected by side effects on the arguments. e.g. SVREF, MAPC.
522    
523     flushable
524     May be eliminated if value is unused. The function has no side effects
525     except possibly CONS. If a function is defined to signal errors, then
526     it is not flushable even if it is movable or foldable.
527    
528     movable
529     May be moved with impunity. Has no side effects except possibly CONS,
530     and is affected only by its arguments.
531    
532     predicate
533     A true predicate likely to be open-coded. This is a hint to IR1
534     conversion that it should ensure calls always appear as an IF test.
535     Not usually specified to Defknown, since this is implementation
536     dependent, and is usually automatically set by the Define-VOP
537     :Conditional option.
538    
539     Name may also be a list of names, in which case the same information is given
540     to all the names. The keywords specify the initial values for various
541     optimizers that the function might have."
542     (when (and (intersection attributes '(any call unwind))
543     (intersection attributes '(movable)))
544     (error "Function cannot have both good and bad attributes: ~S" attributes))
545    
546     `(%defknown ',(if (and (consp name)
547     (not (eq (car name) 'setf)))
548     name
549     (list name))
550     '(function ,arg-types ,result-type)
551     (ir1-attributes ,@(if (member 'any attributes)
552     (union '(call unsafe unwind) attributes)
553     attributes))
554     ,@keys))
555    
556    
557     ;;; Defoptimizer -- Interface
558     ;;;
559     ;;; Create a function which parses combination args according to a
560     ;;; Lambda-List, optionally storing it in a function-info slot.
561     ;;;
562     (defmacro defoptimizer (what (lambda-list &optional (n-node (gensym))
563     &rest vars)
564     &body body)
565     "Defoptimizer (Function Kind) (Lambda-List [Node-Var] Var*)
566     Declaration* Form*
567     Define some Kind of optimizer for the named Function. Function must be a
568     known function. Lambda-List is used to parse the arguments to the
569     combination as in Deftransform. If the argument syntax is invalid or there
570     are non-constant keys, then we simply return NIL.
571    
572     The function is DEFUN'ed as Function-Kind-OPTIMIZER. Possible kinds are
573     DERIVE-TYPE, OPTIMIZER, LTN-ANNOTATE and IR2-CONVERT. If a symbol is
574     specified instead of a (Function Kind) list, then we just do a DEFUN with the
575     symbol as its name, and don't do anything with the definition. This is
576     useful for creating optimizers to be passed by name to DEFKNOWN.
577    
578     If supplied, Node-Var is bound to the combination node being optimized. If
579     additional Vars are supplied, then they are used as the rest of the optimizer
580     function's lambda-list. LTN-ANNOTATE methods are passed an additional POLICY
581     argument, and IR2-CONVERT methods are passed an additional IR2-BLOCK
582     argument."
583    
584     (let ((name (if (symbolp what) what
585     (symbolicate (first what) "-" (second what) "-OPTIMIZER"))))
586    
587     (let ((n-args (gensym)))
588     `(progn
589     (defun ,name (,n-node ,@vars)
590     (let ((,n-args (basic-combination-args ,n-node)))
591     ,(parse-deftransform lambda-list body n-args
592     `(return-from ,name nil))))
593     ,@(when (consp what)
594     `((setf (,(symbolicate "FUNCTION-INFO-" (second what))
595     (function-info-or-lose ',(first what)))
596     #',name)))))))
597    
598    
599     ;;;; IR groveling macros:
600    
601     ;;; Do-Blocks, Do-Blocks-Backwards -- Interface
602     ;;;
603     (defmacro do-blocks ((block-var component &optional ends result) &body body)
604     "Do-Blocks (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}*
605     Iterate over the blocks in a component, binding Block-Var to each block in
606     turn. The value of Ends determines whether to iterate over dummy head and
607     tail blocks:
608     NIL -- Skip Head and Tail (the default)
609     :Head -- Do head but skip tail
610     :Tail -- Do tail but skip head
611     :Both -- Do both head and tail
612    
613     If supplied, Result-Form is the value to return."
614     (unless (member ends '(nil :head :tail :both))
615     (error "Losing Ends value: ~S." ends))
616     (let ((n-component (gensym))
617     (n-tail (gensym)))
618     `(let* ((,n-component ,component)
619     (,n-tail ,(if (member ends '(:both :tail))
620     nil
621     `(component-tail ,n-component))))
622     (do ((,block-var ,(if (member ends '(:both :head))
623     `(component-head ,n-component)
624     `(block-next (component-head ,n-component)))
625     (block-next ,block-var)))
626     ((eq ,block-var ,n-tail) ,result)
627     ,@body))))
628     ;;;
629     (defmacro do-blocks-backwards ((block-var component &optional ends result) &body body)
630     "Do-Blocks-Backwards (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}*
631     Like Do-Blocks, only iterate over the blocks in reverse order."
632     (unless (member ends '(nil :head :tail :both))
633     (error "Losing Ends value: ~S." ends))
634     (let ((n-component (gensym))
635     (n-head (gensym)))
636     `(let* ((,n-component ,component)
637     (,n-head ,(if (member ends '(:both :head))
638     nil
639     `(component-head ,n-component))))
640     (do ((,block-var ,(if (member ends '(:both :tail))
641     `(component-tail ,n-component)
642     `(block-prev (component-tail ,n-component)))
643     (block-prev ,block-var)))
644     ((eq ,block-var ,n-head) ,result)
645     ,@body))))
646    
647    
648     ;;; Do-Uses -- Interface
649     ;;;
650     ;;; Could change it not to replicate the code someday perhaps...
651     ;;;
652     (defmacro do-uses ((node-var continuation &optional result) &body body)
653     "Do-Uses (Node-Var Continuation [Result]) {Declaration}* {Form}*
654     Iterate over the uses of Continuation, binding Node to each one succesively."
655     (once-only ((n-cont continuation))
656     `(ecase (continuation-kind ,n-cont)
657     (:unused)
658     (:inside-block
659     (block nil
660     (let ((,node-var (continuation-use ,n-cont)))
661     ,@body
662     ,result)))
663     ((:block-start :deleted-block-start)
664     (dolist (,node-var (block-start-uses (continuation-block ,n-cont))
665     ,result)
666     ,@body)))))
667    
668    
669     ;;; Do-Nodes, Do-Nodes-Backwards -- Interface
670     ;;;
671     ;;; In the forward case, we terminate on Last-Cont so that we don't have to
672     ;;; worry about our termination condition being changed when new code is added
673 ram 1.20 ;;; during the iteration. In the backward case, we do NODE-PREV before
674 wlott 1.1 ;;; evaluating the body so that we can keep going when the current node is
675     ;;; deleted.
676     ;;;
677 ram 1.20 ;;; When Restart-P is supplied to DO-NODES, we start iterating over again at
678     ;;; the beginning of the block when we run into a continuation whose block
679     ;;; differs from the one we are trying to iterate over, either beacuse the
680     ;;; block was split, or because a node was deleted out from under us (hence its
681     ;;; block is NIL.) If the block start is deleted, we just punt. With
682     ;;; Restart-P, we are also more careful about termination, re-indirecting the
683     ;;; BLOCK-LAST each time.
684     ;;;
685     (defmacro do-nodes ((node-var cont-var block &key restart-p) &body body)
686     "Do-Nodes (Node-Var Cont-Var Block {Key Value}*) {Declaration}* {Form}*
687 wlott 1.1 Iterate over the nodes in Block, binding Node-Var to the each node and
688 ram 1.20 Cont-Var to the node's Cont. The only keyword option is Restart-P, which
689     causes iteration to be restarted when a node is deleted out from under us (if
690     not supplied, this is an error.)"
691 wlott 1.1 (let ((n-block (gensym))
692 ram 1.20 (n-last-cont (gensym)))
693 wlott 1.1 `(let* ((,n-block ,block)
694 ram 1.20 ,@(unless restart-p
695     `((,n-last-cont (node-cont (block-last ,n-block))))))
696 wlott 1.1 (do* ((,node-var (continuation-next (block-start ,n-block))
697 ram 1.20 ,(if restart-p
698     `(cond
699     ((eq (continuation-block ,cont-var) ,n-block)
700     (assert (continuation-next ,cont-var))
701     (continuation-next ,cont-var))
702     (t
703     (let ((start (block-start ,n-block)))
704     (unless (eq (continuation-kind start)
705     :block-start)
706     (return nil))
707     (continuation-next start))))
708     `(continuation-next ,cont-var)))
709 wlott 1.1 (,cont-var (node-cont ,node-var) (node-cont ,node-var)))
710     (())
711     ,@body
712 ram 1.20 (when ,(if restart-p
713     `(eq ,node-var (block-last ,n-block))
714     `(eq ,cont-var ,n-last-cont))
715     (return nil))))))
716 wlott 1.1 ;;;
717 ram 1.20 (defmacro do-nodes-backwards ((node-var cont-var block) &body body)
718     "Do-Nodes-Backwards (Node-Var Cont-Var Block) {Declaration}* {Form}*
719 wlott 1.1 Like Do-Nodes, only iterates in reverse order."
720     (let ((n-block (gensym))
721     (n-start (gensym))
722     (n-last (gensym))
723     (n-next (gensym)))
724     `(let* ((,n-block ,block)
725     (,n-start (block-start ,n-block))
726     (,n-last (block-last ,n-block)))
727     (do* ((,cont-var (node-cont ,n-last) ,n-next)
728     (,node-var ,n-last (continuation-use ,cont-var))
729     (,n-next (node-prev ,node-var) (node-prev ,node-var)))
730     (())
731     ,@body
732     (when (eq ,n-next ,n-start)
733 ram 1.20 (return nil))))))
734 wlott 1.1
735    
736     ;;; With-IR1-Environment -- Interface
737     ;;;
738     ;;; The lexical environment is presumably already null...
739     ;;;
740     (defmacro with-ir1-environment (node &rest forms)
741     "With-IR1-Environment Node Form*
742     Bind the IR1 context variables so that IR1 conversion can be done after the
743 ram 1.7 main conversion pass has finished."
744     (let ((n-node (gensym)))
745 wlott 1.1 `(let* ((,n-node ,node)
746 ram 1.7 (*current-component* (block-component (node-block ,n-node)))
747     (*lexical-environment* (node-lexenv ,n-node))
748     (*current-path* (node-source-path ,n-node)))
749 wlott 1.1 ,@forms)))
750    
751    
752     ;;; WITH-IR1-NAMESPACE -- Interface
753     ;;;
754     ;;; Bind the hashtables used for keeping track of global variables,
755     ;;; functions, &c.
756     ;;;
757     (defmacro with-ir1-namespace (&body forms)
758     `(let ((*free-variables* (make-hash-table :test #'eq))
759     (*free-functions* (make-hash-table :test #'equal))
760     (*constants* (make-hash-table :test #'equal))
761 ram 1.9 (*source-paths* (make-hash-table :test #'eq))
762     (*failed-optimizations* (make-hash-table :test #'eq)))
763 wlott 1.1 ,@forms))
764    
765 ram 1.7
766     ;;; LEXENV-FIND -- Interface
767     ;;;
768     (defmacro lexenv-find (name slot &key test)
769     "LEXENV-FIND Name Slot {Key Value}*
770     Look up Name in the lexical environment namespace designated by Slot,
771     returning the <value, T>, or <NIL, NIL> if no entry. The :TEST keyword
772     may be used to determine the name equality predicate."
773     (once-only ((n-res `(assoc ,name (,(symbolicate "LEXENV-" slot)
774     *lexical-environment*)
775     ,@(when test `(:test ,test)))))
776     `(if ,n-res
777     (values (cdr ,n-res) t)
778     (values nil nil))))
779    
780 wlott 1.1
781     ;;;; The Defprinter macro:
782    
783     (defvar *defprint-pretty* nil
784     "If true, defprinter print functions print each slot on a separate line.")
785    
786    
787     ;;; Defprinter-Prin1, Defprinter-Princ -- Internal
788     ;;;
789     ;;; These functions are called by the expansion of the Defprinter
790     ;;; macro to do the actual printing.
791     ;;;
792 ram 1.20 (proclaim '(ftype (function (symbol t stream &optional t) void)
793 wlott 1.1 defprinter-prin1 defprinter-princ))
794 wlott 1.14 (defun defprinter-prin1 (name value stream &optional indent)
795     (declare (ignore indent))
796     (write-string " " stream)
797     (when *print-pretty*
798 wlott 1.27 (pprint-newline :linear stream))
799 wlott 1.14 (princ name stream)
800     (write-string "= " stream)
801     (prin1 value stream))
802 wlott 1.1 ;;;
803 wlott 1.14 (defun defprinter-princ (name value stream &optional indent)
804 wlott 1.1 (declare (ignore indent))
805 wlott 1.14 (write-string " " stream)
806     (when *print-pretty*
807 wlott 1.27 (pprint-newline :linear stream))
808 wlott 1.14 (princ name stream)
809     (write-string "= " stream)
810     (princ value stream))
811 wlott 1.1
812     (defmacro defprinter (name &rest slots)
813     "Defprinter Name Slot-Desc*
814     Define some kind of reasonable defstruct structure-print function. Name
815     is the name of the structure. We define a function %PRINT-name which
816     prints the slots in the structure in the way described by the Slot-Descs.
817     Each Slot-Desc can be a slot name, indicating that the slot should simply
818     be printed. A Slot-Desc may also be a list of a slot name and other stuff.
819     The other stuff is composed of keywords followed by expressions. The
820     expressions are evaluated with the variable which is the slot name bound
821     to the value of the slot. These keywords are defined:
822    
823     :PRIN1 Print the value of the expression instead of the slot value.
824     :PRINC Like :PRIN1, only princ the value
825     :TEST Only print something if the test is true.
826    
827     If no printing thing is specified then the slot value is printed as PRIN1.
828    
829     The structure being printed is bound to Structure and the stream is bound to
830     Stream."
831    
832 wlott 1.14 (flet ((sref (slot) `(,(symbolicate name "-" slot) structure)))
833     (collect ((prints))
834     (dolist (slot slots)
835     (if (atom slot)
836     (prints `(defprinter-prin1 ',slot ,(sref slot) stream))
837     (let ((sname (first slot))
838     (test t))
839     (collect ((stuff))
840     (do ((option (rest slot) (cddr option)))
841     ((null option)
842     (prints
843     `(let ((,sname ,(sref sname)))
844     (when ,test
845     ,@(or (stuff)
846     `((defprinter-prin1 ',sname ,sname
847     stream)))))))
848     (case (first option)
849     (:prin1
850     (stuff `(defprinter-prin1 ',sname ,(second option)
851     stream)))
852     (:princ
853     (stuff `(defprinter-princ ',sname ,(second option)
854     stream)))
855     (:test (setq test (second option)))
856     (t
857     (error "Losing Defprinter option: ~S."
858     (first option)))))))))
859    
860 wlott 1.27 `(defun ,(symbolicate "%PRINT-" name) (structure stream depth)
861 ram 1.28 (declare (ignore depth))
862 wlott 1.29 (flet ((do-prints (stream)
863 wlott 1.30 (declare (ignorable stream))
864 wlott 1.27 ,@(prints)))
865     (cond (*print-pretty*
866 ram 1.28 (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
867 wlott 1.29 (pprint-indent :current 2 stream)
868 ram 1.28 (prin1 ',name stream)
869     (write-char #\space stream)
870     (let ((*print-base* 16)
871     (*print-radix* t))
872     (prin1 (get-lisp-obj-address structure) stream))
873 wlott 1.29 (do-prints stream)))
874 wlott 1.27 (t
875 ram 1.28 (format stream "#<~S ~X"
876     ',name
877     (get-lisp-obj-address structure))
878 wlott 1.29 (do-prints stream)
879 ram 1.28 (format stream ">"))))
880 wlott 1.27 nil))))
881 wlott 1.1
882    
883     ;;;; Boolean attribute utilities:
884     ;;;
885     ;;; We need to maintain various sets of boolean attributes for known
886     ;;; functions and VOPs. To save space and allow for quick set operations, we
887     ;;; represent them as bits in a fixnum.
888     ;;;
889    
890     (deftype attributes () 'fixnum)
891    
892 ram 1.7 (eval-when (compile load eval)
893 wlott 1.1 ;;; Compute-Attribute-Mask -- Internal
894     ;;;
895     ;;; Given a list of attribute names and an alist that translates them to
896     ;;; masks, return the OR of the masks.
897     ;;;
898     (defun compute-attribute-mask (names alist)
899     (collect ((res 0 logior))
900     (dolist (name names)
901     (let ((mask (cdr (assoc name alist))))
902     (unless mask
903     (error "Unknown attribute name: ~S." name))
904     (res mask)))
905     (res)))
906    
907     ); Eval-When (Compile Load Eval)
908    
909     ;;; Def-Boolean-Attribute -- Interface
910     ;;;
911     ;;; Parse the specification and generate some accessor macros.
912     ;;;
913     (defmacro def-boolean-attribute (name &rest attribute-names)
914     "Def-Boolean-Attribute Name Attribute-Name*
915     Define a new class of boolean attributes, with the attributes havin the
916     specified Attribute-Names. Name is the name of the class, which is used to
917     generate some macros to manipulate sets of the attributes:
918    
919     NAME-attributep attributes attribute-name*
920     Return true if one of the named attributes is present, false otherwise.
921 ram 1.7 When set with SETF, updates the place Attributes setting or clearing the
922     specified attributes.
923 wlott 1.1
924     NAME-attributes attribute-name*
925     Return a set of the named attributes."
926    
927 ram 1.7 (let ((const-name (symbolicate name "-ATTRIBUTE-TRANSLATIONS"))
928     (test-name (symbolicate name "-ATTRIBUTEP")))
929 wlott 1.1 (collect ((alist))
930     (do ((mask 1 (ash mask 1))
931     (names attribute-names (cdr names)))
932     ((null names))
933     (alist (cons (car names) mask)))
934    
935     `(progn
936 ram 1.7 (eval-when (compile load eval)
937     (defconstant ,const-name ',(alist)))
938    
939     (defmacro ,test-name (attributes &rest attribute-names)
940     "Automagically generated boolean attribute test function. See
941     Def-Boolean-Attribute."
942     `(logtest ,(compute-attribute-mask attribute-names ,const-name)
943     (the attributes ,attributes)))
944 wlott 1.1
945 ram 1.7 (define-setf-method ,test-name (place &rest attributes
946     &environment env)
947    
948     "Automagically generated boolean attribute setter. See
949     Def-Boolean-Attribute."
950     (multiple-value-bind (temps values stores set get)
951 ram 1.24 (get-setf-method place env)
952 ram 1.7 (let ((newval (gensym))
953     (n-place (gensym))
954     (mask (compute-attribute-mask attributes ,const-name)))
955     (values `(,@temps ,n-place)
956     `(,@values ,get)
957     `(,newval)
958     `(let ((,(first stores)
959     (if ,newval
960     (logior ,n-place ,mask)
961     (logand ,n-place ,(lognot mask)))))
962     ,set
963     ,newval)
964     `(,',test-name ,n-place ,@attributes)))))
965    
966     (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
967     "Automagically generated boolean attribute creation function. See
968     Def-Boolean-Attribute."
969     (compute-attribute-mask attribute-names ,const-name))))))
970 wlott 1.1
971    
972     ;;; Attributes-Union, Attributes-Intersection, Attributes= -- Interface
973     ;;;
974     ;;; And now for some gratuitous pseudo-abstraction...
975     ;;;
976     (defmacro attributes-union (&rest attributes)
977     "Returns the union of all the sets of boolean attributes which are its
978     arguments."
979     `(the attributes
980     (logior ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes))))
981     ;;;
982     (defmacro attributes-intersection (&rest attributes)
983     "Returns the intersection of all the sets of boolean attributes which are its
984     arguments."
985     `(the attributes
986     (logand ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes))))
987     ;;;
988     (proclaim '(inline attributes=))
989     (proclaim '(function attributes= (attributes attributes) boolean))
990     (defun attributes= (attr1 attr2)
991     "Returns true if the attributes present in Attr1 are indentical to those in
992     Attr2."
993     (eql attr1 attr2))
994    
995    
996     ;;;; The Event statistics/trace utility:
997    
998 ram 1.22 (eval-when (compile load eval)
999 wlott 1.1
1000     (defstruct event-info
1001     ;;
1002     ;; The name of this event.
1003 ram 1.18 (name (required-argument) :type symbol)
1004 wlott 1.1 ;;
1005     ;; The string rescribing this event.
1006 ram 1.18 (description (required-argument) :type string)
1007 wlott 1.1 ;;
1008     ;; The name of the variable we stash this in.
1009 ram 1.18 (var (required-argument) :type symbol)
1010 wlott 1.1 ;;
1011     ;; The number of times this event has happened.
1012     (count 0 :type fixnum)
1013     ;;
1014     ;; The level of significance of this event.
1015 ram 1.18 (level (required-argument) :type unsigned-byte)
1016 wlott 1.1 ;;
1017     ;; If true, a function that gets called with the node that the event happened
1018     ;; to.
1019     (action nil :type (or function null)))
1020    
1021     ;;; A hashtable from event names to event-info structures.
1022     ;;;
1023     (defvar *event-info* (make-hash-table :test #'eq))
1024    
1025    
1026     ;;; Event-Info-Or-Lose -- Internal
1027     ;;;
1028     ;;; Return the event info for Name or die trying.
1029     ;;;
1030     (proclaim '(function event-info-or-lose (t) event-info))
1031     (defun event-info-or-lose (name)
1032     (let ((res (gethash name *event-info*)))
1033     (unless res
1034     (error "~S is not the name of an event." name))
1035     res))
1036    
1037     ); Eval-When (Compile Load Eval)
1038    
1039    
1040     ;;; Event-Count, Event-Action, Event-Level -- Interface
1041     ;;;
1042     (proclaim '(function event-count (symbol) fixnum))
1043     (defun event-count (name)
1044     "Return the number of times that Event has happened."
1045     (event-info-count (event-info-or-lose name)))
1046     ;;;
1047     (proclaim '(function event-action (symbol) (or function null)))
1048     (defun event-action (name)
1049     "Return the function that is called when Event happens. If this is null,
1050     there is no action. The function is passed the node to which the event
1051     happened, or NIL if there is no relevant node. This may be set with SETF."
1052     (event-info-action (event-info-or-lose name)))
1053     ;;;
1054     (proclaim '(function %set-event-action (symbol (or function null)) (or function null)))
1055     (defun %set-event-action (name new-value)
1056     (setf (event-info-action (event-info-or-lose name))
1057     new-value))
1058     ;;;
1059     (defsetf event-action %set-event-action)
1060     ;;;
1061     (proclaim '(function event-level (symbol) unsigned-byte))
1062     (defun event-level (name)
1063     "Return the non-negative integer which represents the level of significance
1064     of the event Name. This is used to determine whether to print a message when
1065     the event happens. This may be set with SETF."
1066     (event-info-level (event-info-or-lose name)))
1067     ;;;
1068     (proclaim '(function %set-event-level (symbol unsigned-byte) unsigned-byte))
1069     (defun %set-event-level (name new-value)
1070     (setf (event-info-level (event-info-or-lose name))
1071     new-value))
1072     ;;;
1073     (defsetf event-level %set-event-level)
1074    
1075    
1076     ;;; Defevent -- Interface
1077     ;;;
1078     ;;; Make an event-info structure and stash it in a variable so we can get at
1079     ;;; it quickly.
1080     ;;;
1081     (defmacro defevent (name description &optional (level 0))
1082     "Defevent Name Description
1083     Define a new kind of event. Name is a symbol which names the event and
1084     Description is a string which describes the event. Level (default 0) is the
1085     level of significance associated with this event; it is used to determine
1086     whether to print a Note when the event happens."
1087     (let ((var-name (symbolicate "*" name "-EVENT-INFO*")))
1088     `(eval-when (compile load eval)
1089     (defvar ,var-name
1090     (make-event-info :name ',name :description ',description :var ',var-name
1091     :level ,level))
1092     (setf (gethash ',name *event-info*) ,var-name)
1093     ',name)))
1094    
1095     (proclaim '(type unsigned-byte *event-note-threshold*))
1096     (defvar *event-note-threshold* 1
1097     "This variable is a non-negative integer specifying the lowest level of
1098     event that will print a Note when it occurs.")
1099    
1100     ;;; Event -- Interface
1101     ;;;
1102     ;;; Increment the counter and do any action. Mumble about the event if
1103     ;;; policy indicates.
1104     ;;;
1105     (defmacro event (name &optional node)
1106     "Event Name Node
1107     Note that the event with the specified Name has happened. Node is evaluated
1108     to determine the node to which the event happened."
1109     `(%event ,(event-info-var (event-info-or-lose name)) ,node))
1110     ;;;
1111     (proclaim '(function %event (event-info (or node null))))
1112     (defun %event (info node)
1113     (incf (event-info-count info))
1114     (when (and (>= (event-info-level info) *event-note-threshold*)
1115     (if node
1116     (policy node (= brevity 0))
1117     (policy nil (= brevity 0))))
1118     (let ((*compiler-error-context* node))
1119     (compiler-note (event-info-description info))))
1120    
1121     (let ((action (event-info-action info)))
1122     (when action (funcall action node))))
1123    
1124    
1125     ;;; Event-Statistics, Clear-Statistics -- Interface
1126     ;;;
1127     (proclaim '(function event-statistics (&optional unsigned-byte stream) void))
1128     (defun event-statistics (&optional (min-count 1) (stream *standard-output*))
1129     "Print a listing of events and their counts, sorted by the count. Events
1130     that happened fewer than Min-Count times will not be printed. Stream is the
1131     stream to write to."
1132     (collect ((info))
1133     (maphash #'(lambda (k v)
1134     (declare (ignore k))
1135     (when (>= (event-info-count v) min-count)
1136     (info v)))
1137     *event-info*)
1138     (dolist (event (sort (info) #'> :key #'event-info-count))
1139     (format stream "~6D: ~A~%" (event-info-count event)
1140     (event-info-description event)))
1141     (values)))
1142     ;;;
1143     (proclaim '(function clear-statistics () void))
1144     (defun clear-statistics ()
1145     (maphash #'(lambda (k v)
1146     (declare (ignore k))
1147     (setf (event-info-count v) 0))
1148     *event-info*)
1149     (values))
1150    

  ViewVC Help
Powered by ViewVC 1.1.5