X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=7bd2bfbee4475b47a4801a5d0f5c97162a0bba86;hb=5193965ff7688f7d748962405343ed666bf616b2;hp=5976435ea2d0d84503758fbe77273783db03d2b7;hpb=4e0ff6bb79908436adea8375d4eea46d10079cec;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 5976435..7bd2bfb 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -16,29 +16,36 @@ (def-ir1-translator progn ((&rest forms) start next result) #!+sb-doc - "Progn Form* - Evaluates each Form in order, returning the values of the last form. With no - forms, returns NIL." + "PROGN form* + +Evaluates each FORM in order, returning the values of the last form. With no +forms, returns NIL." (ir1-convert-progn-body start next result forms)) (def-ir1-translator if ((test then &optional else) start next result) #!+sb-doc - "If Predicate Then [Else] - If Predicate evaluates to non-null, evaluate Then and returns its values, - otherwise evaluate Else and return its values. Else defaults to NIL." + "IF predicate then [else] + +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)) (then-ctran (make-ctran)) (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))) @@ -48,8 +55,37 @@ (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 @@ -63,10 +99,10 @@ ;;; environment. (def-ir1-translator block ((name &rest forms) start next result) #!+sb-doc - "Block Name Form* - Evaluate the Forms as a PROGN. Within the lexical scope of the body, - (RETURN-FROM Name Value-Form) can be used to exit the form, returning the - result of Value-Form." + "BLOCK name form* + +Evaluate the FORMS as a PROGN. Within the lexical scope of the body, +RETURN-FROM can be used to exit the form." (unless (symbolp name) (compiler-error "The block name ~S is not a symbol." name)) (start-block start) @@ -87,10 +123,11 @@ (def-ir1-translator return-from ((name &optional value) start next result) #!+sb-doc - "Return-From Block-Name Value-Form - Evaluate the Value-Form, returning its values from the lexically enclosing - BLOCK Block-Name. This is constrained to be used only within the dynamic - extent of the BLOCK." + "RETURN-FROM block-name value-form + +Evaluate the VALUE-FORM, returning its values from the lexically enclosing +block BLOCK-NAME. This is constrained to be used only within the dynamic +extent of the block." ;; old comment: ;; We make NEXT start a block just so that it will have a block ;; assigned. People assume that when they pass a ctran into @@ -123,35 +160,38 @@ (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. @@ -159,13 +199,13 @@ ;;; values. (def-ir1-translator tagbody ((&rest statements) start next result) #!+sb-doc - "Tagbody {Tag | Statement}* - Define tags for used 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." + "TAGBODY {tag | statement}* + +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 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)) @@ -201,9 +241,10 @@ ;;; Emit an EXIT node without any value. (def-ir1-translator go ((tag) start next result) #!+sb-doc - "Go Tag - Transfer control to the named Tag in the lexically enclosing TAGBODY. This - is constrained to be used only within the dynamic extent of the TAGBODY." + "GO tag + +Transfer control to the named TAG in the lexically enclosing TAGBODY. This is +constrained to be used only within the dynamic extent of the TAGBODY." (ctran-starts-block next) (let* ((found (or (lexenv-find tag tags :test #'eql) (compiler-error "attempt to GO to nonexistent tag: ~S" @@ -214,7 +255,7 @@ (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 @@ -233,9 +274,10 @@ ;;; form; otherwise, the forms in the body are ignored. (def-ir1-translator eval-when ((situations &rest forms) start next result) #!+sb-doc - "EVAL-WHEN (Situation*) Form* - Evaluate the Forms in the specified Situations (any of :COMPILE-TOPLEVEL, - :LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)." + "EVAL-WHEN (situation*) form* + +Evaluate the FORMS in the specified SITUATIONS (any of :COMPILE-TOPLEVEL, +:LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)." (multiple-value-bind (ct lt e) (parse-eval-when-situations situations) (declare (ignore ct lt)) (ir1-convert-progn-body start next result (and e forms))) @@ -284,8 +326,8 @@ (unless (symbolp name) (fail "The local macro name ~S is not a symbol." name)) (when (fboundp name) - (compiler-assert-symbol-home-package-unlocked - name "binding ~A as a local macro")) + (program-assert-symbol-home-package-unlocked + context name "binding ~A as a local macro")) (unless (listp arglist) (fail "The local macro argument list ~S is not a list." arglist)) @@ -310,10 +352,11 @@ (def-ir1-translator macrolet ((definitions &rest body) start next result) #!+sb-doc - "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 the DEFMACRO style - destructuring lambda list, and the Forms evaluate to the expansion.." + "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 +destructuring lambda list, and the FORMS evaluate to the expansion." (funcall-in-macrolet-lexenv definitions (lambda (&key funs) @@ -335,10 +378,10 @@ (unless (symbolp name) (fail "The local symbol macro name ~S is not a symbol." name)) (when (or (boundp name) (eq (info :variable :kind name) :macro)) - (compiler-assert-symbol-home-package-unlocked - name "binding ~A as a local symbol-macro")) + (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. @@ -354,9 +397,10 @@ (def-ir1-translator symbol-macrolet ((macrobindings &body body) start next result) #!+sb-doc - "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form* - Define the Names as symbol macros with the given Expansions. Within the - body, references to a Name will effectively be replaced with the Expansion." + "SYMBOL-MACROLET ({(name expansion)}*) decl* form* + +Define the NAMES as symbol macros with the given EXPANSIONS. Within the +body, references to a NAME will effectively be replaced with the EXPANSION." (funcall-in-symbol-macrolet-lexenv macrobindings (lambda (&key vars) @@ -413,7 +457,7 @@ 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) @@ -430,25 +474,52 @@ (def-ir1-translator quote ((thing) start next result) #!+sb-doc - "QUOTE Value - Return Value without evaluating it." + "QUOTE value + +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)) @@ -471,9 +542,9 @@ (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 @@ -486,9 +557,10 @@ (def-ir1-translator function ((thing) start next result) #!+sb-doc - "FUNCTION Name - Return the lexically apparent definition of the function Name. Name may also - be a lambda expression." + "FUNCTION name + +Return the lexically apparent definition of the function NAME. NAME may also +be a lambda expression." (with-fun-name-leaf (leaf thing start) (reference-leaf start next result leaf))) @@ -496,17 +568,45 @@ ;;; 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-p (thing) - ;; FIXME: Once we have a marginally better CONSTANTP and - ;; CONSTANT-VALUE we can use those instead. - (and (consp thing) - (eq 'quote (car thing)) - (null (cddr thing)) - (legal-fun-name-p (cadr thing)) - t)) +(defun constant-global-fun-name (thing) + (let ((constantp (sb!xc:constantp thing))) + (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 @@ -516,40 +616,43 @@ (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) - (cond ((and (consp function) (eq (car function) 'function)) - `(%funcall ,function ,@args)) - ((constant-global-fun-name-p function) - `(%funcall (global-function ,(second function)) ,@args)) - (t - (values nil t)))) + `(%funcall ,(ensure-source-fun-form function) ,@args)) -(deftransform %coerce-callable-to-fun ((thing) (function) *) +(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* ;;;; @@ -574,7 +677,8 @@ (varify-lambda-arg name (if (eq context 'let*) nil - (names))))) + (names)) + context))) (dolist (spec bindings) (cond ((atom spec) (let ((var (get-var spec))) @@ -593,16 +697,17 @@ (vals (second spec))))))) (dolist (name (names)) (when (eq (info :variable :kind name) :macro) - (compiler-assert-symbol-home-package-unlocked - name "lexically binding symbol-macro ~A"))) + (program-assert-symbol-home-package-unlocked + :compile name "lexically binding symbol-macro ~A"))) (values (vars) (vals)))) (def-ir1-translator let ((bindings &body body) start next result) #!+sb-doc - "LET ({(Var [Value]) | Var}*) Declaration* Form* - During evaluation of the Forms, bind the Vars to the result of evaluating the - Value forms. The variables are bound in parallel after all of the Values are - evaluated." + "LET ({(var [value]) | var}*) declaration* form* + +During evaluation of the FORMS, bind the VARS to the result of evaluating the +VALUE forms. The variables are bound in parallel after all of the VALUES forms +have been evaluated." (cond ((null bindings) (ir1-translate-locally body start next result)) ((listp bindings) @@ -628,14 +733,15 @@ (def-ir1-translator let* ((bindings &body body) start next result) #!+sb-doc - "LET* ({(Var [Value]) | Var}*) Declaration* Form* - Similar to LET, but the variables are bound sequentially, allowing each Value - form to reference any of the previous Vars." + "LET* ({(var [value]) | var}*) declaration* form* + +Similar to LET, but the variables are bound sequentially, allowing each VALUE +form to reference any of the previous VARS." (if (listp bindings) (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 @@ -661,10 +767,11 @@ (def-ir1-translator locally ((&body body) start next result) #!+sb-doc - "LOCALLY Declaration* Form* - Sequentially evaluate the Forms in a lexical environment where the - the Declarations have effect. If LOCALLY is a top level form, then - the Forms are also processed as top level forms." + "LOCALLY declaration* form* + +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)) ;;;; FLET and LABELS @@ -686,11 +793,12 @@ (let ((name (first def))) (check-fun-name name) (when (fboundp name) - (compiler-assert-symbol-home-package-unlocked - name "binding ~A as a local function")) + (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)))))) @@ -722,18 +830,21 @@ (def-ir1-translator flet ((definitions &body body) start next result) #!+sb-doc - "FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form* - Evaluate the Body-Forms with some local function definitions. The bindings - do not enclose the definitions; any use of Name in the Forms will refer to - the lexically apparent function definition in the enclosing environment." + "FLET ({(name lambda-list declaration* form*)}*) declaration* body-form* + +Evaluate the BODY-FORMS with local function definitions. The bindings do +not enclose the definitions; any use of NAME in the FORMS will refer to the +lexically apparent function definition in the enclosing environment." (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (multiple-value-bind (names defs) (extract-flet-vars definitions 'flet) (let ((fvars (mapcar (lambda (n d) - (ir1-convert-lambda d - :source-name n - :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)))) @@ -741,10 +852,11 @@ (def-ir1-translator labels ((definitions &body body) start next result) #!+sb-doc - "LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form* - Evaluate the Body-Forms with some local function definitions. The bindings - enclose the new definitions, so the defined functions can call themselves or - each other." + "LABELS ({(name lambda-list declaration* form*)}*) declaration* body-form* + +Evaluate the BODY-FORMS with local function definitions. The bindings enclose +the new definitions, so the defined functions can call themselves or each +other." (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (multiple-value-bind (names defs) (extract-flet-vars definitions 'labels) @@ -766,7 +878,8 @@ (mapcar (lambda (name def) (ir1-convert-lambda def :source-name name - :debug-name (debug-name 'labels name))) + :maybe-add-debug-catch t + :debug-name (debug-name 'labels name t))) names defs)))) ;; Modify all the references to the dummy function leaves so @@ -799,6 +912,8 @@ (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)) @@ -812,26 +927,46 @@ ;;; 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 @@ -844,8 +979,8 @@ (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) @@ -853,14 +988,18 @@ (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. (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 @@ -884,7 +1023,8 @@ (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) @@ -899,9 +1039,10 @@ ;;; properties other than receiving multiple-values. (def-ir1-translator throw ((tag result) start next result-lvar) #!+sb-doc - "Throw Tag Form - Do a non-local exit, return the values of Form from the CATCH whose tag - evaluates to the same thing as Tag." + "THROW tag form + +Do a non-local exit, return the values of FORM from the CATCH whose tag is EQ +to TAG." (ir1-convert start next result-lvar `(multiple-value-call #'%throw ,tag ,result))) @@ -950,6 +1091,8 @@ ;;; function and smashes it to a :CLEANUP function, as well as ;;; referencing it. (def-ir1-translator %cleanup-fun ((name) start next result) + ;; FIXME: Should this not be :TEST #'EQUAL? What happens to + ;; (SETF FOO) here? (let ((fun (lexenv-find name funs))) (aver (lambda-p fun)) (setf (functional-kind fun) :cleanup) @@ -957,11 +1100,12 @@ (def-ir1-translator catch ((tag &body body) start next result) #!+sb-doc - "Catch Tag Form* - Evaluate TAG and instantiate it as a catcher while the body forms are - evaluated in an implicit PROGN. If a THROW is done to TAG within the dynamic - scope of the body, then control will be transferred to the end of the body - and the thrown values will be returned." + "CATCH tag form* + +Evaluate TAG and instantiate it as a catcher while the body forms are +evaluated in an implicit PROGN. If a THROW is done to TAG within the dynamic +scope of the body, then control will be transferred to the end of the body and +the thrown values will be returned." ;; We represent the possibility of the control transfer by making an ;; "escape function" that does a lexical exit, and instantiate the ;; cleanup using %WITHIN-CLEANUP. @@ -976,10 +1120,11 @@ (def-ir1-translator unwind-protect ((protected &body cleanup) start next result) #!+sb-doc - "Unwind-Protect Protected Cleanup* - Evaluate the form PROTECTED, returning its values. The CLEANUP forms are - evaluated whenever the dynamic scope of the PROTECTED form is exited (either - due to normal completion or a non-local exit such as THROW)." + "UNWIND-PROTECT protected cleanup* + +Evaluate the form PROTECTED, returning its values. The CLEANUP forms are +evaluated whenever the dynamic scope of the PROTECTED form is exited (either +due to normal completion or a non-local exit such as THROW)." ;; UNWIND-PROTECT is similar to CATCH, but hairier. We make the ;; cleanup forms into a local function so that they can be referenced ;; both in the case where we are unwound and in any local exits. We @@ -989,11 +1134,14 @@ (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 ;; dynamic extent too. + (declare (dynamic-extent #',cleanup-fun)) (block ,drop-thru-tag (multiple-value-bind (,next ,start ,count) (block ,exit-tag @@ -1002,6 +1150,7 @@ (%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))))))) @@ -1009,9 +1158,10 @@ (def-ir1-translator multiple-value-call ((fun &rest args) start next result) #!+sb-doc - "MULTIPLE-VALUE-CALL Function Values-Form* - Call FUNCTION, passing all the values of each VALUES-FORM as arguments, - values from the first VALUES-FORM making up the first argument, etc." + "MULTIPLE-VALUE-CALL function values-form* + +Call FUNCTION, passing all the values of each VALUES-FORM as arguments, +values from the first VALUES-FORM making up the first argument, etc." (let* ((ctran (make-ctran)) (fun-lvar (make-lvar)) (node (if args @@ -1025,13 +1175,7 @@ ;; important for simplifying compilation of ;; MV-COMBINATIONS. (make-combination fun-lvar)))) - (ir1-convert start ctran fun-lvar - (cond ((and (consp fun) (eq (car fun) 'function)) - fun) - ((constant-global-fun-name-p fun) - `(global-function ,(second fun))) - (t - `(%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)) @@ -1048,9 +1192,10 @@ (def-ir1-translator multiple-value-prog1 ((values-form &rest forms) start next result) #!+sb-doc - "MULTIPLE-VALUE-PROG1 Values-Form Form* - Evaluate Values-Form and then the Forms, but return all the values of - Values-Form." + "MULTIPLE-VALUE-PROG1 values-form form* + +Evaluate VALUES-FORM and then the FORMS, but return all the values of +VALUES-FORM." (let ((dummy (make-ctran))) (ctran-starts-block dummy) (ir1-convert start dummy result values-form)