X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=e566c371a77c0d3cb3261d05c38d1de3319c24a7;hb=08d05510b51708853ca998154d8096b21d85edab;hp=68cac62ab4c60c87726d557eb7e2d20c9e4f55b8;hpb=4e0ff6bb79908436adea8375d4eea46d10079cec;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 68cac62..e566c37 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -14,15 +14,40 @@ (declaim (special *compiler-error-bailout*)) +;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the +;;; form number to associate with a source path. This should be bound +;;; to an initial value of 0 before the processing of each truly +;;; top level form. +(declaim (type index *current-form-number*)) +(defvar *current-form-number*) + ;;; *SOURCE-PATHS* is a hashtable from source code forms to the path ;;; taken through the source to reach the form. This provides a way to ;;; keep track of the location of original source forms, even when ;;; macroexpansions and other arbitary permutations of the code ;;; happen. This table is initialized by calling FIND-SOURCE-PATHS on ;;; the original source. +;;; +;;; It is fairly useless to store symbols, characters, or fixnums in +;;; this table, as 42 is EQ to 42 no matter where in the source it +;;; appears. GET-SOURCE-PATH and NOTE-SOURCE-PATH functions should be +;;; always used to access this table. (declaim (hash-table *source-paths*)) (defvar *source-paths*) +(declaim (inline source-form-has-path-p)) +(defun source-form-has-path-p (form) + (not (typep form '(or symbol fixnum character)))) + +(defun get-source-path (form) + (when (source-form-has-path-p form) + (gethash form *source-paths*))) + +(defun note-source-path (form &rest arguments) + (when (source-form-has-path-p form) + (setf (gethash form *source-paths*) + (apply #'list* 'original-source-start *current-form-number* arguments)))) + ;;; *CURRENT-COMPONENT* is the COMPONENT structure which we link ;;; blocks into as we generate them. This just serves to glue the ;;; emitted blocks together until local call analysis and flow graph @@ -62,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) @@ -85,58 +116,67 @@ (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? -;;; -;;; In CMU CL, the answer was implicitly always true, so this -;;; predicate didn't exist. +;;; Have some DEFINED-FUN-FUNCTIONALS of a *FREE-FUNS* entry become invalid? +;;; Drop 'em. ;;; -;;; This predicate was added to fix bug 138 in SBCL. In some obscure -;;; circumstances, it was possible for a *FREE-FUNS* entry to contain a -;;; DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object contained IR1 -;;; stuff (NODEs, BLOCKs...) referring to an already compiled (aka -;;; "dead") component. When this IR1 stuff was reused in a new -;;; component, under further obscure circumstances it could be used by +;;; This was added to fix bug 138 in SBCL. It is possible for a *FREE-FUNS* +;;; entry to contain a DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object +;;; contained IR1 stuff (NODEs, BLOCKs...) referring to an already compiled +;;; (aka "dead") component. When this IR1 stuff was reused in a new component, +;;; under further obscure circumstances it could be used by ;;; WITH-IR1-ENVIRONMENT-FROM-NODE to generate a binding for -;;; *CURRENT-COMPONENT*. At that point things got all confused, since -;;; IR1 conversion was sending code to a component which had already -;;; been compiled and would never be compiled again. -(defun invalid-free-fun-p (free-fun) +;;; *CURRENT-COMPONENT*. At that point things got all confused, since IR1 +;;; conversion was sending code to a component which had already been compiled +;;; and would never be compiled again. +;;; +;;; Note: as of 1.0.24.41 this seems to happen only in XC, and the original +;;; BUGS entry also makes it seem like this might not be an issue at all on +;;; target. +(defun clear-invalid-functionals (free-fun) ;; There might be other reasons that *FREE-FUN* entries could ;; become invalid, but the only one we've been bitten by so far ;; (sbcl-0.pre7.118) is this one: - (and (defined-fun-p free-fun) - (let ((functional (defined-fun-functional free-fun))) - (or (and functional - (eql (functional-kind functional) :deleted)) - (and (lambda-p functional) - (or - ;; (The main reason for this first test is to bail - ;; out early in cases where the LAMBDA-COMPONENT - ;; call in the second test would fail because links - ;; it needs are uninitialized or invalid.) - ;; - ;; If the BIND node for this LAMBDA is null, then - ;; according to the slot comments, the LAMBDA has - ;; been deleted or its call has been deleted. In - ;; that case, it seems rather questionable to reuse - ;; it, and certainly it shouldn't be necessary to - ;; reuse it, so we cheerfully declare it invalid. - (null (lambda-bind functional)) - ;; If this IR1 stuff belongs to a dead component, - ;; then we can't reuse it without getting into - ;; bizarre confusion. - (eql (component-info (lambda-component functional)) - :dead))))))) + (when (defined-fun-p free-fun) + (setf (defined-fun-functionals free-fun) + (delete-if (lambda (functional) + (or (eq (functional-kind functional) :deleted) + (when (lambda-p functional) + (or + ;; (The main reason for this first test is to bail + ;; out early in cases where the LAMBDA-COMPONENT + ;; call in the second test would fail because links + ;; it needs are uninitialized or invalid.) + ;; + ;; If the BIND node for this LAMBDA is null, then + ;; according to the slot comments, the LAMBDA has + ;; been deleted or its call has been deleted. In + ;; that case, it seems rather questionable to reuse + ;; it, and certainly it shouldn't be necessary to + ;; reuse it, so we cheerfully declare it invalid. + (not (lambda-bind functional)) + ;; If this IR1 stuff belongs to a dead component, + ;; then we can't reuse it without getting into + ;; bizarre confusion. + (eq (component-info (lambda-component functional)) + :dead))))) + (defined-fun-functionals free-fun))) + nil)) ;;; If NAME already has a valid entry in *FREE-FUNS*, then return ;;; the value. Otherwise, make a new GLOBAL-VAR using information from @@ -147,8 +187,9 @@ (declaim (ftype (sfunction (t string) global-var) find-free-fun)) (defun find-free-fun (name context) (or (let ((old-free-fun (gethash name *free-funs*))) - (and (not (invalid-free-fun-p old-free-fun)) - old-free-fun)) + (when old-free-fun + (clear-invalid-functionals old-free-fun) + old-free-fun)) (ecase (info :function :kind name) ;; FIXME: The :MACRO and :SPECIAL-FORM cases could be merged. (:macro @@ -216,11 +257,20 @@ (type (type-specifier (info :variable :type name)))) `(macro . (the ,type ,expansion)))) (:constant - (let ((value (info :variable :constant-value name))) - (make-constant :value value - :%source-name name - :type (ctype-of value) - :where-from where-from))) + (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 @@ -231,43 +281,24 @@ ;;; processed with MAKE-LOAD-FORM. We have to be careful, because ;;; CONSTANT might be circular. We also check that the constant (and ;;; any subparts) are dumpable at all. -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD) - ;; below. -- AL 20010227 - (def!constant list-to-hash-table-threshold 32)) -(defun maybe-emit-make-load-forms (constant) - (let ((things-processed nil) - (count 0)) - ;; FIXME: Does this LIST-or-HASH-TABLE messiness give much benefit? - (declare (type (or list hash-table) things-processed) - (type (integer 0 #.(1+ list-to-hash-table-threshold)) count) - (inline member)) - (labels ((grovel (value) +(defun maybe-emit-make-load-forms (constant &optional (name nil namep)) + (let ((xset (alloc-xset))) + (labels ((trivialp (value) + (typep value + '(or + #-sb-xc-host unboxed-array + #+sb-xc-host (simple-array (unsigned-byte 8) (*)) + symbol + number + character + string))) + (grovel (value) ;; Unless VALUE is an object which which obviously ;; can't contain other objects - (unless (typep value - '(or #-sb-xc-host unboxed-array - #+sb-xc-host (simple-array (unsigned-byte 8) (*)) - symbol - number - character - string)) - (etypecase things-processed - (list - (when (member value things-processed :test #'eq) - (return-from grovel nil)) - (push value things-processed) - (incf count) - (when (> count list-to-hash-table-threshold) - (let ((things things-processed)) - (setf things-processed - (make-hash-table :test 'eq)) - (dolist (thing things) - (setf (gethash thing things-processed) t))))) - (hash-table - (when (gethash value things-processed) - (return-from grovel nil)) - (setf (gethash value things-processed) t))) + (unless (trivialp value) + (if (xset-member-p value xset) + (return-from grovel nil) + (add-to-xset value xset)) (typecase value (cons (grovel (car value)) @@ -288,12 +319,15 @@ ((array t) (dotimes (i (array-total-size value)) (grovel (row-major-aref value i)))) - (;; In the target SBCL, we can dump any instance, - ;; but in the cross-compilation host, - ;; %INSTANCE-FOO functions don't work on general - ;; instances, only on STRUCTURE!OBJECTs. - #+sb-xc-host structure!object + (#+sb-xc-host structure!object #-sb-xc-host instance + ;; In the target SBCL, we can dump any instance, but + ;; in the cross-compilation host, %INSTANCE-FOO + ;; functions don't work on general instances, only on + ;; STRUCTURE!OBJECTs. + ;; + ;; FIXME: What about funcallable instances with + ;; user-defined MAKE-LOAD-FORM methods? (when (emit-make-load-form value) (dotimes (i (- (%instance-length value) #+sb-xc-host 0 @@ -304,7 +338,15 @@ (compiler-error "Objects of type ~S can't be dumped into fasl files." (type-of value))))))) - (grovel constant))) + ;; Dump all non-trivial named constants using the name. + (if (and namep (not (typep constant '(or symbol character + ;; FIXME: Cold init breaks if we + ;; try to reference FP constants + ;; thru their names. + #+sb-xc-host number + #-sb-xc-host fixnum)))) + (emit-make-load-form constant name) + (grovel constant)))) (values)) ;;;; some flow-graph hacking utilities @@ -346,6 +388,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) @@ -393,12 +446,12 @@ ;;; The hashtables used to hold global namespace info must be ;;; reallocated elsewhere. Note also that *LEXENV* is not bound, so ;;; that local macro definitions can be introduced by enclosing code. -(defun ir1-toplevel (form path for-value) +(defun ir1-toplevel (form path for-value &optional (allow-instrumenting t)) (declare (list path)) (let* ((*current-path* path) (component (make-empty-component)) (*current-component* component) - (*allow-instrumenting* t)) + (*allow-instrumenting* allow-instrumenting)) (setf (component-name component) 'initial-component) (setf (component-kind component) :initial) (let* ((forms (if for-value `(,form) `(,form nil))) @@ -410,13 +463,6 @@ (functional-kind res) :toplevel) res))) -;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the -;;; form number to associate with a source path. This should be bound -;;; to an initial value of 0 before the processing of each truly -;;; top level form. -(declaim (type index *current-form-number*)) -(defvar *current-form-number*) - ;;; This function is called on freshly read forms to record the ;;; initial location of each form (and subform.) Form is the form to ;;; find the paths in, and TLF-NUM is the top level form number of the @@ -430,9 +476,8 @@ (sub-find-source-paths form (list tlf-num))) (values)) (defun sub-find-source-paths (form path) - (unless (gethash form *source-paths*) - (setf (gethash form *source-paths*) - (list* 'original-source-start *current-form-number* path)) + (unless (get-source-path form) + (note-source-path form path) (incf *current-form-number*) (let ((pos 0) (subform form) @@ -442,8 +487,13 @@ '(progn (when (atom subform) (return)) (let ((fm (car subform))) - (when (consp fm) - (sub-find-source-paths fm (cons pos path))) + (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))) (incf pos)) (setq subform (cdr subform)) (when (eq subform trail) (return))))) @@ -470,7 +520,8 @@ ,@body (return-from ,skip nil))))) (ir1-convert ,start ,next ,result - (make-compiler-error-form ,condition ,form))))))) + (make-compiler-error-form ,condition + ,form))))))) ;; Translate FORM into IR1. The code is inserted as the NEXT of the ;; CTRAN START. RESULT is the LVAR which receives the value of the @@ -484,11 +535,10 @@ ;; namespace. (defun ir1-convert (start next result form) (ir1-error-bailout (start next result form) - (let ((*current-path* (or (gethash form *source-paths*) - (cons form *current-path*)))) - (cond ((step-form-p form) - (ir1-convert-step start next result form)) - ((atom form) + (let* ((*current-path* (or (get-source-path form) + (cons form *current-path*))) + (start (instrument-coverage start nil form))) + (cond ((atom form) (cond ((and (symbolp form) (not (keywordp form))) (ir1-convert-var start next result form)) ((leaf-p form) @@ -496,58 +546,20 @@ (t (reference-constant start next result form)))) (t - (let ((opname (car form))) - (cond ((or (symbolp opname) (leaf-p opname)) - (let ((lexical-def (if (leaf-p opname) - opname - (lexenv-find opname funs)))) - (typecase lexical-def - (null - (ir1-convert-global-functoid start next result - form)) - (functional - (ir1-convert-local-combination start next result - form - lexical-def)) - (global-var - (ir1-convert-srctran start next result - lexical-def form)) - (t - (aver (and (consp lexical-def) - (eq (car lexical-def) 'macro))) - (ir1-convert start next result - (careful-expand-macro (cdr lexical-def) - form)))))) - ((or (atom opname) (not (eq (car opname) 'lambda))) - (compiler-error "illegal function call")) - (t - ;; implicitly (LAMBDA ..) because the LAMBDA - ;; expression is the CAR of an executed form - (ir1-convert-combination start next result - form - (ir1-convert-lambda - opname - :debug-name (debug-name - 'lambda-car - opname)))))))))) + (ir1-convert-functoid start next result form))))) (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 - ;; needs to be. + ;; if necessary. (defun reference-constant (start next result value) (declare (type ctran start next) - (type (or lvar null) result) - (inline find-constant)) + (type (or lvar null) result)) (ir1-error-bailout (start next result value) - (when (producing-fasl-file) - (maybe-emit-make-load-forms value)) - (let* ((leaf (find-constant value)) - (res (make-ref leaf))) - (push res (leaf-refs leaf)) - (link-node-to-previous-ctran res start) - (use-continuation res next result))) + (let* ((leaf (find-constant value)) + (res (make-ref leaf))) + (push res (leaf-refs leaf)) + (link-node-to-previous-ctran res start) + (use-continuation res next result))) (values))) ;;; Add FUNCTIONAL to the COMPONENT-REANALYZE-FUNCTIONALS, unless it's @@ -577,7 +589,7 @@ ;;; needed. If LEAF represents a defined function which has already ;;; been converted, and is not :NOTINLINE, then reference the ;;; functional instead. -(defun reference-leaf (start next result leaf) +(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)) @@ -601,7 +613,7 @@ '(nil :optional))) (maybe-reanalyze-functional leaf)) leaf)) - (ref (make-ref leaf))) + (ref (make-ref leaf name))) (push ref (leaf-refs leaf)) (setf (leaf-ever-used leaf) t) (link-node-to-previous-ctran ref start) @@ -623,72 +635,124 @@ (defun ir1-convert-var (start next result name) (declare (type ctran start next) (type (or lvar null) result) (symbol name)) (let ((var (or (lexenv-find name vars) (find-free-var name)))) - (etypecase var - (leaf - (when (lambda-var-p var) - (let ((home (ctran-home-lambda-or-null start))) - (when home - (pushnew var (lambda-calls-or-closes home)))) - (when (lambda-var-ignorep var) - ;; (ANSI's specification for the IGNORE declaration requires - ;; that this be a STYLE-WARNING, not a full WARNING.) - #-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 - (warn "reading an ignored variable: ~S" name))) - (reference-leaf start next result var)) - (cons - (aver (eq (car var) 'macro)) - ;; FIXME: [Free] type declarations. -- APD, 2002-01-26 - (ir1-convert start next result (cdr var))) - (heap-alien-info - (ir1-convert start next result `(%heap-alien ',var))))) + (if (and (global-var-p var) (not result)) + ;; KLUDGE: If the reference is dead, convert using SYMBOL-VALUE + ;; which is not flushable, so that unbound dead variables signal + ;; an error (bug 412). + (ir1-convert start next result `(symbol-value ',name)) + (etypecase var + (leaf + (when (lambda-var-p var) + (let ((home (ctran-home-lambda-or-null start))) + (when home + (sset-adjoin var (lambda-calls-or-closes home)))) + (when (lambda-var-ignorep var) + ;; (ANSI's specification for the IGNORE declaration requires + ;; that this be a STYLE-WARNING, not a full WARNING.) + #-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 + (warn "reading an ignored variable: ~S" name))) + (reference-leaf start next result var name)) + (cons + (aver (eq (car var) 'macro)) + ;; FIXME: [Free] type declarations. -- APD, 2002-01-26 + (ir1-convert start next result (cdr var))) + (heap-alien-info + (ir1-convert start next result `(%heap-alien ',var)))))) (values)) -;;; Convert anything that looks like a special form, global function -;;; or compiler-macro call. -(defun ir1-convert-global-functoid (start next result form) - (declare (type ctran start next) (type (or lvar null) result) (list form)) - (let* ((fun-name (first form)) - (translator (info :function :ir1-convert fun-name)) - (cmacro-fun (sb!xc:compiler-macro-function fun-name *lexenv*))) +;;; Find a compiler-macro for a form, taking FUNCALL into account. +(defun find-compiler-macro (opname form) + (if (eq opname 'funcall) + (let ((fun-form (cadr form))) + (cond ((and (consp fun-form) (eq 'function (car fun-form))) + (let ((real-fun (cadr fun-form))) + (if (legal-fun-name-p real-fun) + (values (sb!xc:compiler-macro-function real-fun *lexenv*) + real-fun) + (values nil nil)))) + ((sb!xc:constantp fun-form *lexenv*) + (let ((fun (constant-form-value fun-form *lexenv*))) + (if (legal-fun-name-p fun) + ;; CLHS tells us that local functions must shadow + ;; compiler-macro-functions, but since the call is + ;; through a name, we are obviously interested + ;; in the global function. + (values (sb!xc:compiler-macro-function fun nil) fun) + (values nil nil)))) + (t + (values nil nil)))) + (if (legal-fun-name-p opname) + (values (sb!xc:compiler-macro-function opname *lexenv*) opname) + (values nil nil)))) + +;;; Picks of special forms and compiler-macro expansions, and hands +;;; the rest to IR1-CONVERT-COMMON-FUNCTOID +(defun ir1-convert-functoid (start next result form) + (let* ((op (car form)) + (translator (and (symbolp op) (info :function :ir1-convert op)))) (cond (translator - (when cmacro-fun + (when (sb!xc:compiler-macro-function op *lexenv*) (compiler-warn "ignoring compiler macro for special form")) (funcall translator start next result form)) - ((and cmacro-fun - ;; gotcha: If you look up the DEFINE-COMPILER-MACRO - ;; macro in the ANSI spec, you might think that - ;; suppressing compiler-macro expansion when NOTINLINE - ;; is some pre-ANSI hack. However, if you look up the - ;; NOTINLINE declaration, you'll find that ANSI - ;; requires this behavior after all. - (not (eq (info :function :inlinep fun-name) :notinline))) - (let ((res (careful-expand-macro cmacro-fun form))) - (if (eq res form) - (ir1-convert-global-functoid-no-cmacro - start next result form fun-name) - (ir1-convert start next result res)))) (t - (ir1-convert-global-functoid-no-cmacro start next result - form fun-name))))) + (multiple-value-bind (cmacro-fun cmacro-fun-name) + (find-compiler-macro op form) + (if (and cmacro-fun + ;; 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))) + (ir1-convert-common-functoid start next result form op))))))) -;;; Handle the case of where the call was not a compiler macro, or was -;;; a compiler macro and passed. -(defun ir1-convert-global-functoid-no-cmacro (start next result form fun) +;;; Handles the "common" cases: any other forms except special forms +;;; and compiler-macros. +(defun ir1-convert-common-functoid (start next result form op) + (cond ((or (symbolp op) (leaf-p op)) + (let ((lexical-def (if (leaf-p op) op (lexenv-find op funs)))) + (typecase lexical-def + (null + (ir1-convert-global-functoid start next result form op)) + (functional + (ir1-convert-local-combination start next result form + lexical-def)) + (global-var + (ir1-convert-srctran start next result lexical-def form)) + (t + (aver (and (consp lexical-def) (eq (car lexical-def) 'macro))) + (ir1-convert start next result + (careful-expand-macro (cdr lexical-def) form)))))) + ((or (atom op) (not (eq (car op) 'lambda))) + (compiler-error "illegal function call")) + (t + ;; implicitly (LAMBDA ..) because the LAMBDA expression is + ;; the CAR of an executed form. + (ir1-convert-combination + start next result form + (ir1-convert-lambda op + :debug-name (debug-name 'inline-lambda op)))))) + +;;; Convert anything that looks like a global function call. +(defun ir1-convert-global-functoid (start next result form fun) (declare (type ctran start next) (type (or lvar null) result) (list form)) ;; FIXME: Couldn't all the INFO calls here be converted into - ;; standard CL functions, like MACRO-FUNCTION or something? - ;; And what happens with lexically-defined (MACROLET) macros - ;; here, anyway? + ;; standard CL functions, like MACRO-FUNCTION or something? And what + ;; happens with lexically-defined (MACROLET) macros here, anyway? (ecase (info :function :kind fun) (:macro (ir1-convert start next result (careful-expand-macro (info :function :macro-function fun) - form))) + form)) + (unless (policy *lexenv* (zerop store-xref-data)) + (record-macroexpansion fun (ctran-block start) *current-path*))) ((nil :function) (ir1-convert-srctran start next result (find-free-fun fun "shouldn't happen! (no-cmacro)") @@ -709,7 +773,7 @@ (let ((*print-pretty* nil) ;; We rely on the printer to abbreviate FORM. (*print-length* 3) - (*print-level* 1)) + (*print-level* 3)) (format nil #-sb-xc-host "(in macroexpansion of ~S)" @@ -777,6 +841,8 @@ (forms body)) (loop (let ((form (car forms))) + (setf this-start + (maybe-instrument-progn-like this-start forms form)) (when (endp (cdr forms)) (ir1-convert this-start next result form) (return)) @@ -785,9 +851,107 @@ (setq this-start this-ctran forms (cdr forms))))))) (values)) + + +;;;; code coverage + +;;; Check the policy for whether we should generate code coverage +;;; instrumentation. If not, just return the original START +;;; ctran. Otherwise insert code coverage instrumentation after +;;; START, and return the new ctran. +(defun instrument-coverage (start mode form) + ;; We don't actually use FORM for anything, it's just convenient to + ;; have around when debugging the instrumentation. + (declare (ignore form)) + (if (and (policy *lexenv* (> store-coverage-data 0)) + *code-coverage-records* + *allow-instrumenting*) + (let ((path (source-path-original-source *current-path*))) + (when mode + (push mode path)) + (if (member (ctran-block start) + (gethash path *code-coverage-blocks*)) + ;; If this source path has already been instrumented in + ;; this block, don't instrument it again. + start + (let ((store + ;; Get an interned record cons for the path. A cons + ;; with the same object identity must be used for + ;; each instrument for the same block. + (or (gethash path *code-coverage-records*) + (setf (gethash path *code-coverage-records*) + (cons path +code-coverage-unmarked+)))) + (next (make-ctran)) + (*allow-instrumenting* nil)) + (push (ctran-block start) + (gethash path *code-coverage-blocks*)) + (let ((*allow-instrumenting* nil)) + (ir1-convert start next nil + `(locally + (declare (optimize speed + (safety 0) + (debug 0) + (check-constant-modification 0))) + ;; We're being naughty here, and + ;; modifying constant data. That's ok, + ;; we know what we're doing. + (%rplacd ',store t)))) + next))) + start)) + +;;; In contexts where we don't have a source location for FORM +;;; e.g. due to it not being a cons, but where we have a source +;;; location for the enclosing cons, use the latter source location if +;;; available. This works pretty well in practice, since many PROGNish +;;; macroexpansions will just directly splice a block of forms into +;;; some enclosing form with `(progn ,@body), thus retaining the +;;; EQness of the conses. +(defun maybe-instrument-progn-like (start forms form) + (or (when (and *allow-instrumenting* + (not (get-source-path form))) + (let ((*current-path* (get-source-path forms))) + (when *current-path* + (instrument-coverage start nil form)))) + start)) + +(defun record-code-coverage (info cc) + (setf (gethash info *code-coverage-info*) cc)) + +(defun clear-code-coverage () + (clrhash *code-coverage-info*)) + +(defun reset-code-coverage () + (maphash (lambda (info cc) + (declare (ignore info)) + (dolist (cc-entry cc) + (setf (cdr cc-entry) +code-coverage-unmarked+))) + *code-coverage-info*)) + +(defun code-coverage-record-marked (record) + (aver (consp record)) + (ecase (cdr record) + ((#.+code-coverage-unmarked+) nil) + ((t) t))) + ;;;; converting combinations +;;; Does this form look like something that we should add single-stepping +;;; instrumentation for? +(defun step-form-p (form) + (flet ((step-symbol-p (symbol) + (not (member (symbol-package symbol) + (load-time-value + ;; KLUDGE: packages we're not interested in + ;; stepping. + (mapcar #'find-package '(sb!c sb!int sb!impl + sb!kernel sb!pcl))))))) + (and *allow-instrumenting* + (policy *lexenv* (= insert-step-conditions 3)) + (listp form) + (symbolp (car form)) + (step-symbol-p (car form))))) + ;;; Convert a function call where the function FUN is a LEAF. FORM is ;;; the source for the call. We return the COMBINATION node so that ;;; the caller can poke at it if it wants to. @@ -797,7 +961,20 @@ (let ((ctran (make-ctran)) (fun-lvar (make-lvar))) (ir1-convert start ctran fun-lvar `(the (or function symbol) ,fun)) - (ir1-convert-combination-args fun-lvar ctran next result (cdr form)))) + (let ((combination + (ir1-convert-combination-args fun-lvar ctran next result + (cdr form)))) + (when (step-form-p form) + ;; Store a string representation of the form in the + ;; combination node. This will let the IR2 translator know + ;; that we want stepper instrumentation for this node. The + ;; string will be stored in the debug-info by DUMP-1-LOCATION. + (setf (combination-step-info combination) + (let ((*print-pretty* t) + (*print-circle* t) + (*print-readably* nil)) + (prin1-to-string form)))) + combination))) ;;; Convert the arguments to a call and make the COMBINATION ;;; node. FUN-LVAR yields the function to call. ARGS is the list of @@ -811,8 +988,12 @@ (let ((node (make-combination fun-lvar))) (setf (lvar-dest fun-lvar) node) (collect ((arg-lvars)) - (let ((this-start start)) + (let ((this-start start) + (forms args)) (dolist (arg args) + (setf this-start + (maybe-instrument-progn-like this-start forms arg)) + (setf forms (cdr forms)) (let ((this-ctran (make-ctran)) (this-lvar (make-lvar node))) (ir1-convert this-start this-ctran this-lvar arg) @@ -845,6 +1026,10 @@ (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 +;;; attribute, don't generate any branch coverage instrumentation for it. +(defvar *instrument-if-for-code-coverage* t) + ;;; 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. @@ -860,7 +1045,8 @@ (if (and info (ir1-attributep (fun-info-attributes info) predicate) (not (if-p (and result (lvar-dest result))))) - (ir1-convert start next result `(if ,form t nil)) + (let ((*instrument-if-for-code-coverage* nil)) + (ir1-convert start next result `(if ,form t nil))) (ir1-convert-combination-checking-type start next result form var)))) ;;; Actually really convert a global function call that we are allowed @@ -883,8 +1069,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))) @@ -929,15 +1116,15 @@ ;;; If a LAMBDA-VAR being bound, we intersect the type with the var's ;;; type, otherwise we add a type restriction on the var. If a symbol ;;; macro, we just wrap a THE around the expansion. -(defun process-type-decl (decl res vars) +(defun process-type-decl (decl res vars context) (declare (list decl vars) (type lexenv res)) (let ((type (compiler-specifier-type (first decl)))) (collect ((restr nil cons) (new-vars nil cons)) (dolist (var-name (rest decl)) (when (boundp var-name) - (compiler-assert-symbol-home-package-unlocked - var-name "declaring the type of ~A")) + (program-assert-symbol-home-package-unlocked + context var-name "declaring the type of ~A")) (let* ((bound-var (find-in-bindings vars var-name)) (var (or bound-var (lexenv-find var-name vars) @@ -964,7 +1151,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) @@ -992,15 +1181,15 @@ ;;; declarations for functions being bound, we must also deal with ;;; declarations that constrain the type of lexically apparent ;;; functions. -(defun process-ftype-decl (spec res names fvars) +(defun process-ftype-decl (spec res names fvars context) (declare (type list names fvars) (type lexenv res)) (let ((type (compiler-specifier-type spec))) (collect ((res nil cons)) (dolist (name names) (when (fboundp name) - (compiler-assert-symbol-home-package-unlocked - name "declaring the ftype of ~A")) + (program-assert-symbol-home-package-unlocked + context name "declaring the ftype of ~A")) (let ((found (find name fvars :key #'leaf-source-name :test #'equal))) (cond (found @@ -1020,11 +1209,12 @@ ;;; special declaration is instantiated by throwing a special variable ;;; into the variables if BINDING-FORM-P is NIL, or otherwise into ;;; *POST-BINDING-VARIABLE-LEXENV*. -(defun process-special-decl (spec res vars binding-form-p) +(defun process-special-decl (spec res vars binding-form-p context) (declare (list spec vars) (type lexenv res)) (collect ((new-venv nil cons)) (dolist (name (cdr spec)) - (compiler-assert-symbol-home-package-unlocked name "declaring ~A special") + (program-assert-symbol-home-package-unlocked + context name "declaring ~A special") (let ((var (find-in-bindings vars name))) (etypecase var (cons @@ -1071,8 +1261,8 @@ (when (defined-fun-p var) (setf (defined-fun-inline-expansion res) (defined-fun-inline-expansion var)) - (setf (defined-fun-functional res) - (defined-fun-functional var))) + (setf (defined-fun-functionals res) + (defined-fun-functionals var))) ;; FIXME: Is this really right? Needs we not set the FUNCTIONAL ;; to the original global-var? res)) @@ -1143,54 +1333,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. @@ -1201,18 +1396,18 @@ ;;; Process a single declaration spec, augmenting the specified LEXENV ;;; RES. Return RES and result type. VARS and FVARS are as described ;;; PROCESS-DECLS. -(defun process-1-decl (raw-spec res vars fvars binding-form-p) +(defun process-1-decl (raw-spec res vars fvars binding-form-p context) (declare (type list raw-spec vars fvars)) (declare (type lexenv res)) (let ((spec (canonized-decl-spec raw-spec)) (result-type *wild-type*)) (values (case (first spec) - (special (process-special-decl spec res vars binding-form-p)) + (special (process-special-decl spec res vars binding-form-p context)) (ftype (unless (cdr spec) (compiler-error "no type specified in FTYPE declaration: ~S" spec)) - (process-ftype-decl (second spec) res (cddr spec) fvars)) + (process-ftype-decl (second spec) res (cddr spec) fvars context)) ((inline notinline maybe-inline) (process-inline-decl spec res fvars)) ((ignore ignorable) @@ -1233,7 +1428,7 @@ :handled-conditions (process-unmuffle-conditions-decl spec (lexenv-handled-conditions res)))) (type - (process-type-decl (cdr spec) res vars)) + (process-type-decl (cdr spec) res vars context)) (values (unless *suppress-values-declaration* (let ((types (cdr spec))) @@ -1243,8 +1438,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 @@ -1268,21 +1463,27 @@ ;;; ;;; This is also called in main.lisp when PROCESS-FORM handles a use ;;; of LOCALLY. -(defun process-decls (decls vars fvars &key (lexenv *lexenv*) - (binding-form-p nil)) +(defun process-decls (decls vars fvars &key + (lexenv *lexenv*) (binding-form-p nil) (context :compile)) (declare (list decls vars fvars)) (let ((result-type *wild-type*) (*post-binding-variable-lexenv* nil)) (dolist (decl decls) (dolist (spec (rest decl)) - (unless (consp spec) - (compiler-error "malformed declaration specifier ~S in ~S" spec decl)) - (multiple-value-bind (new-env new-result-type) - (process-1-decl spec lexenv vars fvars binding-form-p) - (setq lexenv new-env) - (unless (eq new-result-type *wild-type*) - (setq result-type - (values-type-intersection result-type new-result-type)))))) + (progv + ;; Kludge: EVAL calls this function to deal with LOCALLY. + (when (eq context :compile) (list '*current-path*)) + (when (eq context :compile) (list (or (get-source-path spec) + (get-source-path decl) + *current-path*))) + (unless (consp spec) + (compiler-error "malformed declaration specifier ~S in ~S" spec decl)) + (multiple-value-bind (new-env new-result-type) + (process-1-decl spec lexenv vars fvars binding-form-p context) + (setq lexenv new-env) + (unless (eq new-result-type *wild-type*) + (setq result-type + (values-type-intersection result-type new-result-type))))))) (values lexenv result-type *post-binding-variable-lexenv*))) (defun %processing-decls (decls vars fvars ctran lvar binding-form-p fun) @@ -1306,7 +1507,7 @@ (check-type ctran symbol) (check-type lvar symbol) (let ((post-binding-lexenv-p (not (null post-binding-lexenv))) - (post-binding-lexenv (or post-binding-lexenv (gensym)))) + (post-binding-lexenv (or post-binding-lexenv (sb!xc:gensym "LEXENV")))) `(%processing-decls ,decls ,vars ,fvars ,ctran ,lvar ,post-binding-lexenv-p (lambda (,ctran ,lvar ,post-binding-lexenv)