X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=5f3706625c114a1be6ce853ab1c7d1e3a2154882;hb=dc4be57ff0baeee18d43fbee1bfc1af4af50e522;hp=340a7397ac9c72f623bbf63309a714d77f9ffeb7;hpb=8c1cdfc03a0070295e595e8b0ba97214ccb50a41;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 340a739..5f37066 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -66,7 +66,6 @@ (unless (info :function :kind name) (setf (info :function :kind name) :function) (setf (info :function :where-from name) :assumed)) - (let ((where (info :function :where-from name))) (when (and (eq where :assumed) ;; In the ordinary target Lisp, it's silly to report @@ -388,12 +387,12 @@ (component (make-empty-component)) (*current-component* component) (*allow-instrumenting* t)) - (setf (component-name component) "initial component") + (setf (component-name component) 'initial-component) (setf (component-kind component) :initial) (let* ((forms (if for-value `(,form) `(,form nil))) (res (ir1-convert-lambda-body forms () - :debug-name (debug-namify "top level form " form)))) + :debug-name (debug-name 'top-level-form form)))) (setf (functional-entry-fun res) res (functional-arg-documentation res) () (functional-kind res) :toplevel) @@ -516,11 +515,11 @@ form (ir1-convert-lambda opname - :debug-name (debug-namify - "LAMBDA CAR " + :debug-name (debug-name + 'lambda-car opname)))))))))) (values)) - + ;; Generate a reference to a manifest constant, creating a new leaf ;; if necessary. If we are producing a fasl file, make sure that ;; MAKE-LOAD-FORM gets used on any parts of the constant that it @@ -576,7 +575,14 @@ :notinline)) (let ((functional (defined-fun-functional leaf))) (when (and functional - (not (functional-kind functional))) + (not (functional-kind functional)) + ;; Bug MISC.320: ir1-transform + ;; can create a reference to a + ;; inline-expanded function, + ;; defined in another component. + (not (and (lambda-p functional) + (neq (lambda-component functional) + *current-component*)))) (maybe-reanalyze-functional functional)))) (when (and (lambda-p leaf) (memq (functional-kind leaf) @@ -981,11 +987,9 @@ (collect ((res nil cons)) (dolist (name names) (when (fboundp name) - (compiler-assert-symbol-home-package-unlocked name - "declaring the ftype of ~A")) - (let ((found (find name fvars - :key #'leaf-source-name - :test #'equal))) + (compiler-assert-symbol-home-package-unlocked + name "declaring the ftype of ~A")) + (let ((found (find name fvars :key #'leaf-source-name :test #'equal))) (cond (found (setf (leaf-type found) type) @@ -1032,17 +1036,20 @@ res))) ;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP -;;; (and TYPE if notinline). -(defun make-new-inlinep (var inlinep) +;;; (and TYPE if notinline), plus type-restrictions from the lexenv. +(defun make-new-inlinep (var inlinep local-type) (declare (type global-var var) (type inlinep inlinep)) - (let ((res (make-defined-fun - :%source-name (leaf-source-name var) - :where-from (leaf-where-from var) - :type (if (and (eq inlinep :notinline) - (not (eq (leaf-where-from var) :declared))) - (specifier-type 'function) - (leaf-type var)) - :inlinep inlinep))) + (let* ((type (if (and (eq inlinep :notinline) + (not (eq (leaf-where-from var) :declared))) + (specifier-type 'function) + (leaf-type var))) + (res (make-defined-fun + :%source-name (leaf-source-name var) + :where-from (leaf-where-from var) + :type (if local-type + (type-intersection local-type type) + type) + :inlinep inlinep))) (when (defined-fun-p var) (setf (defined-fun-inline-expansion res) (defined-fun-inline-expansion var)) @@ -1056,14 +1063,11 @@ (let ((sense (cdr (assoc (first spec) *inlinep-translations* :test #'eq))) (new-fenv ())) (dolist (name (rest spec)) - (let ((fvar (find name fvars - :key #'leaf-source-name - :test #'equal))) + (let ((fvar (find name fvars :key #'leaf-source-name :test #'equal))) (if fvar (setf (functional-inlinep fvar) sense) - (let ((found - (find-lexically-apparent-fun - name "in an inline or notinline declaration"))) + (let ((found (find-lexically-apparent-fun + name "in an inline or notinline declaration"))) (etypecase found (functional (when (policy *lexenv* (>= speed inhibit-warnings)) @@ -1071,9 +1075,10 @@ definition of local function:~% ~S" sense name))) (global-var - (push (cons name (make-new-inlinep found sense)) - new-fenv))))))) - + (let ((type + (cdr (assoc found (lexenv-type-restrictions res))))) + (push (cons name (make-new-inlinep found sense type)) + new-fenv)))))))) (if new-fenv (make-lexenv :default res :funs new-fenv) res))) @@ -1118,7 +1123,7 @@ (setf (lambda-var-ignorep var) t))))) (values)) -(defun process-dx-decl (names vars) +(defun process-dx-decl (names vars fvars) (flet ((maybe-notify (control &rest args) (when (policy *lexenv* (> speed inhibit-warnings)) (apply #'compiler-notify control args)))) @@ -1146,7 +1151,24 @@ (eq (car name) 'function) (null (cddr name)) (valid-function-name-p (cadr name))) - (maybe-notify "ignoring DYNAMIC-EXTENT declaration for ~S" 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 ~ + (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)))) @@ -1202,12 +1224,12 @@ `(values ,@types))))) res)) (dynamic-extent - (process-dx-decl (cdr spec) vars) + (process-dx-decl (cdr spec) vars fvars) res) ((disable-package-locks enable-package-locks) (make-lexenv :default res - :disabled-package-locks (process-package-lock-decl + :disabled-package-locks (process-package-lock-decl spec (lexenv-disabled-package-locks res)))) (t (unless (info :declaration :recognized (first spec))