(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)))
(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)))))
\f
;;;; BLOCK and TAGBODY
(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 (<tag> <form>* (go <next tag>)). 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.
(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))))
\f
;;;; translators for compiler-magic special forms
(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)
;;; 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
(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)))
\f
;;;; LET and LET*
;;;;
(multiple-value-bind (forms decls)
(parse-body body :doc-string-allowed nil)
(multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
- (processing-decls (decls vars nil start next post-binding-lexenv)
+ (processing-decls (decls vars nil next result post-binding-lexenv)
(ir1-convert-aux-bindings start
next
result
#!+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))
(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)
(mapcar (lambda (name def)
(ir1-convert-lambda def
:source-name name
+ :maybe-add-debug-catch t
:debug-name (debug-name 'labels name)))
names defs))))
;;; 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))
\f
;;;; SETQ
(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.
(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
(%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)))))))
\f
projects / sbcl.git / blobdiff