X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=ca8904d89a4be647b5090ca13137c168e0e7668a;hb=2f492b2a39b1361e1dd97d5243bc47238b98ca8f;hp=91b7a697509299a0044f22fb350aaebccf5c17dc;hpb=eded4f764cd9736b34a60d4a53b24cef1e9b203e;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 91b7a69..ca8904d 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -87,6 +87,12 @@ (eq (defined-fun-inlinep fun) :notinline) (eq (info :function :inlinep name) :notinline)))) +;; This will get redefined in PCL boot. +(declaim (notinline update-info-for-gf)) +(defun maybe-update-info-for-gf (name) + (declare (ignorable name)) + (values)) + ;;; Return a GLOBAL-VAR structure usable for referencing the global ;;; function NAME. (defun find-global-fun (name latep) @@ -110,14 +116,20 @@ (make-global-var :kind :global-function :%source-name name - :type (if (and (not latep) - (or *derive-function-types* - (eq where :declared) - (and (member name *fun-names-in-this-file* - :test #'equal) - (not (fun-lexically-notinline-p name))))) - (info :function :type name) + :type (if (or (eq where :declared) + (and (not latep) + (or *derive-function-types* + (eq where :defined-method) + (and (not (fun-lexically-notinline-p name)) + (member name *fun-names-in-this-file* + :test #'equal))))) + (progn + (maybe-update-info-for-gf name) + (info :function :type name)) (specifier-type 'function)) + :defined-type (if (eq where :defined) + (info :function :type name) + *universal-type*) :where-from where))) ;;; Has the *FREE-FUNS* entry FREE-FUN become invalid? @@ -241,7 +253,20 @@ (type (type-specifier (info :variable :type name)))) `(macro . (the ,type ,expansion)))) (:constant - (find-constant (symbol-value name) name)) + (let ((value (symbol-value name))) + ;; Override the values of standard symbols in XC, + ;; since we can't redefine them. + #+sb-xc-host + (when (eql (find-symbol (symbol-name name) :cl) name) + (multiple-value-bind (xc-value foundp) + (info :variable :xc-constant-value name) + (cond (foundp + (setf value xc-value)) + ((not (eq value name)) + (compiler-warn + "Using cross-compilation host's definition of ~S: ~A~%" + name (symbol-value name)))))) + (find-constant value name))) (t (make-global-var :kind kind :%source-name name @@ -359,6 +384,17 @@ (error "~S is already a predecessor of ~S." node-block block)) (push node-block (block-pred block)))) +;;; Insert NEW before OLD in the flow-graph. +(defun insert-node-before (old new) + (let ((prev (node-prev old)) + (temp (make-ctran))) + (ensure-block-start prev) + (setf (ctran-next prev) nil) + (link-node-to-previous-ctran new prev) + (use-ctran new temp) + (link-node-to-previous-ctran old temp)) + (values)) + ;;; This function is used to set the ctran for a node, and thus ;;; determine what receives the value. (defun use-lvar (node lvar) @@ -1029,8 +1065,9 @@ (type leaf var)) (let* ((node (ir1-convert-combination start next result form var)) (fun-lvar (basic-combination-fun node)) - (type (leaf-type var))) - (when (validate-call-type node type t) + (type (leaf-type var)) + (defined-type (leaf-defined-type var))) + (when (validate-call-type node type defined-type t) (setf (lvar-%derived-type fun-lvar) (make-single-value-type type)) (setf (lvar-reoptimize fun-lvar) nil))) @@ -1110,7 +1147,9 @@ (type-specifier old-type) (type-specifier type) var-name)))) - (bound-var (setf (leaf-type bound-var) int)) + (bound-var + (setf (leaf-type bound-var) int + (leaf-where-from bound-var) :declared)) (t (restr (cons var int))))))) (process-var var bound-var) @@ -1290,54 +1329,59 @@ (setf (lambda-var-ignorep var) t))))) (values)) -(defun process-dx-decl (names vars fvars) +(defun process-dx-decl (names vars fvars kind) (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))) - (let* ((fname (cadr name)) - (bound-fun (find fname fvars - :key #'leaf-source-name - :test #'equal))) - (etypecase bound-fun - (leaf - #!+stack-allocatable-closures - (setf (leaf-dynamic-extent bound-fun) t) - #!-stack-allocatable-closures - (maybe-notify - "ignoring DYNAMIC-EXTENT declaration on a function ~S ~ + (let ((dx (cond ((eq 'truly-dynamic-extent kind) + :truly) + ((and (eq 'dynamic-extent kind) + *stack-allocate-dynamic-extent*) + t)))) + (if dx + (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) dx) + (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))) + (let* ((fname (cadr name)) + (bound-fun (find fname fvars + :key #'leaf-source-name + :test #'equal))) + (etypecase bound-fun + (leaf + #!+stack-allocatable-closures + (setf (leaf-dynamic-extent bound-fun) dx) + #!-stack-allocatable-closures + (maybe-notify + "ignoring DYNAMIC-EXTENT declaration on a function ~S ~ (not supported on this platform)." fname)) - (cons - (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname)) - (null - (maybe-notify - "ignoring DYNAMIC-EXTENT declaration for free ~S" - fname))))) - (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name)))) - (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names)))) + (cons + (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname)) + (null + (maybe-notify + "ignoring DYNAMIC-EXTENT declaration for free ~S" + fname))))) + (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. @@ -1390,8 +1434,8 @@ (car types) `(values ,@types))))) res)) - (dynamic-extent - (process-dx-decl (cdr spec) vars fvars) + ((dynamic-extent truly-dynamic-extent) + (process-dx-decl (cdr spec) vars fvars (first spec)) res) ((disable-package-locks enable-package-locks) (make-lexenv