X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmacros.lisp;h=835f5a3e80ee7f2e414566aaa8c917f5675149e3;hb=bfa4310e41dcd011ca9d139f29be1c5757b41378;hp=fadd68749970a1b509e040ec82e783e338ce95b7;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index fadd687..835f5a3 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -41,13 +41,12 @@ ;;; 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 next-var result-var - &key (kind :special-form)) - &body body) +;;; 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) + &body body) (let ((fn-name (symbolicate "IR1-CONVERT-" name)) (n-form (gensym)) (n-env (gensym))) @@ -59,28 +58,31 @@ `(progn (declaim (ftype (function (ctran ctran (or lvar null) t) (values)) ,fn-name)) - (defun ,fn-name (,start-var ,next-var ,result-var ,n-form) - (let ((,n-env *lexenv*)) - ,@decls - ,body - (values))) + (defun ,fn-name (,start-var ,next-var ,result-var ,n-form + &aux (,n-env *lexenv*)) + (declare (ignorable ,start-var ,next-var ,result-var)) + ,@decls + ,body + (values)) ,@(when doc `((setf (fdocumentation ',name 'function) ,doc))) ;; FIXME: Evidently "there can only be one!" -- we overwrite any ;; other :IR1-CONVERT value. This deserves a warning, I think. (setf (info :function :ir1-convert ',name) #',fn-name) - (setf (info :function :kind ',name) ,kind) + ;; FIXME: rename this to SPECIAL-OPERATOR, to update it to + ;; the 1990s? + (setf (info :function :kind ',name) :special-form) ;; It's nice to do this for error checking in the target ;; SBCL, but it's not nice to do this when we're running in ;; the cross-compilation host Lisp, which owns the ;; SYMBOL-FUNCTION of its COMMON-LISP symbols. #-sb-xc-host - ,@(when (eq kind :special-form) - `((setf (symbol-function ',name) - (lambda (&rest rest) - (declare (ignore rest)) - (error 'special-form-function - :name ',name))))))))) + (let ((fun (lambda (&rest rest) + (declare (ignore rest)) + (error 'special-form-function :name ',name)))) + (setf (%simple-fun-arglist fun) ',lambda-list) + (setf (symbol-function ',name) fun)) + ',name)))) ;;; (This is similar to DEF-IR1-TRANSLATOR, except that we pass if the ;;; syntax is invalid.) @@ -267,15 +269,16 @@ (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) @@ -347,11 +350,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 @@ -378,7 +381,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 @@ -511,6 +514,7 @@ (let ((n-args (gensym))) `(progn (defun ,name (,n-node ,@vars) + (declare (ignorable ,@vars)) (let ((,n-args (basic-combination-args ,n-node))) ,(parse-deftransform lambda-list body n-args `(return-from ,name nil)))) @@ -562,7 +566,7 @@ ((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... @@ -577,24 +581,23 @@ ,@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. +;;; 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) @@ -619,30 +622,36 @@ (ctran-next it)) (t (return))))) ,@(when lvar-var - `((,lvar-var #1=(when (valued-node-p ,node-var) - (node-lvar ,node-var)) - #1#)))) + `((,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 -(defmacro do-nodes-backwards ((node-var lvar block) &body body) +;;; 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-prev (gensym))) - `(do* ((,n-block ,block) - (,n-start (block-start ,n-block)) - (,node-var (block-last ,n-block) (ctran-use ,n-prev)) - (,n-prev (node-prev ,node-var) (node-prev ,node-var)) - (,lvar #1=(when (valued-node-p ,node-var) (node-lvar ,node-var)) - #1#)) - (nil) - ,@body - (when (eq ,n-prev ,n-start) - (return nil))))) + `(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)