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

Contents of /src/compiler/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5