X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=a583be1829f0a438c06027791ff80a477c2b7b21;hb=ec066d84dd46611428943d152749b3891a3f4b7c;hp=4b9543b9a0dc4cd239aa97b91ed75c3e863b78ec;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 4b9543b..a583be1 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -303,20 +303,17 @@ ;;;; some flow-graph hacking utilities ;;; This function sets up the back link between the node and the -;;; continuation which continues at it. +;;; ctran which continues at it. (defun link-node-to-previous-ctran (node ctran) (declare (type node node) (type ctran ctran)) (aver (not (ctran-next ctran))) (setf (ctran-next ctran) node) (setf (node-prev node) ctran)) -;;; This function is used to set the continuation for a node, and thus -;;; determine what receives the value and what is evaluated next. If -;;; the continuation has no block, then we make it be in the block -;;; that the node is in. If the continuation heads its block, we end -;;; our block and link it to that block. If the continuation is not -;;; currently used, then we set the DERIVED-TYPE for the continuation -;;; to that of the node, so that a little type propagation gets done. +;;; This function is used to set the ctran for a node, and thus +;;; determine what is evaluated next. If the ctran has no block, then +;;; we make it be in the block that the node is in. If the ctran heads +;;; its block, we end our block and link it to that block. #!-sb-fluid (declaim (inline use-ctran)) (defun use-ctran (node ctran) (declare (type node node) (type ctran ctran)) @@ -340,9 +337,10 @@ (setf (block-succ node-block) (list block)) (when (memq node-block (block-pred block)) (error "~S is already a predecessor of ~S." node-block block)) - (push node-block (block-pred block)) - #+nil(reoptimize-ctran ctran))) ; XXX + (push node-block (block-pred block)))) +;;; This function is used to set the ctran for a node, and thus +;;; determine what receives the value. (defun use-lvar (node lvar) (declare (type valued-node node) (type (or lvar null) lvar)) (aver (not (node-lvar node))) @@ -621,7 +619,12 @@ (when (lambda-var-ignorep var) ;; (ANSI's specification for the IGNORE declaration requires ;; that this be a STYLE-WARNING, not a full WARNING.) - (compiler-style-warn "reading an ignored variable: ~S" name))) + #-sb-xc-host + (compiler-style-warn "reading an ignored variable: ~S" name) + ;; there's no need for us to accept ANSI's lameness when + ;; processing our own code, though. + #+sb-xc-host + (compiler-warn "reading an ignored variable: ~S" name))) (reference-leaf start next result var)) (cons (aver (eq (car var) 'MACRO)) @@ -778,24 +781,24 @@ (declaim (ftype (sfunction (ctran ctran (or lvar null) list leaf) combination) ir1-convert-combination)) (defun ir1-convert-combination (start next result form fun) - (let ((fun-ctran (make-ctran)) + (let ((ctran (make-ctran)) (fun-lvar (make-lvar))) - (ir1-convert start fun-ctran fun-lvar `(the (or function symbol) ,fun)) - (ir1-convert-combination-args fun-ctran fun-lvar next result (cdr form)))) + (ir1-convert start ctran fun-lvar `(the (or function symbol) ,fun)) + (ir1-convert-combination-args fun-lvar ctran next result (cdr form)))) ;;; Convert the arguments to a call and make the COMBINATION -;;; node. FUN-CONT is the continuation which yields the function to -;;; call. ARGS is the list of arguments for the call, which defaults -;;; to the cdr of source. We return the COMBINATION node. -(defun ir1-convert-combination-args (fun-ctran fun-lvar next result args) - (declare (type ctran fun-ctran next) +;;; node. FUN-LVAR yields the function to call. ARGS is the list of +;;; arguments for the call, which defaults to the cdr of source. We +;;; return the COMBINATION node. +(defun ir1-convert-combination-args (fun-lvar start next result args) + (declare (type ctran start next) (type lvar fun-lvar) (type (or lvar null) result) (list args)) (let ((node (make-combination fun-lvar))) (setf (lvar-dest fun-lvar) node) (collect ((arg-lvars)) - (let ((this-start fun-ctran)) + (let ((this-start start)) (dolist (arg args) (let ((this-ctran (make-ctran)) (this-lvar (make-lvar node))) @@ -829,7 +832,7 @@ (ir1-convert start next result transformed))) (ir1-convert-maybe-predicate start next result form var)))))) -;;; If the function has the PREDICATE attribute, and the CONT's DEST +;;; If the function has the PREDICATE attribute, and the RESULT's DEST ;;; isn't an IF, then we convert (IF
T NIL), ensuring that a ;;; predicate always appears in a conditional context. ;;; @@ -858,9 +861,9 @@ ;;; call is legal. ;;; ;;; If the call is legal, we also propagate type assertions from the -;;; function type to the arg and result continuations. We do this now -;;; so that IR1 optimize doesn't have to redundantly do the check -;;; later so that it can do the type propagation. +;;; function type to the arg and result lvars. We do this now so that +;;; IR1 optimize doesn't have to redundantly do the check later so +;;; that it can do the type propagation. (defun ir1-convert-combination-checking-type (start next result form var) (declare (type ctran start next) (type (or lvar null) result) (list form) @@ -1106,6 +1109,38 @@ (setf (lambda-var-ignorep var) t))))) (values)) +(defun process-dx-decl (names vars) + (flet ((maybe-notify (control &rest args) + (when (policy *lexenv* (> speed inhibit-warnings)) + (apply #'compiler-notify control args)))) + (if (policy *lexenv* (= stack-allocate-dynamic-extent 3)) + (dolist (name names) + (cond + ((symbolp name) + (let* ((bound-var (find-in-bindings vars name)) + (var (or bound-var + (lexenv-find name vars) + (find-free-var name)))) + (etypecase var + (leaf + (if bound-var + (setf (leaf-dynamic-extent var) t) + (maybe-notify + "ignoring DYNAMIC-EXTENT declaration for free ~S" + name))) + (cons + (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name)) + (heap-alien-info + (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S" + name))))) + ((and (consp name) + (eq (car name) 'function) + (null (cddr name)) + (valid-function-name-p (cadr name))) + (maybe-notify "ignoring DYNAMIC-EXTENT declaration for ~S" name)) + (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name)))) + (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names)))) + ;;; FIXME: This is non-ANSI, so the default should be T, or it should ;;; go away, I think. (defvar *suppress-values-declaration* nil @@ -1148,10 +1183,7 @@ `(values ,@types))))) res)) (dynamic-extent - (when (policy *lexenv* (> speed inhibit-warnings)) - (compiler-notify - "compiler limitation: ~ - ~% There's no special support for DYNAMIC-EXTENT (so it's ignored).")) + (process-dx-decl (cdr spec) vars) res) (t (unless (info :declaration :recognized (first spec))