X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=d347beaeba625ff1edb83e9674a03451f7638a99;hb=6bd6f66558995e0c4b353525255f8a85f25c54aa;hp=3b8f1afddccdd5baa8018cfcd53936ddf89cb992;hpb=5d4cadcc92642f2a23743a5458a23aa9dc544db2;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 3b8f1af..d347bea 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -205,14 +205,16 @@ (inlinep (info :function :inlinep name))) (setf (gethash name *free-funs*) (if (or expansion inlinep) - (make-defined-fun - :%source-name name - :inline-expansion expansion - :inlinep inlinep - :where-from (info :function :where-from name) - :type (if (eq inlinep :notinline) - (specifier-type 'function) - (info :function :type name))) + (let ((where (info :function :where-from name))) + (make-defined-fun + :%source-name name + :inline-expansion expansion + :inlinep inlinep + :where-from where + :type (if (and (eq inlinep :notinline) + (neq where :declared)) + (specifier-type 'function) + (info :function :type name)))) (find-global-fun name nil)))))))) ;;; Return the LEAF structure for the lexically apparent function @@ -228,6 +230,9 @@ (t (find-free-fun name context))))) +(defun maybe-find-free-var (name) + (gethash name *free-vars*)) + ;;; Return the LEAF node for a global variable reference to NAME. If ;;; NAME is already entered in *FREE-VARS*, then we just return the ;;; corresponding value. Otherwise, we make a new leaf using @@ -484,16 +489,19 @@ (trail form)) (declare (fixnum pos)) (macrolet ((frob () - '(progn + `(progn (when (atom subform) (return)) (let ((fm (car subform))) - (if (consp fm) - ;; If it's a cons, recurse - (sub-find-source-paths fm (cons pos path)) - ;; Otherwise store the containing form. It's - ;; not perfect, but better than nothing. - (unless (zerop pos) - (note-source-path subform pos path))) + (cond ((consp fm) + ;; If it's a cons, recurse. + (sub-find-source-paths fm (cons pos path))) + ((eq 'quote fm) + ;; Don't look into quoted constants. + (return)) + ((not (zerop pos)) + ;; Otherwise store the containing form. It's not + ;; perfect, but better than nothing. + (note-source-path subform pos path))) (incf pos)) (setq subform (cdr subform)) (when (eq subform trail) (return))))) @@ -591,22 +599,13 @@ ;;; functional instead. (defun reference-leaf (start next result leaf &optional (name '.anonymous.)) (declare (type ctran start next) (type (or lvar null) result) (type leaf leaf)) - (when (functional-p leaf) - (assure-functional-live-p leaf)) + (assure-leaf-live-p leaf) (let* ((type (lexenv-find leaf type-restrictions)) (leaf (or (and (defined-fun-p leaf) (not (eq (defined-fun-inlinep leaf) :notinline)) (let ((functional (defined-fun-functional leaf))) - (when (and 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*)))) + (when (and functional (not (functional-kind functional))) (maybe-reanalyze-functional functional)))) (when (and (lambda-p leaf) (memq (functional-kind leaf) @@ -708,10 +707,13 @@ ;; CLHS 3.2.2.1.3 specifies that NOTINLINE ;; suppresses compiler-macros. (not (fun-lexically-notinline-p cmacro-fun-name))) - (let ((res (careful-expand-macro cmacro-fun form))) - (if (eq res form) - (ir1-convert-common-functoid start next result form op) - (ir1-convert start next result res))) + (let ((res (careful-expand-macro cmacro-fun form t))) + (cond ((eq res form) + (ir1-convert-common-functoid start next result form op)) + (t + (unless (policy *lexenv* (zerop store-xref-data)) + (record-call cmacro-fun-name (ctran-block start) *current-path*)) + (ir1-convert start next result res)))) (ir1-convert-common-functoid start next result form op))))))) ;;; Handles the "common" cases: any other forms except special forms @@ -766,7 +768,7 @@ ;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping ;;; errors which occur during the macroexpansion. -(defun careful-expand-macro (fun form) +(defun careful-expand-macro (fun form &optional cmacro) (let (;; a hint I (WHN) wish I'd known earlier (hint "(hint: For more precise location, try *BREAK-ON-SIGNALS*.)")) (flet (;; Return a string to use as a prefix in error reporting, @@ -778,10 +780,11 @@ (*print-level* 3)) (format nil - #-sb-xc-host "(in macroexpansion of ~S)" + #-sb-xc-host "(in ~A of ~S)" ;; longer message to avoid ambiguity "Was it the xc host ;; or the cross-compiler which encountered the problem?" - #+sb-xc-host "(in cross-compiler macroexpansion of ~S)" + #+sb-xc-host "(in cross-compiler ~A of ~S)" + (if cmacro "compiler-macroexpansion" "macroexpansion") form)))) (handler-bind ((style-warning (lambda (c) (compiler-style-warn @@ -1018,14 +1021,16 @@ (defined-fun-inlinep var)))) (if (eq inlinep :notinline) (ir1-convert-combination start next result form var) - (let ((transform (info :function - :source-transform - (leaf-source-name var)))) + (let* ((name (leaf-source-name var)) + (transform (info :function :source-transform name))) (if transform (multiple-value-bind (transformed pass) (funcall transform form) - (if pass - (ir1-convert-maybe-predicate start next result form var) - (ir1-convert start next result transformed))) + (cond (pass + (ir1-convert-maybe-predicate start next result form var)) + (t + (unless (policy *lexenv* (zerop store-xref-data)) + (record-call name (ctran-block start) *current-path*)) + (ir1-convert start next result transformed)))) (ir1-convert-maybe-predicate start next result form var)))))) ;;; KLUDGE: If we insert a synthetic IF for a function with the PREDICATE @@ -1346,58 +1351,62 @@ (values)) (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)))) - (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))))) + (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) + (maybe-find-free-var name)))) + (etypecase var + (leaf + (if bound-var + (setf (leaf-dynamic-extent var) dx) + (compiler-notify + "Ignoring free DYNAMIC-EXTENT declaration: ~S" name))) + (cons + (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name)) + (heap-alien-info + (compiler-error "DYNAMIC-EXTENT on alien-variable: ~S" + name)) + (null + (compiler-style-warn + "Unbound variable declared DYNAMIC-EXTENT: ~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)) + (fun (or bound-fun (lexenv-find fname funs)))) + (etypecase fun + (leaf + (if bound-fun + #!+stack-allocatable-closures + (setf (leaf-dynamic-extent bound-fun) dx) + #!-stack-allocatable-closures + (compiler-notify + "Ignoring DYNAMIC-EXTENT declaration on function ~S ~ + (not supported on this platform)." fname) + (compiler-notify + "Ignoring free DYNAMIC-EXTENT declaration: ~S" name))) + (cons + (compiler-error "DYNAMIC-EXTENT on macro: ~S" name)) + (null + (compiler-style-warn + "Unbound function declared DYNAMIC-EXTENT: ~S" name))))) + (t + (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name)))) + (when (policy *lexenv* (= speed 3)) + (compiler-notify "Ignoring DYNAMIC-EXTENT declarations: ~S" names))))) ;;; FIXME: This is non-ANSI, so the default should be T, or it should ;;; go away, I think.