X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=7bd2bfbee4475b47a4801a5d0f5c97162a0bba86;hb=5193965ff7688f7d748962405343ed666bf616b2;hp=a1437e1c0f492357aae33f0e8d493b3a8e81f2a2;hpb=1840d888d2ef13fe0ea5aaa06f1fef3300da682b;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index a1437e1..7bd2bfb 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -26,7 +26,7 @@ forms, returns NIL." #!+sb-doc "IF predicate then [else] -If PREDICATE evaluates to false, evaluate THEN and return its values, +If PREDICATE evaluates to true, evaluate THEN and return its values, otherwise evaluate ELSE and return its values. ELSE defaults to NIL." (let* ((pred-ctran (make-ctran)) (pred-lvar (make-lvar)) @@ -34,13 +34,18 @@ 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))) ;; IR1-CONVERT-MAYBE-PREDICATE requires DEST to be CIF, so the ;; order of the following two forms is important (setf (lvar-dest pred-lvar) node) - (ir1-convert start pred-ctran pred-lvar test) + (multiple-value-bind (context count) (possible-rest-arg-context test) + (if context + (ir1-convert start pred-ctran pred-lvar `(%rest-true ,test ,context ,count)) + (ir1-convert start pred-ctran pred-lvar test))) (link-node-to-previous-ctran node pred-ctran) (let ((start-block (ctran-block pred-ctran))) @@ -50,8 +55,37 @@ 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) + (when (consp form) + (unless (eq 'quote (car form)) + (somesub form))))) + (somesub (forms) + (when (consp forms) + (or (sub (car forms)) + (somesub (cdr forms)))))) + (sub form)))) ;;;; BLOCK and TAGBODY @@ -167,11 +201,11 @@ extent of the block." #!+sb-doc "TAGBODY {tag | statement}* -Define tags for use with GO. The STATEMENTS are evaluated in order ,skipping +Define tags for use with GO. The STATEMENTS are evaluated in order, skipping TAGS, and NIL is returned. If a statement contains a GO to a defined TAG within the lexical scope of the form, then control is transferred to the next -statement following that tag. A TAG must an integer or a symbol. A STATEMENT -must be a list. Other objects are illegal within the body." +statement following that tag. A TAG must be an integer or a symbol. A +STATEMENT must be a list. Other objects are illegal within the body." (start-block start) (ctran-starts-block next) (let* ((dummy (make-ctran)) @@ -321,7 +355,7 @@ Evaluate the FORMS in the specified SITUATIONS (any of :COMPILE-TOPLEVEL, "MACROLET ({(name lambda-list form*)}*) body-form* Evaluate the BODY-FORMS in an environment with the specified local macros -defined. Name is the local macro name, LAMBDA-LIST is a DEFMACRO style +defined. NAME is the local macro name, LAMBDA-LIST is a DEFMACRO style destructuring lambda list, and the FORMS evaluate to the expansion." (funcall-in-macrolet-lexenv definitions @@ -347,7 +381,7 @@ destructuring lambda list, and the FORMS evaluate to the expansion." (program-assert-symbol-home-package-unlocked context name "binding ~A as a local symbol-macro")) (let ((kind (info :variable :kind name))) - (when (member kind '(:special :constant)) + (when (member kind '(:special :constant :global)) (fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" kind name))) ;; A magical cons that MACROEXPAND-1 understands. @@ -423,7 +457,7 @@ body, references to a NAME will effectively be replaced with the EXPANSION." nargs min))) - (when (eq (template-result-types template) :conditional) + (when (template-conditional-p template) (bug "%PRIMITIVE was used with a conditional template.")) (when (template-more-results-type template) @@ -445,21 +479,47 @@ body, references to a NAME will effectively be replaced with the EXPANSION." Return VALUE without evaluating it." (reference-constant start next result thing)) +(defun name-context () + ;; Name of the outermost non-NIL BLOCK, or the source namestring + ;; of the source file. + (let ((context + (or (car (find-if (lambda (b) + (let ((name (pop b))) + (and name + ;; KLUDGE: High debug adds this block on + ;; some platforms. + #!-unwind-to-frame-and-call-vop + (neq 'return-value-tag name) + ;; KLUDGE: CATCH produces blocks whose + ;; cleanup is :CATCH. + (neq :catch (cleanup-kind (entry-cleanup (pop b))))))) + (lexenv-blocks *lexenv*) :from-end t)) + *source-namestring* + (let ((p (or *compile-file-truename* *load-truename*))) + (when p (namestring p)))))) + (when context + (list :in context)))) + ;;;; FUNCTION and NAMED-LAMBDA (defun name-lambdalike (thing) - (ecase (car thing) + (case (car thing) ((named-lambda) - (second thing)) - ((lambda instance-lambda) - `(lambda ,(second thing))) - ((lambda-with-lexenv)' - `(lambda ,(fifth thing))))) + (or (second thing) + `(lambda ,(third thing) ,(name-context)))) + ((lambda) + `(lambda ,(second thing) ,@(name-context))) + ((lambda-with-lexenv) + ;; FIXME: Get the original DEFUN name here. + `(lambda ,(fifth thing))) + (otherwise + (compiler-error "Not a valid lambda expression:~% ~S" + thing)))) (defun fun-name-leaf (thing) (if (consp thing) (cond ((member (car thing) - '(lambda named-lambda instance-lambda lambda-with-lexenv)) + '(lambda named-lambda lambda-with-lexenv)) (values (ir1-convert-lambdalike thing :debug-name (name-lambdalike thing)) @@ -482,9 +542,9 @@ Return VALUE without evaluating it." (dolist (lambda lambdas) (setf (functional-allocator lambda) allocator))))) -(defmacro with-fun-name-leaf ((leaf thing start &key global) &body body) +(defmacro with-fun-name-leaf ((leaf thing start &key global-function) &body body) `(multiple-value-bind (,leaf allocate-p) - (if ,global + (if ,global-function (find-global-fun ,thing t) (fun-name-leaf ,thing)) (if allocate-p @@ -508,14 +568,45 @@ be a lambda expression." ;;; expansions, and doesn't nag about undefined functions. ;;; Used for optimizing things like (FUNCALL 'FOO). (def-ir1-translator global-function ((thing) start next result) - (with-fun-name-leaf (leaf thing start :global t) + (with-fun-name-leaf (leaf thing start :global-function t) (reference-leaf start next result leaf))) (defun constant-global-fun-name (thing) (let ((constantp (sb!xc:constantp thing))) - (and constantp - (let ((name (constant-form-value thing))) - (and (legal-fun-name-p name) name))))) + (when constantp + (let ((name (constant-form-value thing))) + (when (legal-fun-name-p name) + name))))) + +(defun lvar-constant-global-fun-name (lvar) + (when (constant-lvar-p lvar) + (let ((name (lvar-value lvar))) + (when (legal-fun-name-p name) + name)))) + +(defun ensure-source-fun-form (source &optional give-up) + (let ((op (when (consp source) (car source)))) + (cond ((eq op '%coerce-callable-to-fun) + (ensure-source-fun-form (second source))) + ((member op '(function global-function lambda named-lambda)) + (values source nil)) + (t + (let ((cname (constant-global-fun-name source))) + (if cname + (values `(global-function ,cname) nil) + (values `(%coerce-callable-to-fun ,source) give-up))))))) + +(defun ensure-lvar-fun-form (lvar lvar-name &optional give-up) + (aver (and lvar-name (symbolp lvar-name))) + (if (csubtypep (lvar-type lvar) (specifier-type 'function)) + lvar-name + (let ((cname (lvar-constant-global-fun-name lvar))) + (cond (cname + `(global-function ,cname)) + (give-up + (give-up-ir1-transform "not known to be a function")) + (t + `(%coerce-callable-to-fun ,lvar-name)))))) ;;;; FUNCALL @@ -525,40 +616,43 @@ be a lambda expression." (deftransform funcall ((function &rest args) * *) (let ((arg-names (make-gensym-list (length args)))) `(lambda (function ,@arg-names) - (%funcall ,(if (csubtypep (lvar-type function) - (specifier-type 'function)) - 'function - '(%coerce-callable-to-fun function)) - ,@arg-names)))) + (declare (ignorable function)) + `(%funcall ,(ensure-lvar-fun-form function 'function) ,@arg-names)))) (def-ir1-translator %funcall ((function &rest args) start next result) - (cond ((and (consp function) (eq (car function) 'function)) - (with-fun-name-leaf (leaf (second function) start) - (ir1-convert start next result `(,leaf ,@args)))) - ((and (consp function) (eq (car function) 'global-function)) - (with-fun-name-leaf (leaf (second function) start :global t) - (ir1-convert start next result `(,leaf ,@args)))) - (t - (let ((ctran (make-ctran)) - (fun-lvar (make-lvar))) - (ir1-convert start ctran fun-lvar `(the function ,function)) - (ir1-convert-combination-args fun-lvar ctran next result args))))) + ;; MACROEXPAND so that (LAMBDA ...) forms arriving here don't get an + ;; extra cast inserted for them. + (let* ((function (%macroexpand function *lexenv*)) + (op (when (consp function) (car function)))) + (cond ((eq op 'function) + (compiler-destructuring-bind (thing) (cdr function) + function + (with-fun-name-leaf (leaf thing start) + (ir1-convert start next result `(,leaf ,@args))))) + ((eq op 'global-function) + (compiler-destructuring-bind (thing) (cdr function) + global-function + (with-fun-name-leaf (leaf thing start :global-function t) + (ir1-convert start next result `(,leaf ,@args))))) + (t + (let ((ctran (make-ctran)) + (fun-lvar (make-lvar))) + (ir1-convert start ctran fun-lvar `(the function ,function)) + (ir1-convert-combination-args fun-lvar ctran next result args)))))) ;;; This source transform exists to reduce the amount of work for the ;;; compiler. If the called function is a FUNCTION form, then convert ;;; 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)) - `(%funcall ,function ,@args) - (let ((name (constant-global-fun-name function))) - (if name - `(%funcall (global-function ,name) ,@args) - (values nil t))))) - -(deftransform %coerce-callable-to-fun ((thing) (function) *) + `(%funcall ,(ensure-source-fun-form function) ,@args)) + +(deftransform %coerce-callable-to-fun ((thing) * * :node node) "optimize away possible call to FDEFINITION at runtime" - 'thing) + (ensure-lvar-fun-form thing 'thing t)) + +(define-source-transform %coerce-callable-to-fun (thing) + (ensure-source-fun-form thing t)) ;;;; LET and LET* ;;;; @@ -583,7 +677,8 @@ be a lambda expression." (varify-lambda-arg name (if (eq context 'let*) nil - (names))))) + (names)) + context))) (dolist (spec bindings) (cond ((atom spec) (let ((var (get-var spec))) @@ -674,7 +769,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)) @@ -701,8 +796,9 @@ also processed as top level forms." (program-assert-symbol-home-package-unlocked :compile name "binding ~A as a local function")) (names name) - (multiple-value-bind (forms decls) (parse-body (cddr def)) + (multiple-value-bind (forms decls doc) (parse-body (cddr def)) (defs `(lambda ,(second def) + ,@(when doc (list doc)) ,@decls (block ,(fun-name-block-name name) . ,forms)))))) @@ -744,10 +840,11 @@ lexically apparent function definition in the enclosing environment." (multiple-value-bind (names defs) (extract-flet-vars definitions 'flet) (let ((fvars (mapcar (lambda (n d) - (ir1-convert-lambda d - :source-name n - :maybe-add-debug-catch t - :debug-name (debug-name 'flet n))) + (ir1-convert-lambda + d :source-name n + :maybe-add-debug-catch t + :debug-name + (debug-name 'flet n t))) names defs))) (processing-decls (decls nil fvars next result) (let ((*lexenv* (make-lexenv :funs (pairlis names fvars)))) @@ -782,7 +879,7 @@ other." (ir1-convert-lambda def :source-name name :maybe-add-debug-catch t - :debug-name (debug-name 'labels name))) + :debug-name (debug-name 'labels name t))) names defs)))) ;; Modify all the references to the dummy function leaves so @@ -815,6 +912,8 @@ other." (values-subtypep (make-single-value-type (leaf-type value)) type)) (and (sb!xc:constantp value) + (or (not (values-type-p type)) + (values-type-may-be-single-value-p type)) (ctypep (constant-form-value value) (single-value-type type)))) (ir1-convert start next result value)) @@ -828,26 +927,46 @@ 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) +;;; +;;; For the benefit of code-walkers we also add a macro-expansion. (Using INFO +;;; directly to get around safeguards for adding a macro-expansion for special +;;; operator.) Because :FUNCTION :KIND remains :SPECIAL-FORM, the compiler +;;; never uses the macro -- but manually calling its MACRO-FUNCTION or +;;; MACROEXPANDing TRULY-THE forms does. +(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)) + +#-sb-xc-host +(setf (info :function :macro-function 'truly-the) + (lambda (whole env) + (declare (ignore env)) + `(the ,@(cdr whole)))) ;;;; SETQ @@ -860,8 +979,8 @@ other." (compiler-error "odd number of args to SETQ: ~S" source)) (if (= len 2) (let* ((name (first things)) - (leaf (or (lexenv-find name vars) - (find-free-var name)))) + (value-form (second things)) + (leaf (or (lexenv-find name vars) (find-free-var name)))) (etypecase leaf (leaf (when (constant-p leaf) @@ -876,7 +995,11 @@ other." (compiler-style-warn "~S is being set even though it was declared to be ignored." name))) - (setq-var start next result leaf (second things))) + (if (and (global-var-p leaf) (eq :unknown (global-var-kind leaf))) + ;; For undefined variables go through SET, so that we can catch + ;; constant modifications. + (ir1-convert start next result `(set ',name ,value-form)) + (setq-var start next result leaf value-form))) (cons (aver (eq (car leaf) 'macro)) ;; FIXME: [Free] type declaration. -- APD, 2002-01-26 @@ -900,7 +1023,8 @@ other." (dest-lvar (make-lvar)) (type (or (lexenv-find var type-restrictions) (leaf-type var)))) - (ir1-convert start dest-ctran dest-lvar `(the ,type ,value)) + (ir1-convert start dest-ctran dest-lvar `(the ,(type-specifier type) + ,value)) (let ((res (make-set :var var :value dest-lvar))) (setf (lvar-dest dest-lvar) res) (setf (leaf-ever-used var) t) @@ -1017,6 +1141,7 @@ due to normal completion or a non-local exit such as THROW)." ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT, ;; and something can be done to make %ESCAPE-FUN have ;; dynamic extent too. + (declare (dynamic-extent #',cleanup-fun)) (block ,drop-thru-tag (multiple-value-bind (,next ,start ,count) (block ,exit-tag @@ -1025,6 +1150,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))))))) @@ -1049,13 +1175,7 @@ values from the first VALUES-FORM making up the first argument, etc." ;; important for simplifying compilation of ;; MV-COMBINATIONS. (make-combination fun-lvar)))) - (ir1-convert start ctran fun-lvar - (if (and (consp fun) (eq (car fun) 'function)) - fun - (let ((name (constant-global-fun-name fun))) - (if name - `(global-function ,name) - `(%coerce-callable-to-fun ,fun))))) + (ir1-convert start ctran fun-lvar (ensure-source-fun-form fun)) (setf (lvar-dest fun-lvar) node) (collect ((arg-lvars)) (let ((this-start ctran))