X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmacros.lisp;h=59de9b077e173b698d7e3d54180fe93dbe8f9ffa;hb=54da325f13fb41669869aea688ae195426c0e231;hp=9d310cce80ae6dc58cde828137cdd1907ec5b8b9;hpb=2d195da5e29feadce7190ea1a68a2efa83a5e1c0;p=sbcl.git diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 9d310cc..59de9b0 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -13,119 +13,73 @@ (declaim (special *wild-type* *universal-type* *compiler-error-context*)) -;;; An INLINEP value describes how a function is called. The values have these -;;; meanings: -;;; NIL No declaration seen: do whatever you feel like, but don't dump -;;; an inline expansion. +;;; An INLINEP value describes how a function is called. The values +;;; have these meanings: +;;; NIL No declaration seen: do whatever you feel like, but don't +;;; dump an inline expansion. ;;; :NOTINLINE NOTINLINE declaration seen: always do full function call. -;;; :INLINE INLINE declaration seen: save expansion, expanding to it if -;;; policy favors. +;;; :INLINE INLINE declaration seen: save expansion, expanding to it +;;; if policy favors. ;;; :MAYBE-INLINE -;;; Retain expansion, but only use it opportunistically. +;;; Retain expansion, but only use it opportunistically. +;;; :MAYBE-INLINE is quite different from :INLINE. As explained +;;; by APD on #lisp 2005-11-26: "MAYBE-INLINE lambda is +;;; instantiated once per component, INLINE - for all +;;; references (even under #'without FUNCALL)." (deftype inlinep () '(member :inline :maybe-inline :notinline nil)) -;;;; the POLICY macro - -(defparameter *policy-parameter-slots* - '((speed . cookie-speed) (space . cookie-space) (safety . cookie-safety) - (cspeed . cookie-cspeed) (brevity . cookie-brevity) - (debug . cookie-debug))) - -;;; Find all the policy parameters which are actually mentioned in Stuff, -;;; returning the names in a list. We assume everything is evaluated. -(eval-when (:compile-toplevel :load-toplevel :execute) -(defun find-used-parameters (stuff) - (if (atom stuff) - (if (assoc stuff *policy-parameter-slots*) (list stuff) ()) - (collect ((res () nunion)) - (dolist (arg (cdr stuff) (res)) - (res (find-used-parameters arg)))))) -) ; EVAL-WHEN - -;;; This macro provides some syntactic sugar for querying the settings -;;; of the compiler policy parameters. -;;; -;;; Test whether some conditions apply to the current compiler policy -;;; for Node. Each condition is a predicate form which accesses the -;;; policy values by referring to them as the variables SPEED, SPACE, -;;; SAFETY, CSPEED, BREVITY and DEBUG. The results of all the -;;; conditions are combined with AND and returned as the result. -;;; -;;; NODE is a form which is evaluated to obtain the node which the -;;; policy is for. If NODE is NIL, then we use the current policy as -;;; defined by *DEFAULT-COOKIE* and *CURRENT-COOKIE*. This option is -;;; only well defined during IR1 conversion. -(defmacro policy (node &rest conditions) - (let* ((form `(and ,@conditions)) - (n-cookie (gensym)) - (binds (mapcar - #'(lambda (name) - (let ((slot (cdr (assoc name *policy-parameter-slots*)))) - `(,name (,slot ,n-cookie)))) - (find-used-parameters form)))) - `(let* ((,n-cookie (lexenv-cookie - ,(if node - `(node-lexenv ,node) - '*lexenv*))) - ,@binds) - ,form))) - ;;;; source-hacking defining forms -;;; to be passed to PARSE-DEFMACRO when we want compiler errors -;;; instead of real errors -#!-sb-fluid (declaim (inline convert-condition-into-compiler-error)) -(defun convert-condition-into-compiler-error (datum &rest stuff) - (if (stringp datum) - (apply #'compiler-error datum stuff) - (compiler-error "~A" - (if (symbolp datum) - (apply #'make-condition datum stuff) - datum)))) - ;;; Parse a DEFMACRO-style lambda-list, setting things up so that a ;;; 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 - &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))) - (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) - `(progn - (declaim (ftype (function (continuation continuation t) (values)) - ,fn-name)) - (defun ,fn-name (,start-var ,cont-var ,n-form) - (let ((,n-env *lexenv*)) - ,@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) - ;; 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 "can't FUNCALL the SYMBOL-FUNCTION of ~ - special forms"))))))))) + (guard-name (symbolicate name "-GUARD"))) + (with-unique-names (whole-var n-env) + (multiple-value-bind (body decls doc) + (parse-defmacro lambda-list whole-var body name "special form" + :environment n-env + :error-fun 'compiler-error + :wrap-block nil) + `(progn + (declaim (ftype (function (ctran ctran (or lvar null) t) (values)) + ,fn-name)) + (defun ,fn-name (,start-var ,next-var ,result-var ,whole-var + &aux (,n-env *lexenv*)) + (declare (ignorable ,start-var ,next-var ,result-var)) + ,@decls + ,body + (values)) + #-sb-xc-host + ;; 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. These guard + ;; functions also provide the documentation for special forms. + (progn + (defun ,guard-name (&rest args) + ,@(when doc (list doc)) + (declare (ignore args)) + (error 'special-form-function :name ',name)) + (let ((fun #',guard-name)) + (setf (%simple-fun-arglist fun) ',lambda-list + (%simple-fun-name fun) ',name + (symbol-function ',name) fun) + (fmakunbound ',guard-name))) + ;; 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) + ;; FIXME: rename this to SPECIAL-OPERATOR, to update it to + ;; the 1990s? + (setf (info :function :kind ',name) :special-form) + ',name))))) ;;; (This is similar to DEF-IR1-TRANSLATOR, except that we pass if the ;;; syntax is invalid.) @@ -146,47 +100,23 @@ ;;; 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 def-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) + (with-unique-names (whole-var n-env name) (multiple-value-bind (body decls) - (parse-defmacro lambda-list n-form body name "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))))) - -;;; Define a function that converts a use of (%PRIMITIVE NAME ..) -;;; into Lisp code. LAMBDA-LIST is a DEFMACRO-style lambda list. -(defmacro def-primitive-translator (name lambda-list &body body) - (let ((fn-name (symbolicate "PRIMITIVE-TRANSLATE-" name)) - (n-form (gensym)) - (n-env (gensym))) - (multiple-value-bind (body decls) - (parse-defmacro lambda-list n-form body name "%primitive" - :environment n-env - :error-fun 'convert-condition-into-compiler-error) - `(progn - (defun ,fn-name (,n-form) - (let ((,n-env *lexenv*)) - ,@decls - ,body)) - (setf (gethash ',name *primitive-translators*) ',fn-name))))) + (parse-defmacro lambda-list whole-var body "source transform" "form" + :environment n-env + :error-fun `(lambda (&rest stuff) + (declare (ignore stuff)) + (return-from ,name + (values nil t))) + :wrap-block nil) + `(lambda (,whole-var &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 ;;;; @@ -196,7 +126,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. @@ -204,112 +134,132 @@ (collect ((res 0 logior)) (dolist (name names) (let ((mask (cdr (assoc name alist)))) - (unless mask - (error "unknown attribute name: ~S" name)) - (res mask))) + (unless mask + (error "unknown attribute name: ~S" name)) + (res mask))) (res))) ) ; EVAL-WHEN -;;; Parse the specification and generate some accessor macros. +;;; Define a new class of boolean attributes, with the attributes +;;; having the specified ATTRIBUTE-NAMES. NAME is the name of the +;;; class, which is used to generate some macros to manipulate sets of +;;; the attributes: ;;; -;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a -;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..) -;;; #+SB-XC-HOST -;;; (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..) -;;; arrangement, in order to get it to work in cross-compilation. This -;;; duplication should be removed, perhaps by rewriting the macro in a -;;; more cross-compiler-friendly way, or perhaps just by using some -;;; (MACROLET ((FROB ..)) .. FROB .. FROB) form, but I don't want to -;;; do it now, because the system isn't running yet, so it'd be too -;;; hard to check that my changes were correct -- WHN 19990806 -(def!macro def-boolean-attribute (name &rest attribute-names) - #!+sb-doc - "Def-Boolean-Attribute Name Attribute-Name* - Define a new class of boolean attributes, with the attributes having the - specified Attribute-Names. Name is the name of the class, which is used to - generate some macros to manipulate sets of the attributes: - - NAME-attributep attributes attribute-name* - Return true if one of the named attributes is present, false otherwise. - When set with SETF, updates the place Attributes setting or clearing the - specified attributes. - - NAME-attributes attribute-name* - Return a set of the named attributes." - - (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*")) - (test-name (symbolicate name "-ATTRIBUTEP"))) - (collect ((alist)) - (do ((mask 1 (ash mask 1)) - (names attribute-names (cdr names))) - ((null names)) - (alist (cons (car names) mask))) - - `(progn - - (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter ,translations-name ',(alist))) - - (defmacro ,test-name (attributes &rest attribute-names) - "Automagically generated boolean attribute test function. See - Def-Boolean-Attribute." - `(logtest ,(compute-attribute-mask attribute-names - ,translations-name) - (the attributes ,attributes))) - - (define-setf-expander ,test-name (place &rest attributes - &environment env) - "Automagically generated boolean attribute setter. See - Def-Boolean-Attribute." - #-sb-xc-host (declare (type sb!c::lexenv env)) - ;; FIXME: It would be better if &ENVIRONMENT arguments - ;; were automatically declared to have type LEXENV by the - ;; hairy-argument-handling code. - (multiple-value-bind (temps values stores set get) - (get-setf-expansion place env) - (when (cdr stores) - (error "multiple store variables for ~S" place)) - (let ((newval (gensym)) - (n-place (gensym)) - (mask (compute-attribute-mask attributes - ,translations-name))) - (values `(,@temps ,n-place) - `(,@values ,get) - `(,newval) - `(let ((,(first stores) - (if ,newval - (logior ,n-place ,mask) - (logand ,n-place ,(lognot mask))))) - ,set - ,newval) - `(,',test-name ,n-place ,@attributes))))) - - (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names) - "Automagically generated boolean attribute creation function. See - Def-Boolean-Attribute." - (compute-attribute-mask attribute-names ,translations-name)))))) -;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806 +;;; NAME-attributep attributes attribute-name* +;;; Return true if one of the named attributes is present, false +;;; otherwise. When set with SETF, updates the place Attributes +;;; setting or clearing the specified attributes. +;;; +;;; NAME-attributes attribute-name* +;;; Return a set of the named attributes. +#-sb-xc +(progn + (def!macro !def-boolean-attribute (name &rest attribute-names) + + (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*")) + (test-name (symbolicate name "-ATTRIBUTEP")) + (decoder-name (symbolicate "DECODE-" name "-ATTRIBUTES"))) + (collect ((alist)) + (do ((mask 1 (ash mask 1)) + (names attribute-names (cdr names))) + ((null names)) + (alist (cons (car names) mask))) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter ,translations-name ',(alist))) + (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names) + "Automagically generated boolean attribute creation function. + See !DEF-BOOLEAN-ATTRIBUTE." + (compute-attribute-mask attribute-names ,translations-name)) + (defmacro ,test-name (attributes &rest attribute-names) + "Automagically generated boolean attribute test function. + See !DEF-BOOLEAN-ATTRIBUTE." + `(logtest ,(compute-attribute-mask attribute-names + ,translations-name) + (the attributes ,attributes))) + ;; This definition transforms strangely under UNCROSS, in a + ;; way that DEF!MACRO doesn't understand, so we delegate it + ;; to a submacro then define the submacro differently when + ;; building the xc and when building the target compiler. + (!def-boolean-attribute-setter ,test-name + ,translations-name + ,@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 + ;; hack it by hand, passing a different GET-SETF-EXPANSION-FUN-NAME + ;; in the host DEFMACRO and target DEFMACRO-MUNDANELY cases. + (defun guts-of-!def-boolean-attribute-setter (test-name + translations-name + attribute-names + get-setf-expansion-fun-name) + (declare (ignore attribute-names)) + `(define-setf-expander ,test-name (place &rest attributes + &environment env) + "Automagically generated boolean attribute setter. See + !DEF-BOOLEAN-ATTRIBUTE." + #-sb-xc-host (declare (type sb!c::lexenv env)) + ;; FIXME: It would be better if &ENVIRONMENT arguments were + ;; automatically declared to have type LEXENV by the + ;; hairy-argument-handling code. + (multiple-value-bind (temps values stores set get) + (,get-setf-expansion-fun-name place env) + (when (cdr stores) + (error "multiple store variables for ~S" place)) + (let ((newval (sb!xc:gensym)) + (n-place (sb!xc:gensym)) + (mask (compute-attribute-mask attributes ,translations-name))) + (values `(,@temps ,n-place) + `(,@values ,get) + `(,newval) + `(let ((,(first stores) + (if ,newval + (logior ,n-place ,mask) + (logand ,n-place ,(lognot mask))))) + ,set + ,newval) + `(,',test-name ,n-place ,@attributes)))))) + ;; We define the host version here, and the just-like-it-but-different + ;; target version later, after DEFMACRO-MUNDANELY has been defined. + (defmacro !def-boolean-attribute-setter (test-name + translations-name + &rest attribute-names) + (guts-of-!def-boolean-attribute-setter test-name + translations-name + attribute-names + 'get-setf-expansion))) + +;;; Otherwise the source locations for DEFTRANSFORM, DEFKNOWN, &c +;;; would be off by one toplevel form as their source locations are +;;; determined before cross-compiling where the above PROGN is not +;;; seen. +#+sb-xc (progn) ;;; And now for some gratuitous pseudo-abstraction... +;;; +;;; ATTRIBUTES-UNION +;;; Return the union of all the sets of boolean attributes which are its +;;; arguments. +;;; ATTRIBUTES-INTERSECTION +;;; Return the intersection of all the sets of boolean attributes which +;;; are its arguments. +;;; ATTRIBUTES +;;; True if the attributes present in ATTR1 are identical to +;;; those in ATTR2. (defmacro attributes-union (&rest attributes) - #!+sb-doc - "Returns the union of all the sets of boolean attributes which are its - arguments." `(the attributes - (logior ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes)))) + (logior ,@(mapcar (lambda (x) `(the attributes ,x)) attributes)))) (defmacro attributes-intersection (&rest attributes) - #!+sb-doc - "Returns the intersection of all the sets of boolean attributes which are its - arguments." `(the attributes - (logand ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes)))) + (logand ,@(mapcar (lambda (x) `(the attributes ,x)) attributes)))) (declaim (ftype (function (attributes attributes) boolean) attributes=)) #!-sb-fluid (declaim (inline attributes=)) (defun attributes= (attr1 attr2) - #!+sb-doc - "Returns true if the attributes present in Attr1 are identical to those in - Attr2." (eql attr1 attr2)) ;;;; lambda-list parsing utilities @@ -318,192 +268,184 @@ ;;;; 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. -(declaim (ftype (function (list list symbol t) list) parse-deftransform)) +;;; the arguments of a combination with respect to that +;;; lambda-list. BODY is 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) (let* ((min-args (length req)) - (max-args (+ min-args (length opt))) - (n-keys (gensym))) + (max-args (+ min-args (length opt))) + (n-keys (gensym))) (collect ((binds) - (vars) - (pos 0 +) - (keywords)) - (dolist (arg req) - (vars arg) - (binds `(,arg (nth ,(pos) ,args))) - (pos 1)) - - (dolist (arg opt) - (let ((var (if (atom arg) arg (first arg)))) - (vars var) - (binds `(,var (nth ,(pos) ,args))) - (pos 1))) - - (when restp - (vars rest) - (binds `(,rest (nthcdr ,(pos) ,args)))) - - (dolist (spec keys) - (if (or (atom spec) (atom (first spec))) - (let* ((var (if (atom spec) spec (first spec))) - (key (intern (symbol-name var) "KEYWORD"))) - (vars var) - (binds `(,var (find-keyword-continuation ,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))) - (keywords key)))) - - (let ((n-length (gensym)) - (limited-legal (not (or restp keyp)))) - (values - `(let ((,n-length (length ,args)) - ,@(when keyp `((,n-keys (nthcdr ,(pos) ,args))))) - (unless (and - ;; FIXME: should be PROPER-LIST-OF-LENGTH-P - ,(if limited-legal - `(<= ,min-args ,n-length ,max-args) - `(<= ,min-args ,n-length)) - ,@(when keyp - (if allowp - `((check-keywords-constant ,n-keys)) - `((check-transform-keys ,n-keys ',(keywords)))))) - ,error-form) - (let ,(binds) - (declare (ignorable ,@(vars))) - ,@body)) - (vars))))))) + (vars) + (pos 0 +) + (keywords)) + (dolist (arg req) + (vars arg) + (binds `(,arg (nth ,(pos) ,args))) + (pos 1)) + + (dolist (arg opt) + (let ((var (if (atom arg) arg (first arg)))) + (vars var) + (binds `(,var (nth ,(pos) ,args))) + (pos 1))) + + (when restp + (vars rest) + (binds `(,rest (nthcdr ,(pos) ,args)))) + + (dolist (spec keys) + (if (or (atom spec) (atom (first spec))) + (let* ((var (if (atom spec) spec (first spec))) + (key (keywordicate var))) + (vars var) + (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-lvar ,n-keys ,key))) + (keywords key)))) + + (let ((n-length (gensym)) + (limited-legal (not (or restp keyp)))) + (values + `(let ((,n-length (length ,args)) + ,@(when keyp `((,n-keys (nthcdr ,(pos) ,args))))) + (unless (and + ;; FIXME: should be PROPER-LIST-OF-LENGTH-P + ,(if limited-legal + `(<= ,min-args ,n-length ,max-args) + `(<= ,min-args ,n-length)) + ,@(when keyp + (if allowp + `((check-key-args-constant ,n-keys)) + `((check-transform-keys ,n-keys ',(keywords)))))) + ,error-form) + (let ,(binds) + (declare (ignorable ,@(vars))) + ,@body)) + (vars))))))) ) ; EVAL-WHEN ;;;; DEFTRANSFORM -;;; Parse the lambda-list and generate code to test the policy and -;;; automatically create the result lambda. +;;; Define an IR1 transformation for NAME. An IR1 transformation +;;; computes a lambda that replaces the function variable reference +;;; for the call. A transform may pass (decide not to transform the +;;; call) by calling the GIVE-UP-IR1-TRANSFORM function. LAMBDA-LIST +;;; both determines how the current call is parsed and specifies the +;;; LAMBDA-LIST for the resulting lambda. +;;; +;;; We parse the call and bind each of the lambda-list variables to +;;; 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 +;;; lambda-list variables. The DOC-STRING is used when printing +;;; efficiency notes about the defined transform. +;;; +;;; Normally, the body evaluates to a form which becomes the body of +;;; an automatically constructed lambda. We make LAMBDA-LIST the +;;; lambda-list for the lambda, and automatically insert declarations +;;; of the argument and result types. If the second value of the body +;;; is non-null, then it is a list of declarations which are to be +;;; inserted at the head of the lambda. Automatic lambda generation +;;; may be inhibited by explicitly returning a lambda from the body. +;;; +;;; The ARG-TYPES and RESULT-TYPE are used to create a function type +;;; which the call must satisfy before transformation is attempted. +;;; The function type specifier is constructed by wrapping (FUNCTION +;;; ...) around these values, so the lack of a restriction may be +;;; specified by omitting the argument or supplying *. The argument +;;; syntax specified in the ARG-TYPES need not be the same as that in +;;; the LAMBDA-LIST, but the transform will never happen if the +;;; syntaxes can't be satisfied simultaneously. If there is an +;;; existing transform for the same function that has the same type, +;;; then it is replaced with the new definition. +;;; +;;; These are the legal keyword options: +;;; :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 +;;; is false, then the transform automatically gives up. +;;; :EVAL-NAME +;;; - The name and argument/result types are actually forms to be +;;; evaluated. Useful for getting closures that transform similar +;;; functions. +;;; :DEFUN-ONLY +;;; - Don't actually instantiate a transform, instead just DEFUN +;;; Name with the specified transform definition function. This +;;; may be later instantiated with %DEFTRANSFORM. +;;; :IMPORTANT +;;; - If supplied and non-NIL, note this transform as ``important,'' +;;; which means efficiency notes will be generated when this +;;; transform fails even if INHIBIT-WARNINGS=SPEED (but not if +;;; INHIBIT-WARNINGS>SPEED). (defmacro deftransform (name (lambda-list &optional (arg-types '*) - (result-type '*) - &key result policy node defun-only - eval-name important (when :native)) - &body body-decls-doc) - #!+sb-doc - "Deftransform Name (Lambda-List [Arg-Types] [Result-Type] {Key Value}*) - Declaration* [Doc-String] Form* - Define an IR1 transformation for NAME. An IR1 transformation computes a - lambda that replaces the function variable reference for the call. A - transform may pass (decide not to transform the call) by calling the - GIVE-UP-IR1-TRANSFORM function. LAMBDA-LIST both determines how the - current call is parsed and specifies the 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 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 lambda-list variables. The DOC-STRING - is used when printing efficiency notes about the defined transform. - - Normally, the body evaluates to a form which becomes the body of an - automatically constructed lambda. We make LAMBDA-LIST the lambda-list - for the lambda, and automatically insert declarations of the argument - and result types. If the second value of the body is non-null, then it - is a list of declarations which are to be inserted at the head of the - lambda. Automatic lambda generation may be inhibited by explicitly - returning a lambda from the body. - - The ARG-TYPES and RESULT-TYPE are used to create a function type - which the call must satisfy before transformation is attempted. The - function type specifier is constructed by wrapping (FUNCTION ...) - around these values, so the lack of a restriction may be specified by - omitting the argument or supplying *. The argument syntax specified in - the ARG-TYPES need not be the same as that in the LAMBDA-LIST, but the - transform will never happen if the syntaxes can't be satisfied - simultaneously. If there is an existing transform for the same - function that has the same type, then it is replaced with the new - definition. - - These are the legal keyword options: - :Result - A variable which is bound to the result continuation. - :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 is false, then - the transform automatically passes. - :Eval-Name - - The name and argument/result types are actually forms to be - evaluated. Useful for getting closures that transform similar - functions. - :Defun-Only - - Don't actually instantiate a transform, instead just DEFUN - Name with the specified transform definition function. This may - be later instantiated with %DEFTRANSFORM. - :Important - - If supplied and non-NIL, note this transform as ``important,'' - which means efficiency notes will be generated when this - transform fails even if brevity=speed (but not if brevity>speed) - :When {:Native | :Byte | :Both} - - Indicates whether this transform applies to native code, - byte-code or both (default :native.)" - + (result-type '*) + &key result policy node defun-only + eval-name important) + &body body-decls-doc) (when (and eval-name defun-only) (error "can't specify both DEFUN-ONLY and EVAL-NAME")) (multiple-value-bind (body decls doc) (parse-body body-decls-doc) - (let ((n-args (gensym)) - (n-node (or node (gensym))) - (n-decls (gensym)) - (n-lambda (gensym)) - (decls-body `(,@decls ,@body))) + (let ((n-args (sb!xc:gensym)) + (n-node (or node (sb!xc:gensym))) + (n-decls (sb!xc:gensym)) + (n-lambda (sb!xc:gensym)) + (decls-body `(,@decls ,@body))) (multiple-value-bind (parsed-form vars) - (parse-deftransform lambda-list - (if policy - `((unless (policy ,n-node ,policy) - (give-up-ir1-transform)) - ,@decls-body) - body) - n-args - '(give-up-ir1-transform)) - (let ((stuff - `((,n-node) - (let* ((,n-args (basic-combination-args ,n-node)) - ,@(when result - `((,result (node-cont ,n-node))))) - (multiple-value-bind (,n-lambda ,n-decls) - ,parsed-form - (if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda)) - ,n-lambda - `(lambda ,',lambda-list - (declare (ignorable ,@',vars)) - ,@,n-decls - ,,n-lambda))))))) - (if defun-only - `(defun ,name ,@(when doc `(,doc)) ,@stuff) - `(%deftransform - ,(if eval-name name `',name) - ,(if eval-name - ``(function ,,arg-types ,,result-type) - `'(function ,arg-types ,result-type)) - #'(lambda ,@stuff) - ,doc - ,(if important t nil) - ,when))))))) + (parse-deftransform lambda-list + (if policy + `((unless (policy ,n-node ,policy) + (give-up-ir1-transform)) + ,@decls-body) + body) + n-args + '(give-up-ir1-transform)) + (let ((stuff + `((,n-node) + (let* ((,n-args (basic-combination-args ,n-node)) + ,@(when result + `((,result (node-lvar ,n-node))))) + (multiple-value-bind (,n-lambda ,n-decls) + ,parsed-form + (if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda)) + ,n-lambda + `(lambda ,',lambda-list + (declare (ignorable ,@',vars)) + ,@,n-decls + ,,n-lambda))))))) + (if defun-only + `(defun ,name ,@(when doc `(,doc)) ,@stuff) + `(%deftransform + ,(if eval-name name `',name) + ,(if eval-name + ``(function ,,arg-types ,,result-type) + `'(function ,arg-types ,result-type)) + (lambda ,@stuff) + ,doc + ,(if important t nil)))))))) ;;;; DEFKNOWN and DEFOPTIMIZER @@ -516,373 +458,305 @@ ;;; ;;; FIXME: DEFKNOWN is needed only at build-the-system time. Figure ;;; out some way to keep it from appearing in the target system. +;;; +;;; Declare the function NAME to be a known function. We construct a +;;; type specifier for the function by wrapping (FUNCTION ...) around +;;; the ARG-TYPES and RESULT-TYPE. ATTRIBUTES is an unevaluated list +;;; of boolean attributes of the function. See their description in +;;; (!DEF-BOOLEAN-ATTRIBUTE IR1). NAME may also be a list of names, in +;;; which case the same information is given to all the names. The +;;; 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) - #!+sb-doc - "Defknown Name Arg-Types Result-Type [Attributes] {Key Value}* - Declare the function Name to be a known function. We construct a type - specifier for the function by wrapping (FUNCTION ...) around the Arg-Types - and Result-Type. Attributes is an unevaluated list of boolean - attributes of the function. These attributes are meaningful here: - call - May call functions that are passed as arguments. In order - to determine what other effects are present, we must find - the effects of all arguments that may be functions. - - unsafe - May incorporate arguments in the result or somehow pass - them upward. - - unwind - May fail to return during correct execution. Errors - are O.K. - - any - The (default) worst case. Includes all the other bad - things, plus any other possible bad thing. - - foldable - May be constant-folded. The function has no side effects, - but may be affected by side effects on the arguments. E.g. - SVREF, MAPC. - - flushable - May be eliminated if value is unused. The function has - no side effects except possibly CONS. If a function is - defined to signal errors, then it is not flushable even - if it is movable or foldable. - - movable - May be moved with impunity. Has no side effects except - possibly CONS,and is affected only by its arguments. - - predicate - A true predicate likely to be open-coded. This is a - hint to IR1 conversion that it should ensure calls always - appear as an IF test. Not usually specified to Defknown, - since this is implementation dependent, and is usually - automatically set by the Define-VOP :Conditional option. - - Name may also be a list of names, in which case the same information - is given to all the names. The keywords specify the initial values - for various optimizers that the function might have." + &body keys) + #-sb-xc-host + (when (member 'unsafe attributes) + (style-warn "Ignoring legacy attribute UNSAFE. Replaced by its inverse: DX-SAFE.") + (setf attributes (remove 'unsafe attributes))) (when (and (intersection attributes '(any call unwind)) - (intersection attributes '(movable))) + (intersection attributes '(movable))) (error "function cannot have both good and bad attributes: ~S" attributes)) + (when (member 'any attributes) + (setq attributes (union '(call unwind) attributes))) + (when (member 'flushable attributes) + (pushnew 'unsafely-flushable attributes)) + `(%defknown ',(if (and (consp name) - (not (eq (car name) 'setf))) - name - (list name)) - '(function ,arg-types ,result-type) - (ir1-attributes ,@(if (member 'any attributes) - (union '(call unsafe unwind) attributes) - attributes)) - ,@keys)) - -;;; Create a function which parses combination args according to -;;; LAMBDA-LIST, optionally storing it in a FUNCTION-INFO slot. -(defmacro defoptimizer (what (lambda-list &optional (n-node (gensym)) - &rest vars) - &body body) - #!+sb-doc - "Defoptimizer (Function Kind) (Lambda-List [Node-Var] Var*) - Declaration* Form* - Define some Kind of optimizer for the named Function. Function must be a - known function. Lambda-List is used to parse the arguments to the - combination as in Deftransform. If the argument syntax is invalid or there - are non-constant keys, then we simply return NIL. - - The function is DEFUN'ed as Function-Kind-OPTIMIZER. Possible kinds are - DERIVE-TYPE, OPTIMIZER, LTN-ANNOTATE and IR2-CONVERT. If a symbol is - specified instead of a (Function Kind) list, then we just do a DEFUN with the - symbol as its name, and don't do anything with the definition. This is - useful for creating optimizers to be passed by name to DEFKNOWN. - - If supplied, Node-Var is bound to the combination node being optimized. If - additional Vars are supplied, then they are used as the rest of the optimizer - function's lambda-list. LTN-ANNOTATE methods are passed an additional POLICY - argument, and IR2-CONVERT methods are passed an additional IR2-BLOCK - argument." - - (let ((name (if (symbolp what) what - (symbolicate (first what) "-" (second what) "-OPTIMIZER")))) - - (let ((n-args (gensym))) - `(progn - (defun ,name (,n-node ,@vars) - (let ((,n-args (basic-combination-args ,n-node))) - ,(parse-deftransform lambda-list body n-args - `(return-from ,name nil)))) - ,@(when (consp what) - `((setf (,(symbolicate "FUNCTION-INFO-" (second what)) - (function-info-or-lose ',(first what))) - #',name))))))) + (not (legal-fun-name-p name))) + name + (list name)) + '(sfunction ,arg-types ,result-type) + (ir1-attributes ,@attributes) + ,@keys)) + +;;; Create a function which parses combination args according to WHAT +;;; and LAMBDA-LIST, where WHAT is either a function name or a list +;;; (FUN-NAME KIND) and does some KIND of optimization. +;;; +;;; The FUN-NAME must name a known function. LAMBDA-LIST is used +;;; to parse the arguments to the combination as in DEFTRANSFORM. If +;;; the argument syntax is invalid or there are non-constant keys, +;;; then we simply return NIL. +;;; +;;; The function is DEFUN'ed as FUNCTION-KIND-OPTIMIZER. Possible +;;; kinds are DERIVE-TYPE, OPTIMIZER, LTN-ANNOTATE and IR2-CONVERT. If +;;; a symbol is specified instead of a (FUNCTION KIND) list, then we +;;; just do a DEFUN with the symbol as its name, and don't do anything +;;; with the definition. This is useful for creating optimizers to be +;;; passed by name to DEFKNOWN. +;;; +;;; If supplied, NODE-VAR is bound to the combination node being +;;; optimized. If additional VARS are supplied, then they are used as +;;; the rest of the optimizer function's lambda-list. LTN-ANNOTATE +;;; methods are passed an additional POLICY argument, and IR2-CONVERT +;;; methods are passed an additional IR2-BLOCK argument. +(defmacro defoptimizer (what (lambda-list &optional (n-node (sb!xc:gensym)) + &rest vars) + &body body) + (flet ((function-name (name) + (etypecase name + (symbol name) + ((cons (eql setf) (cons symbol null)) + (symbolicate (car name) "-" (cadr name)))))) + (let ((name (if (symbolp what) + what + (symbolicate (function-name (first what)) + "-" (second what) "-OPTIMIZER")))) + + (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)))) + ,@(when (consp what) + `((setf (,(let ((*package* (symbol-package 'sb!c::fun-info))) + (symbolicate "FUN-INFO-" (second what))) + (fun-info-or-lose ',(first what))) + #',name)))))))) ;;;; IR groveling macros +;;; Iterate over the blocks in a component, binding BLOCK-VAR to each +;;; block in turn. The value of ENDS determines whether to iterate +;;; over dummy head and tail blocks: +;;; NIL -- Skip Head and Tail (the default) +;;; :HEAD -- Do head but skip tail +;;; :TAIL -- Do tail but skip head +;;; :BOTH -- Do both head and tail +;;; +;;; If supplied, RESULT-FORM is the value to return. (defmacro do-blocks ((block-var component &optional ends result) &body body) - #!+sb-doc - "Do-Blocks (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}* - Iterate over the blocks in a component, binding Block-Var to each block in - turn. The value of Ends determines whether to iterate over dummy head and - tail blocks: - NIL -- Skip Head and Tail (the default) - :Head -- Do head but skip tail - :Tail -- Do tail but skip head - :Both -- Do both head and tail - - If supplied, Result-Form is the value to return." (unless (member ends '(nil :head :tail :both)) (error "losing ENDS value: ~S" ends)) (let ((n-component (gensym)) - (n-tail (gensym))) + (n-tail (gensym))) `(let* ((,n-component ,component) - (,n-tail ,(if (member ends '(:both :tail)) - nil - `(component-tail ,n-component)))) + (,n-tail ,(if (member ends '(:both :tail)) + nil + `(component-tail ,n-component)))) (do ((,block-var ,(if (member ends '(:both :head)) - `(component-head ,n-component) - `(block-next (component-head ,n-component))) - (block-next ,block-var))) - ((eq ,block-var ,n-tail) ,result) - ,@body)))) + `(component-head ,n-component) + `(block-next (component-head ,n-component))) + (block-next ,block-var))) + ((eq ,block-var ,n-tail) ,result) + ,@body)))) +;;; like DO-BLOCKS, only iterating over the blocks in reverse order (defmacro do-blocks-backwards ((block-var component &optional ends result) &body body) - #!+sb-doc - "Do-Blocks-Backwards (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}* - Like Do-Blocks, only iterate over the blocks in reverse order." (unless (member ends '(nil :head :tail :both)) (error "losing ENDS value: ~S" ends)) (let ((n-component (gensym)) - (n-head (gensym))) + (n-head (gensym))) `(let* ((,n-component ,component) - (,n-head ,(if (member ends '(:both :head)) - nil - `(component-head ,n-component)))) + (,n-head ,(if (member ends '(:both :head)) + nil + `(component-head ,n-component)))) (do ((,block-var ,(if (member ends '(:both :tail)) - `(component-tail ,n-component) - `(block-prev (component-tail ,n-component))) - (block-prev ,block-var))) - ((eq ,block-var ,n-head) ,result) - ,@body)))) - -;;; Could change it not to replicate the code someday perhaps... -(defmacro do-uses ((node-var continuation &optional result) &body body) - #!+sb-doc - "Do-Uses (Node-Var Continuation [Result]) {Declaration}* {Form}* - Iterate over the uses of Continuation, binding Node to each one - successively." - (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))))) - -;;; 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. + `(component-tail ,n-component) + `(block-prev (component-tail ,n-component))) + (block-prev ,block-var))) + ((eq ,block-var ,n-head) ,result) + ,@body)))) + +;;; Iterate over the uses of LVAR, binding NODE to each one +;;; successively. +(defmacro do-uses ((node-var lvar &optional result) &body body) + (with-unique-names (uses) + `(let ((,uses (lvar-uses ,lvar))) + (block nil + (flet ((do-1-use (,node-var) + ,@body)) + (if (listp ,uses) + (dolist (node ,uses) + (do-1-use node)) + (do-1-use ,uses))) + ,result)))) + +;;; Iterate over the nodes in BLOCK, binding NODE-VAR to the each node +;;; 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 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 beacuse 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) - #!+sb-doc - "Do-Nodes (Node-Var Cont-Var Block {Key Value}*) {Declaration}* {Form}* - 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 Restart-P, which - causes iteration to be restarted when a node is deleted out from under us (if - not supplied, this is an error.)" +;;; 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-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) - (assert (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)))))) -(defmacro do-nodes-backwards ((node-var cont-var block) &body body) - #!+sb-doc - "Do-Nodes-Backwards (Node-Var Cont-Var Block) {Declaration}* {Form}* - Like Do-Nodes, only iterates in reverse order." - (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)))))) - -;;; The lexical environment is presumably already null... -(defmacro with-ir1-environment (node &rest forms) - #!+sb-doc - "With-IR1-Environment Node Form* - Bind the IR1 context variables so that IR1 conversion can be done after the - main conversion pass has finished." - (let ((n-node (gensym))) - `(let* ((,n-node ,node) - (*current-component* (block-component (node-block ,n-node))) - (*lexenv* (node-lexenv ,n-node)) - (*current-path* (node-source-path ,n-node))) - ,@forms))) + (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 +;;; after the original conversion pass has finished. +(defmacro with-ir1-environment-from-node (node &rest forms) + `(flet ((closure-needing-ir1-environment-from-node () + ,@forms)) + (%with-ir1-environment-from-node + ,node + #'closure-needing-ir1-environment-from-node))) +(defun %with-ir1-environment-from-node (node fun) + (declare (type node node) (type function fun)) + (let ((*current-component* (node-component node)) + (*lexenv* (node-lexenv node)) + (*current-path* (node-source-path node))) + (aver-live-component *current-component*) + (funcall fun))) + +(defmacro with-source-paths (&body forms) + (with-unique-names (source-paths) + `(let* ((,source-paths (make-hash-table :test 'eq)) + (*source-paths* ,source-paths)) + (unwind-protect + (progn ,@forms) + (clrhash ,source-paths))))) ;;; Bind the hashtables used for keeping track of global variables, -;;; functions, &c. Also establish condition handlers. +;;; functions, etc. Also establish condition handlers. (defmacro with-ir1-namespace (&body forms) - `(let ((*free-variables* (make-hash-table :test 'eq)) - (*free-functions* (make-hash-table :test 'equal)) - (*constants* (make-hash-table :test 'equal)) - (*source-paths* (make-hash-table :test 'eq))) - (handler-bind ((compiler-error #'compiler-error-handler) - (style-warning #'compiler-style-warning-handler) - (warning #'compiler-warning-handler)) - ,@forms))) - + `(let ((*free-vars* (make-hash-table :test 'eq)) + (*free-funs* (make-hash-table :test 'equal)) + (*constants* (make-hash-table :test 'equal))) + (unwind-protect + (progn ,@forms) + (clrhash *free-funs*) + (clrhash *free-vars*) + (clrhash *constants*)))) + +;;; Look up NAME in the lexical environment namespace designated by +;;; SLOT, returning the , or if no entry. The +;;; :TEST keyword may be used to determine the name equality +;;; predicate. (defmacro lexenv-find (name slot &key test) - #!+sb-doc - "LEXENV-FIND Name Slot {Key Value}* - Look up Name in the lexical environment namespace designated by Slot, - returning the , or if no entry. The :TEST keyword - may be used to determine the name equality predicate." - (once-only ((n-res `(assoc ,name (,(symbolicate "LEXENV-" slot) *lexenv*) - :test ,(or test '#'eq)))) + (once-only ((n-res `(assoc ,name (,(let ((*package* (symbol-package 'lexenv-funs))) + (symbolicate "LEXENV-" slot)) + *lexenv*) + :test ,(or test '#'eq)))) `(if ,n-res - (values (cdr ,n-res) t) - (values nil nil)))) - -;;; These functions are called by the expansion of the DEFPRINTER -;;; macro to do the actual printing. -(declaim (ftype (function (symbol t stream &optional t) (values)) - defprinter-prin1 defprinter-princ)) -(defun defprinter-prin1 (name value stream &optional indent) - (declare (ignore indent)) - (defprinter-prinx #'prin1 name value stream)) -(defun defprinter-princ (name value stream &optional indent) - (declare (ignore indent)) - (defprinter-prinx #'princ name value stream)) -(defun defprinter-prinx (prinx name value stream) - (declare (type function prinx)) - (write-char #\space stream) - (when *print-pretty* - (pprint-newline :linear stream)) - (format stream ":~A " name) - (funcall prinx value stream) - (values)) + (values (cdr ,n-res) t) + (values nil nil)))) + +(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)))))) -;; Define some kind of reasonable PRINT-OBJECT method for a STRUCTURE-OBJECT. -;; -;; NAME is the name of the structure class, and CONC-NAME is the same as in -;; DEFSTRUCT. -;; -;; The SLOT-DESCS describe how each slot should be printed. Each SLOT-DESC can -;; be a slot name, indicating that the slot should simply be printed. A -;; SLOT-DESC may also be a list of a slot name and other stuff. The other stuff -;; is composed of keywords followed by expressions. The expressions are -;; evaluated with the variable which is the slot name bound to the value of the -;; slot. These keywords are defined: -;; -;; :PRIN1 Print the value of the expression instead of the slot value. -;; :PRINC Like :PRIN1, only princ the value -;; :TEST Only print something if the test is true. -;; -;; If no printing thing is specified then the slot value is printed as PRIN1. -;; -;; The structure being printed is bound to STRUCTURE and the stream is bound to -;; STREAM. -(defmacro defprinter ((name &key (conc-name (concatenate 'simple-string - (symbol-name name) - "-"))) - &rest slot-descs) - (flet ((sref (slot-name) - `(,(symbolicate conc-name slot-name) structure))) - (collect ((prints)) - (dolist (slot-desc slot-descs) - (if (atom slot-desc) - (prints `(defprinter-prin1 ',slot-desc ,(sref slot-desc) stream)) - (let ((sname (first slot-desc)) - (test t)) - (collect ((stuff)) - (do ((option (rest slot-desc) (cddr option))) - ((null option) - (prints - `(let ((,sname ,(sref sname))) - (when ,test - ,@(or (stuff) - `((defprinter-prin1 ',sname ,sname - stream))))))) - (case (first option) - (:prin1 - (stuff `(defprinter-prin1 ',sname ,(second option) - stream))) - (:princ - (stuff `(defprinter-princ ',sname ,(second option) - stream))) - (:test (setq test (second option))) - (t - (error "bad DEFPRINTER option: ~S" (first option))))))))) - - `(def!method print-object ((structure ,name) stream) - (print-unreadable-object (structure stream :type t) - (pprint-logical-block (stream nil) - ;;(pprint-indent :current 2 stream) - ,@(prints))))))) -;;;; the Event statistics/trace utility +;;;; the EVENT statistics/trace utility ;;; FIXME: This seems to be useful for troubleshooting and ;;; 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 +(defstruct (event-info (:copier nil)) ;; The name of this event. - (name (required-argument) :type symbol) + (name (missing-arg) :type symbol) ;; The string rescribing this event. - (description (required-argument) :type string) + (description (missing-arg) :type string) ;; The name of the variable we stash this in. - (var (required-argument) :type symbol) + (var (missing-arg) :type symbol) ;; The number of times this event has happened. (count 0 :type fixnum) ;; The level of significance of this event. - (level (required-argument) :type unsigned-byte) + (level (missing-arg) :type unsigned-byte) ;; If true, a function that gets called with the node that the event ;; happened to. (action nil :type (or function null))) @@ -900,161 +774,143 @@ ) ; EVAL-WHEN +;;; Return the number of times that EVENT has happened. (declaim (ftype (function (symbol) fixnum) event-count)) (defun event-count (name) - #!+sb-doc - "Return the number of times that Event has happened." (event-info-count (event-info-or-lose name))) +;;; Return the function that is called when Event happens. If this is +;;; null, there is no action. The function is passed the node to which +;;; the event happened, or NIL if there is no relevant node. This may +;;; be set with SETF. (declaim (ftype (function (symbol) (or function null)) event-action)) (defun event-action (name) - #!+sb-doc - "Return the function that is called when Event happens. If this is null, - there is no action. The function is passed the node to which the event - happened, or NIL if there is no relevant node. This may be set with SETF." (event-info-action (event-info-or-lose name))) (declaim (ftype (function (symbol (or function null)) (or function null)) - %set-event-action)) + %set-event-action)) (defun %set-event-action (name new-value) (setf (event-info-action (event-info-or-lose name)) - new-value)) + new-value)) (defsetf event-action %set-event-action) +;;; Return the non-negative integer which represents the level of +;;; significance of the event Name. This is used to determine whether +;;; to print a message when the event happens. This may be set with +;;; SETF. (declaim (ftype (function (symbol) unsigned-byte) event-level)) (defun event-level (name) - #!+sb-doc - "Return the non-negative integer which represents the level of significance - of the event Name. This is used to determine whether to print a message when - the event happens. This may be set with SETF." (event-info-level (event-info-or-lose name))) (declaim (ftype (function (symbol unsigned-byte) unsigned-byte) %set-event-level)) (defun %set-event-level (name new-value) (setf (event-info-level (event-info-or-lose name)) - new-value)) + new-value)) (defsetf event-level %set-event-level) -;;; Make an EVENT-INFO structure and stash it in a variable so we can -;;; get at it quickly. +;;; 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. (defmacro defevent (name description &optional (level 0)) - #!+sb-doc - "Defevent Name Description - 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." (let ((var-name (symbolicate "*" name "-EVENT-INFO*"))) `(eval-when (:compile-toplevel :load-toplevel :execute) (defvar ,var-name - (make-event-info :name ',name - :description ',description - :var ',var-name - :level ,level)) + (make-event-info :name ',name + :description ',description + :var ',var-name + :level ,level)) (setf (gethash ',name *event-info*) ,var-name) ',name))) +;;; the lowest level of event that will print a note when it occurs (declaim (type unsigned-byte *event-note-threshold*)) -(defvar *event-note-threshold* 1 - #!+sb-doc - "This variable is a non-negative integer specifying the lowest level of - event that will print a note when it occurs.") +(defvar *event-note-threshold* 1) -;;; Increment the counter and do any action. Mumble about the event if -;;; policy indicates. +;;; 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) - #!+sb-doc - "Event Name Node - Note that the event with the specified Name has happened. Node is evaluated - to determine the node to which the event happened." + ;; Increment the counter and do any action. Mumble about the event if + ;; policy indicates. `(%event ,(event-info-var (event-info-or-lose name)) ,node)) +;;; Print a listing of events and their counts, sorted by the count. +;;; Events that happened fewer than Min-Count times will not be +;;; printed. Stream is the stream to write to. (declaim (ftype (function (&optional unsigned-byte stream) (values)) event-statistics)) (defun event-statistics (&optional (min-count 1) (stream *standard-output*)) - #!+sb-doc - "Print a listing of events and their counts, sorted by the count. Events - that happened fewer than Min-Count times will not be printed. Stream is the - stream to write to." (collect ((info)) - (maphash #'(lambda (k v) - (declare (ignore k)) - (when (>= (event-info-count v) min-count) - (info v))) - *event-info*) + (maphash (lambda (k v) + (declare (ignore k)) + (when (>= (event-info-count v) min-count) + (info v))) + *event-info*) (dolist (event (sort (info) #'> :key #'event-info-count)) (format stream "~6D: ~A~%" (event-info-count event) - (event-info-description event))) + (event-info-description event))) (values)) (values)) (declaim (ftype (function nil (values)) clear-event-statistics)) (defun clear-event-statistics () - (maphash #'(lambda (k v) - (declare (ignore k)) - (setf (event-info-count v) 0)) - *event-info*) + (maphash (lambda (k v) + (declare (ignore k)) + (setf (event-info-count v) 0)) + *event-info*) (values)) ;;;; 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 +;;; sequence functions. (defun find-in (next - element - list - &key - (key #'identity) - (test #'eql test-p) - (test-not nil not-p)) - #!+sb-doc - "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." + element + list + &key + (key #'identity) + (test #'eql test-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 (do ((current list (funcall next current))) - ((null current) nil) - (unless (funcall test-not (funcall key current) element) - (return current))) + ((null current) nil) + (unless (funcall test-not (funcall key current) element) + (return current))) (do ((current list (funcall next current))) - ((null current) nil) - (when (funcall test (funcall key current) element) - (return current))))) + ((null current) nil) + (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. (defun position-in (next - element - list - &key - (key #'identity) - (test #'eql test-p) - (test-not nil not-p)) - #!+sb-doc - "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." + element + list + &key + (key #'identity) + (test #'eql test-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 (do ((current list (funcall next current)) - (i 0 (1+ i))) - ((null current) nil) - (unless (funcall test-not (funcall key current) element) - (return i))) + (i 0 (1+ i))) + ((null current) nil) + (unless (funcall test-not (funcall key current) element) + (return i))) (do ((current list (funcall next current)) - (i 0 (1+ i))) - ((null current) nil) - (when (funcall test (funcall key current) element) - (return i))))) + (i 0 (1+ i))) + ((null current) nil) + (when (funcall test (funcall key current) element) + (return i))))) -(defun map-in (next function list) - #!+sb-doc - "Map Function over the elements in a null-terminated List linked by the - accessor function Next, returning a list of the results." - (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 ..) @@ -1073,24 +929,27 @@ (when (cdr stores) (error "multiple store variables for ~S" place)) (let ((n-item (gensym)) - (n-place (gensym)) - (n-current (gensym)) - (n-prev (gensym))) + (n-place (gensym)) + (n-current (gensym)) + (n-prev (gensym))) `(let* (,@(mapcar #'list temps vals) - (,n-place ,access) - (,n-item ,item)) - (if (eq ,n-place ,n-item) - (let ((,(first stores) (,next ,n-place))) - ,store) - (do ((,n-prev ,n-place ,n-current) - (,n-current (,next ,n-place) - (,next ,n-current))) - ((eq ,n-current ,n-item) - (setf (,next ,n-prev) - (,next ,n-current))))) - (values))))) + (,n-place ,access) + (,n-item ,item)) + (if (eq ,n-place ,n-item) + (let ((,(first stores) (,next ,n-place))) + ,store) + (do ((,n-prev ,n-place ,n-current) + (,n-current (,next ,n-place) + (,next ,n-current))) + ((eq ,n-current ,n-item) + (setf (,next ,n-prev) + (,next ,n-current))))) + (values))))) ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806 +;;; Push ITEM onto a list linked by the accessor function NEXT that is +;;; stored in PLACE. +;;; ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a ;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..) ;;; #+SB-XC-HOST @@ -1103,15 +962,12 @@ ;;; system isn't running yet, so it'd be too hard to check that my changes were ;;; correct -- WHN 19990806 (def!macro push-in (next item place &environment env) - #!+sb-doc - "Push Item onto a list linked by the accessor function Next that is stored in - Place." (multiple-value-bind (temps vals stores store access) (get-setf-expansion place env) (when (cdr stores) (error "multiple store variables for ~S" place)) `(let (,@(mapcar #'list temps vals) - (,(first stores) ,item)) + (,(first stores) ,item)) (setf (,next ,(first stores)) ,access) ,store (values)))) @@ -1119,4 +975,46 @@ (defmacro position-or-lose (&rest args) `(or (position ,@args) - (error "Shouldn't happen?"))) + (error "shouldn't happen?"))) + +;;; user-definable compiler io syntax + +;;; We use WITH-SANE-IO-SYNTAX to provide safe defaults, and provide +;;; *COMPILER-PRINT-VARIABLE-ALIST* for user customization. +(defvar *compiler-print-variable-alist* nil + #!+sb-doc + "an association list describing new bindings for special variables +to be used by the compiler for error-reporting, etc. Eg. + + ((*PRINT-LENGTH* . 10) (*PRINT-LEVEL* . 6) (*PRINT-PRETTY* . NIL)) + +The variables in the CAR positions are bound to the values in the CDR +during the execution of some debug commands. When evaluating arbitrary +expressions in the debugger, the normal values of the printer control +variables are in effect. + +Initially empty, *COMPILER-PRINT-VARIABLE-ALIST* is Typically used to +specify bindings for printer control variables.") + +(defmacro with-compiler-io-syntax (&body forms) + `(with-sane-io-syntax + (progv + (nreverse (mapcar #'car *compiler-print-variable-alist*)) + (nreverse (mapcar #'cdr *compiler-print-variable-alist*)) + ,@forms))) + +;;; Like DESTRUCTURING-BIND, but generates a COMPILER-ERROR on failure +(defmacro compiler-destructuring-bind (lambda-list thing context + &body body) + (let ((whole-name (gensym "WHOLE"))) + (multiple-value-bind (body local-decls) + (parse-defmacro lambda-list whole-name body nil + context + :anonymousp t + :doc-string-allowed nil + :wrap-block nil + :error-fun 'compiler-error) + `(let ((,whole-name ,thing)) + (declare (type list ,whole-name)) + ,@local-decls + ,body))))