X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir1-translators.lisp;h=a6a6f640b95a700affb46c40fd09a12920523efd;hb=6075b05401346ac20ec9a647fe192a2a959f3882;hp=443fef5569458c4d406b29851c19a80bd401b51f;hpb=dafb0472097d387a668b0f84bef3abc3a84e0b1d;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 443fef5..a6a6f64 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -34,6 +34,8 @@ otherwise evaluate ELSE and return its values. ELSE defaults to NIL." (then-block (ctran-starts-block then-ctran)) (else-ctran (make-ctran)) (else-block (ctran-starts-block else-ctran)) + (maybe-instrument *instrument-if-for-code-coverage*) + (*instrument-if-for-code-coverage* t) (node (make-if :test pred-lvar :consequent then-block :alternative else-block))) @@ -50,8 +52,32 @@ otherwise evaluate ELSE and return its values. ELSE defaults to NIL." (link-blocks start-block then-block) (link-blocks start-block else-block)) - (ir1-convert then-ctran next result then) - (ir1-convert else-ctran next result else))) + (let ((path (best-sub-source-path test))) + (ir1-convert (if (and path maybe-instrument) + (let ((*current-path* path)) + (instrument-coverage then-ctran :then test)) + then-ctran) + next result then) + (ir1-convert (if (and path maybe-instrument) + (let ((*current-path* path)) + (instrument-coverage else-ctran :else test)) + else-ctran) + next result else)))) + +;;; To get even remotely sensible results for branch coverage +;;; tracking, we need good source paths. If the macroexpansions +;;; interfere enough the TEST of the conditional doesn't actually have +;;; an original source location (e.g. (UNLESS FOO ...) -> (IF (NOT +;;; FOO) ...). Look through the form, and try to find some subform +;;; that has one. +(defun best-sub-source-path (form) + (if (policy *lexenv* (= store-coverage-data 0)) + nil + (labels ((sub (form) + (or (get-source-path form) + (and (consp form) + (some #'sub form))))) + (or (sub form))))) ;;;; BLOCK and TAGBODY @@ -126,35 +152,38 @@ extent of the block." (link-node-to-previous-ctran exit value-ctran) (let ((home-lambda (ctran-home-lambda-or-null start))) (when home-lambda - (push entry (lambda-calls-or-closes home-lambda)))) + (sset-adjoin entry (lambda-calls-or-closes home-lambda)))) (use-continuation exit exit-ctran (third found)))) ;;; Return a list of the segments of a TAGBODY. Each segment looks ;;; like (
* (go )). That is, we break up the ;;; tagbody into segments of non-tag statements, and explicitly ;;; represent the drop-through with a GO. The first segment has a -;;; dummy NIL tag, since it represents code before the first tag. The +;;; dummy NIL tag, since it represents code before the first tag. Note +;;; however that NIL may appear as the tag of an inner segment. The ;;; last segment (which may also be the first segment) ends in NIL ;;; rather than a GO. (defun parse-tagbody (body) (declare (list body)) - (collect ((segments)) - (let ((current (cons nil body))) + (collect ((tags) + (segments)) + (let ((current body)) (loop - (let ((tag-pos (position-if (complement #'listp) current :start 1))) - (unless tag-pos - (segments `(,@current nil)) - (return)) - (let ((tag (elt current tag-pos))) - (when (assoc tag (segments)) - (compiler-error - "The tag ~S appears more than once in the tagbody." - tag)) - (unless (or (symbolp tag) (integerp tag)) - (compiler-error "~S is not a legal tagbody statement." tag)) - (segments `(,@(subseq current 0 tag-pos) (go ,tag)))) - (setq current (nthcdr tag-pos current))))) - (segments))) + (let ((next-segment (member-if #'atom current))) + (unless next-segment + (segments `(,@current nil)) + (return)) + (let ((tag (car next-segment))) + (when (member tag (tags)) + (compiler-error + "The tag ~S appears more than once in a tagbody." + tag)) + (unless (or (symbolp tag) (integerp tag)) + (compiler-error "~S is not a legal go tag." tag)) + (tags tag) + (segments `(,@(ldiff current next-segment) (go ,tag)))) + (setq current (rest next-segment)))) + (mapcar #'cons (cons nil (tags)) (segments))))) ;;; Set up the cleanup, emitting the entry node. Then make a block for ;;; each tag, building up the tag list for LEXENV-TAGS as we go. @@ -218,7 +247,7 @@ constrained to be used only within the dynamic extent of the TAGBODY." (link-node-to-previous-ctran exit start) (let ((home-lambda (ctran-home-lambda-or-null start))) (when home-lambda - (push entry (lambda-calls-or-closes home-lambda)))) + (sset-adjoin entry (lambda-calls-or-closes home-lambda)))) (use-ctran exit (second found)))) ;;;; translators for compiler-magic special forms @@ -446,10 +475,11 @@ Return VALUE without evaluating it." (defun name-lambdalike (thing) (ecase (car thing) ((named-lambda) - (second thing)) + (or (second thing) + `(lambda ,(third thing)))) ((lambda instance-lambda) `(lambda ,(second thing))) - ((lambda-with-lexenv)' + ((lambda-with-lexenv) `(lambda ,(fifth thing))))) (defun fun-name-leaf (thing) @@ -546,7 +576,7 @@ be a lambda expression." ;;; directly to %FUNCALL, instead of waiting around for type ;;; inference. (define-source-transform funcall (function &rest args) - (if (and (consp function) (eq (car function) 'function)) + (if (and (consp function) (member (car function) '(function lambda))) `(%funcall ,function ,@args) (let ((name (constant-global-fun-name function))) (if name @@ -556,6 +586,11 @@ be a lambda expression." (deftransform %coerce-callable-to-fun ((thing) (function) *) "optimize away possible call to FDEFINITION at runtime" 'thing) + +(define-source-transform %coerce-callable-to-fun (thing) + (if (and (consp thing) (member (car thing) '(function lambda))) + thing + (values nil t))) ;;;; LET and LET* ;;;; @@ -671,7 +706,7 @@ form to reference any of the previous VARS." #!+sb-doc "LOCALLY declaration* form* -Sequentially evaluate the FORMS in a lexical environment where the the +Sequentially evaluate the FORMS in a lexical environment where the DECLARATIONS have effect. If LOCALLY is a top level form, then the FORMS are also processed as top level forms." (ir1-translate-locally body start next result)) @@ -743,6 +778,7 @@ lexically apparent function definition in the enclosing environment." (let ((fvars (mapcar (lambda (n d) (ir1-convert-lambda d :source-name n + :maybe-add-debug-catch t :debug-name (debug-name 'flet n))) names defs))) (processing-decls (decls nil fvars next result) @@ -777,6 +813,7 @@ other." (mapcar (lambda (name def) (ir1-convert-lambda def :source-name name + :maybe-add-debug-catch t :debug-name (debug-name 'labels name))) names defs)))) @@ -823,26 +860,34 @@ other." ;;; Assert that FORM evaluates to the specified type (which may be a ;;; VALUES type). TYPE may be a type specifier or (as a hack) a CTYPE. -(def-ir1-translator the ((type value) start next result) - (the-in-policy type value (lexenv-policy *lexenv*) start next result)) +(def-ir1-translator the ((value-type form) start next result) + #!+sb-doc + "Specifies that the values returned by FORM conform to the VALUE-TYPE. + +CLHS specifies that the consequences are undefined if any result is +not of the declared type, but SBCL treats declarations as assertions +as long as SAFETY is at least 2, in which case incorrect type +information will result in a runtime type-error instead of leading to +eg. heap corruption. This is however expressly non-portable: use +CHECK-TYPE instead of THE to catch type-errors at runtime. THE is best +considered an optimization tool to inform the compiler about types it +is unable to derive from other declared types." + (the-in-policy value-type form (lexenv-policy *lexenv*) start next result)) ;;; This is like the THE special form, except that it believes ;;; whatever you tell it. It will never generate a type check, but ;;; will cause a warning if the compiler can prove the assertion is ;;; wrong. -(def-ir1-translator truly-the ((type value) start next result) +(def-ir1-translator truly-the ((value-type form) start next result) #!+sb-doc - "" - #-nil - (let ((type (coerce-to-values (compiler-values-specifier-type type))) - (old (when result (find-uses result)))) - (ir1-convert start next result value) - (when result - (do-uses (use result) - (unless (memq use old) - (derive-node-type use type))))) - #+nil - (the-in-policy type value '((type-check . 0)) start cont)) + "Specifies that the values returned by FORM conform to the +VALUE-TYPE, and causes the compiler to trust this information +unconditionally. + +Consequences are undefined if any result is not of the declared type +-- typical symptoms including memory corruptions. Use with great +care." + (the-in-policy value-type form '((type-check . 0)) start next result)) ;;;; SETQ @@ -864,7 +909,7 @@ other." (when (lambda-var-p leaf) (let ((home-lambda (ctran-home-lambda-or-null start))) (when home-lambda - (pushnew leaf (lambda-calls-or-closes home-lambda)))) + (sset-adjoin leaf (lambda-calls-or-closes home-lambda)))) (when (lambda-var-ignorep leaf) ;; ANSI's definition of "Declaration IGNORE, IGNORABLE" ;; requires that this be a STYLE-WARNING, not a full warning. @@ -1005,7 +1050,9 @@ due to normal completion or a non-local exit such as THROW)." (ir1-convert start next result (with-unique-names (cleanup-fun drop-thru-tag exit-tag next start count) - `(flet ((,cleanup-fun () ,@cleanup nil)) + `(flet ((,cleanup-fun () + ,@cleanup + nil)) ;; FIXME: If we ever get DYNAMIC-EXTENT working, then ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT, ;; and something can be done to make %ESCAPE-FUN have @@ -1018,6 +1065,7 @@ due to normal completion or a non-local exit such as THROW)." (%unwind-protect (%escape-fun ,exit-tag) (%cleanup-fun ,cleanup-fun)) (return-from ,drop-thru-tag ,protected))) + (declare (optimize (insert-debug-catch 0))) (,cleanup-fun) (%continue-unwind ,next ,start ,count)))))))