X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmacros.lisp;h=c92c88a25f2594582889ff02a274b9bfd820b7fe;hb=0c25cf1e8e49095969378ab356a5516f29d4c139;hp=f8fb006eae00945379f0cb24dcdfd9b56eea99c8;hpb=cf607a404d7518e8a18c9e362913f370eb9a5e38;p=sbcl.git diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index f8fb006..c92c88a 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -41,11 +41,11 @@ ;;; compiler error happens if the syntax is invalid. ;;; ;;; Define a function that converts a special form or other magical -;;; thing into IR1. LAMBDA-LIST is a defmacro style lambda list. -;;; START-VAR and CONT-VAR are bound to the start and result -;;; continuations for the resulting IR1. KIND is the function kind to -;;; associate with NAME. -(defmacro def-ir1-translator (name (lambda-list start-var cont-var +;;; thing into IR1. LAMBDA-LIST is a defmacro style lambda +;;; list. START-VAR, NEXT-VAR and RESULT-VAR are bound to the start and +;;; result continuations for the resulting IR1. KIND is the function +;;; kind to associate with NAME. +(defmacro def-ir1-translator (name (lambda-list start-var next-var result-var &key (kind :special-form)) &body body) (let ((fn-name (symbolicate "IR1-CONVERT-" name)) @@ -54,11 +54,12 @@ (multiple-value-bind (body decls doc) (parse-defmacro lambda-list n-form body name "special form" :environment n-env - :error-fun 'convert-condition-into-compiler-error) + :error-fun 'convert-condition-into-compiler-error + :wrap-block nil) `(progn - (declaim (ftype (function (continuation continuation t) (values)) + (declaim (ftype (function (ctran ctran (or lvar null) t) (values)) ,fn-name)) - (defun ,fn-name (,start-var ,cont-var ,n-form) + (defun ,fn-name (,start-var ,next-var ,result-var ,n-form) (let ((,n-env *lexenv*)) ,@decls ,body @@ -100,30 +101,25 @@ ;;; If the desirability of the transformation depends on the current ;;; OPTIMIZE parameters, then the POLICY macro should be used to ;;; determine when to pass. -(defmacro define-source-transform (name lambda-list &body body) - (let ((fn-name - (if (listp name) - (collect ((pieces)) - (dolist (piece name) - (pieces "-") - (pieces piece)) - (apply #'symbolicate "SOURCE-TRANSFORM" (pieces))) - (symbolicate "SOURCE-TRANSFORM-" name))) - (n-form (gensym)) - (n-env (gensym))) +(defmacro source-transform-lambda (lambda-list &body body) + (let ((n-form (gensym)) + (n-env (gensym)) + (name (gensym))) (multiple-value-bind (body decls) - (parse-defmacro lambda-list n-form body name "form" + (parse-defmacro lambda-list n-form body "source transform" "form" :environment n-env :error-fun `(lambda (&rest stuff) (declare (ignore stuff)) - (return-from ,fn-name - (values nil t)))) - `(progn - (defun ,fn-name (,n-form) - (let ((,n-env *lexenv*)) - ,@decls - ,body)) - (setf (info :function :source-transform ',name) #',fn-name))))) + (return-from ,name + (values nil t))) + :wrap-block nil) + `(lambda (,n-form &aux (,n-env *lexenv*)) + ,@decls + (block ,name + ,body))))) +(defmacro define-source-transform (name lambda-list &body body) + `(setf (info :function :source-transform ',name) + (source-transform-lambda ,lambda-list ,@body))) ;;;; boolean attribute utilities ;;;; @@ -133,7 +129,7 @@ (deftype attributes () 'fixnum) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) ;;; Given a list of attribute names and an alist that translates them ;;; to masks, return the OR of the masks. @@ -160,12 +156,13 @@ ;;; ;;; NAME-attributes attribute-name* ;;; Return a set of the named attributes. -#+sb-xc-host -(progn +#-sb-xc +(progn (def!macro !def-boolean-attribute (name &rest attribute-names) (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*")) - (test-name (symbolicate name "-ATTRIBUTEP"))) + (test-name (symbolicate name "-ATTRIBUTEP")) + (decoder-name (symbolicate "DECODE-" name "-ATTRIBUTES"))) (collect ((alist)) (do ((mask 1 (ash mask 1)) (names attribute-names (cdr names))) @@ -190,7 +187,11 @@ ;; building the xc and when building the target compiler. (!def-boolean-attribute-setter ,test-name ,translations-name - ,@attribute-names))))) + ,@attribute-names) + (defun ,decoder-name (attributes) + (loop for (name . mask) in ,translations-name + when (logtest mask attributes) + collect name)))))) ;; It seems to be difficult to express in DEF!MACRO machinery what ;; to do with target-vs-host GET-SETF-EXPANSION in here, so we just @@ -263,18 +264,19 @@ ;;;; to parse the IR1 representation of a function call using a ;;;; standard function lambda-list. -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) ;;; Given a DEFTRANSFORM-style lambda-list, generate code that parses -;;; the arguments of a combination with respect to that lambda-list. -;;; BODY is the the list of forms which are to be evaluated within the -;;; bindings. ARGS is the variable that holds list of argument -;;; continuations. ERROR-FORM is a form which is evaluated when the -;;; syntax of the supplied arguments is incorrect or a non-constant -;;; argument keyword is supplied. Defaults and other gunk are ignored. -;;; The second value is a list of all the arguments bound. We make the -;;; variables IGNORABLE so that we don't have to manually declare them -;;; Ignore if their only purpose is to make the syntax work. +;;; the arguments of a combination with respect to that +;;; lambda-list. BODY is the the list of forms which are to be +;;; evaluated within the bindings. ARGS is the variable that holds +;;; list of argument lvars. ERROR-FORM is a form which is evaluated +;;; when the syntax of the supplied arguments is incorrect or a +;;; non-constant argument keyword is supplied. Defaults and other gunk +;;; are ignored. The second value is a list of all the arguments +;;; bound. We make the variables IGNORABLE so that we don't have to +;;; manually declare them Ignore if their only purpose is to make the +;;; syntax work. (defun parse-deftransform (lambda-list body args error-form) (multiple-value-bind (req opt restp rest keyp keys allowp) (parse-lambda-list lambda-list) @@ -305,13 +307,13 @@ (let* ((var (if (atom spec) spec (first spec))) (key (keywordicate var))) (vars var) - (binds `(,var (find-keyword-continuation ,n-keys ,key))) + (binds `(,var (find-keyword-lvar ,n-keys ,key))) (keywords key)) (let* ((head (first spec)) (var (second head)) (key (first head))) (vars var) - (binds `(,var (find-keyword-continuation ,n-keys ,key))) + (binds `(,var (find-keyword-lvar ,n-keys ,key))) (keywords key)))) (let ((n-length (gensym)) @@ -346,11 +348,11 @@ ;;; LAMBDA-LIST for the resulting lambda. ;;; ;;; We parse the call and bind each of the lambda-list variables to -;;; the continuation which represents the value of the argument. When -;;; parsing the call, we ignore the defaults, and always bind the -;;; variables for unsupplied arguments to NIL. If a required argument -;;; is missing, an unknown keyword is supplied, or an argument keyword -;;; is not a constant, then the transform automatically passes. The +;;; the lvar which represents the value of the argument. When parsing +;;; the call, we ignore the defaults, and always bind the variables +;;; for unsupplied arguments to NIL. If a required argument is +;;; missing, an unknown keyword is supplied, or an argument keyword is +;;; not a constant, then the transform automatically passes. The ;;; DECLARATIONS apply to the bindings made by DEFTRANSFORM at ;;; transformation time, rather than to the variables of the resulting ;;; lambda. Bound-but-not-referenced warnings are suppressed for the @@ -377,7 +379,7 @@ ;;; then it is replaced with the new definition. ;;; ;;; These are the legal keyword options: -;;; :RESULT - A variable which is bound to the result continuation. +;;; :RESULT - A variable which is bound to the result lvar. ;;; :NODE - A variable which is bound to the combination node for the call. ;;; :POLICY - A form which is supplied to the POLICY macro to determine ;;; whether this transformation is appropriate. If the result @@ -421,7 +423,7 @@ `((,n-node) (let* ((,n-args (basic-combination-args ,n-node)) ,@(when result - `((,result (node-cont ,n-node))))) + `((,result (node-lvar ,n-node))))) (multiple-value-bind (,n-lambda ,n-decls) ,parsed-form (if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda)) @@ -462,21 +464,21 @@ ;;; keywords specify the initial values for various optimizers that ;;; the function might have. (defmacro defknown (name arg-types result-type &optional (attributes '(any)) - &rest keys) + &rest keys) (when (and (intersection attributes '(any call unwind)) (intersection attributes '(movable))) (error "function cannot have both good and bad attributes: ~S" attributes)) (when (member 'any attributes) - (setf attributes (union '(call unsafe unwind) attributes))) + (setq attributes (union '(call unsafe unwind) attributes))) (when (member 'flushable attributes) (pushnew 'unsafely-flushable attributes)) `(%defknown ',(if (and (consp name) - (not (eq (car name) 'setf))) + (not (legal-fun-name-p name))) name (list name)) - '(function ,arg-types ,result-type) + '(sfunction ,arg-types ,result-type) (ir1-attributes ,@attributes) ,@keys)) @@ -561,85 +563,100 @@ ((eq ,block-var ,n-head) ,result) ,@body)))) -;;; Iterate over the uses of CONTINUATION, binding NODE to each one +;;; Iterate over the uses of LVAR, binding NODE to each one ;;; successively. ;;; ;;; XXX Could change it not to replicate the code someday perhaps... -(defmacro do-uses ((node-var continuation &optional result) &body body) - (once-only ((n-cont continuation)) - `(ecase (continuation-kind ,n-cont) - (:unused) - (:inside-block - (block nil - (let ((,node-var (continuation-use ,n-cont))) - ,@body - ,result))) - ((:block-start :deleted-block-start) - (dolist (,node-var (block-start-uses (continuation-block ,n-cont)) - ,result) - ,@body))))) +(defmacro do-uses ((node-var lvar &optional result) &body body) + (with-unique-names (uses) + `(let ((,uses (lvar-uses ,lvar))) + (if (listp ,uses) + (dolist (,node-var ,uses ,result) + ,@body) + (block nil + (let ((,node-var ,uses)) + ,@body)))))) ;;; Iterate over the nodes in BLOCK, binding NODE-VAR to the each node -;;; and CONT-VAR to the node's CONT. The only keyword option is +;;; and LVAR-VAR to the node's LVAR. The only keyword option is ;;; RESTART-P, which causes iteration to be restarted when a node is ;;; deleted out from under us. (If not supplied, this is an error.) ;;; -;;; In the forward case, we terminate on LAST-CONT so that we don't -;;; have to worry about our termination condition being changed when -;;; new code is added during the iteration. In the backward case, we -;;; do NODE-PREV before evaluating the body so that we can keep going -;;; when the current node is deleted. +;;; In the forward case, we terminate when NODE does not have NEXT, so +;;; that we do not have to worry about our termination condition being +;;; changed when new code is added during the iteration. In the +;;; backward case, we do NODE-PREV before evaluating the body so that +;;; we can keep going when the current node is deleted. ;;; ;;; When RESTART-P is supplied to DO-NODES, we start iterating over -;;; again at the beginning of the block when we run into a -;;; continuation whose block differs from the one we are trying to -;;; iterate over, either because the block was split, or because a -;;; node was deleted out from under us (hence its block is NIL.) If -;;; the block start is deleted, we just punt. With RESTART-P, we are -;;; also more careful about termination, re-indirecting the BLOCK-LAST -;;; each time. -(defmacro do-nodes ((node-var cont-var block &key restart-p) &body body) - (let ((n-block (gensym)) - (n-last-cont (gensym))) - `(let* ((,n-block ,block) - ,@(unless restart-p - `((,n-last-cont (node-cont (block-last ,n-block)))))) - (do* ((,node-var (continuation-next (block-start ,n-block)) - ,(if restart-p - `(cond - ((eq (continuation-block ,cont-var) ,n-block) - (aver (continuation-next ,cont-var)) - (continuation-next ,cont-var)) - (t - (let ((start (block-start ,n-block))) - (unless (eq (continuation-kind start) - :block-start) - (return nil)) - (continuation-next start)))) - `(continuation-next ,cont-var))) - (,cont-var (node-cont ,node-var) (node-cont ,node-var))) - (()) - ,@body - (when ,(if restart-p - `(eq ,node-var (block-last ,n-block)) - `(eq ,cont-var ,n-last-cont)) - (return nil)))))) -;;; like DO-NODES, only iterating in reverse order -(defmacro do-nodes-backwards ((node-var cont-var block) &body body) +;;; again at the beginning of the block when we run into a ctran whose +;;; block differs from the one we are trying to iterate over, either +;;; because the block was split, or because a node was deleted out +;;; from under us (hence its block is NIL.) If the block start is +;;; deleted, we just punt. With RESTART-P, we are also more careful +;;; about termination, re-indirecting the BLOCK-LAST each time. +(defmacro do-nodes ((node-var lvar-var block &key restart-p) + &body body) + (with-unique-names (n-block n-start) + `(do* ((,n-block ,block) + (,n-start (block-start ,n-block)) + + (,node-var (ctran-next ,n-start) + ,(if restart-p + `(let ((next (node-next ,node-var))) + (cond + ((not next) + (return)) + ((eq (ctran-block next) ,n-block) + (ctran-next next)) + (t + (let ((start (block-start ,n-block))) + (unless (eq (ctran-kind start) + :block-start) + (return nil)) + (ctran-next start))))) + `(acond ((node-next ,node-var) + (ctran-next it)) + (t (return))))) + ,@(when lvar-var + `((,lvar-var (when (valued-node-p ,node-var) + (node-lvar ,node-var)) + (when (valued-node-p ,node-var) + (node-lvar ,node-var)))))) + (nil) + ,@body + ,@(when restart-p + `((when (block-delete-p ,n-block) + (return))))))) + +;;; Like DO-NODES, only iterating in reverse order. Should be careful +;;; with block being split under us. +(defmacro do-nodes-backwards ((node-var lvar block &key restart-p) &body body) (let ((n-block (gensym)) - (n-start (gensym)) - (n-last (gensym)) - (n-next (gensym))) - `(let* ((,n-block ,block) - (,n-start (block-start ,n-block)) - (,n-last (block-last ,n-block))) - (do* ((,cont-var (node-cont ,n-last) ,n-next) - (,node-var ,n-last (continuation-use ,cont-var)) - (,n-next (node-prev ,node-var) (node-prev ,node-var))) - (()) - ,@body - (when (eq ,n-next ,n-start) - (return nil)))))) + (n-prev (gensym))) + `(loop with ,n-block = ,block + for ,node-var = (block-last ,n-block) then + ,(if restart-p + `(if (eq ,n-block (ctran-block ,n-prev)) + (ctran-use ,n-prev) + (block-last ,n-block)) + `(ctran-use ,n-prev)) + for ,n-prev = (when ,node-var (node-prev ,node-var)) + and ,lvar = (when (and ,node-var (valued-node-p ,node-var)) + (node-lvar ,node-var)) + while ,(if restart-p + `(and ,node-var (not (block-to-be-deleted-p ,n-block))) + node-var) + do (progn + ,@body)))) + +(defmacro do-nodes-carefully ((node-var block) &body body) + (with-unique-names (n-block n-ctran) + `(loop with ,n-block = ,block + for ,n-ctran = (block-start ,n-block) then (node-next ,node-var) + for ,node-var = (and ,n-ctran (ctran-next ,n-ctran)) + while ,node-var + do (progn ,@body)))) ;;; Bind the IR1 context variables to the values associated with NODE, ;;; so that new, extra IR1 conversion related to NODE can be done @@ -683,10 +700,18 @@ (values (cdr ,n-res) t) (values nil nil)))) -;;; -(defmacro with-continuation-type-assertion ((cont ctype context) &body body) - `(let ((*lexenv* (ir1ize-the-or-values ,ctype ,cont *lexenv* ,context))) - ,@body)) +(defmacro with-component-last-block ((component block) &body body) + (with-unique-names (old-last-block) + (once-only ((component component) + (block block)) + `(let ((,old-last-block (component-last-block ,component))) + (unwind-protect + (progn (setf (component-last-block ,component) + ,block) + ,@body) + (setf (component-last-block ,component) + ,old-last-block)))))) + ;;;; the EVENT statistics/trace utility @@ -694,7 +719,7 @@ ;;; experimentation, not for ordinary use, so it should probably ;;; become conditional on SB-SHOW. -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defstruct (event-info (:copier nil)) ;; The name of this event. @@ -756,8 +781,8 @@ new-value)) (defsetf event-level %set-event-level) -;;; Define a new kind of event. Name is a symbol which names the event -;;; and Description is a string which describes the event. Level +;;; Define a new kind of event. NAME is a symbol which names the event +;;; and DESCRIPTION is a string which describes the event. Level ;;; (default 0) is the level of significance associated with this ;;; event; it is used to determine whether to print a Note when the ;;; event happens. @@ -776,7 +801,7 @@ (declaim (type unsigned-byte *event-note-threshold*)) (defvar *event-note-threshold* 1) -;;; Note that the event with the specified Name has happened. Node is +;;; Note that the event with the specified NAME has happened. NODE is ;;; evaluated to determine the node to which the event happened. (defmacro event (name &optional node) ;; Increment the counter and do any action. Mumble about the event if @@ -811,10 +836,10 @@ ;;;; functions on directly-linked lists (linked through specialized ;;;; NEXT operations) -#!-sb-fluid (declaim (inline find-in position-in map-in)) +#!-sb-fluid (declaim (inline find-in position-in)) -;;; Find Element in a null-terminated List linked by the accessor -;;; function Next. Key, Test and Test-Not are the same as for generic +;;; Find ELEMENT in a null-terminated LIST linked by the accessor +;;; function NEXT. KEY, TEST and TEST-NOT are the same as for generic ;;; sequence functions. (defun find-in (next element @@ -822,7 +847,8 @@ &key (key #'identity) (test #'eql test-p) - (test-not nil not-p)) + (test-not #'eql not-p)) + (declare (type function next key test test-not)) (when (and test-p not-p) (error "It's silly to supply both :TEST and :TEST-NOT arguments.")) (if not-p @@ -835,16 +861,17 @@ (when (funcall test (funcall key current) element) (return current))))) -;;; Return the position of Element (or NIL if absent) in a -;;; null-terminated List linked by the accessor function Next. Key, -;;; Test and Test-Not are the same as for generic sequence functions. +;;; Return the position of ELEMENT (or NIL if absent) in a +;;; null-terminated LIST linked by the accessor function NEXT. KEY, +;;; TEST and TEST-NOT are the same as for generic sequence functions. (defun position-in (next element list &key (key #'identity) (test #'eql test-p) - (test-not nil not-p)) + (test-not #'eql not-p)) + (declare (type function next key test test-not)) (when (and test-p not-p) (error "It's silly to supply both :TEST and :TEST-NOT arguments.")) (if not-p @@ -859,14 +886,6 @@ (when (funcall test (funcall key current) element) (return i))))) -;;; Map FUNCTION over the elements in a null-terminated LIST linked by the -;;; accessor function NEXT, returning an ordinary list of the results. -(defun map-in (next function list) - (collect ((res)) - (do ((current list (funcall next current))) - ((null current)) - (res (funcall function current))) - (res))) ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a ;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)