X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=d26e53a00ee0d4e1c359de9c9136b58fb70b97ea;hb=2b030567c502db66fce76789c4e7cc49d4962bf4;hp=a6cfd9611ac37735a4b83a99ad52455538e0442f;hpb=49e92ee57b3b01f5862d0c6fa65f521de1688941;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index a6cfd96..d26e53a 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -74,7 +74,7 @@ otherwise evaluate ELSE and return its values. ELSE defaults to NIL." (if (policy *lexenv* (= store-coverage-data 0)) nil (labels ((sub (form) - (or (gethash form *source-paths*) + (or (get-source-path form) (and (consp form) (some #'sub form))))) (or (sub form))))) @@ -475,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) @@ -575,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 @@ -585,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* ;;;; @@ -700,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)) @@ -854,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 @@ -886,8 +900,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) @@ -902,7 +916,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 :global (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 @@ -1051,6 +1069,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)))))))