X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=ab89de188e92d581f6f93bc5ce68d051ed2f2958;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=ccb901f9dc8ec10399f59262d0bdf5010f0e83f5;hpb=a52bbbda8ae06f5b501dd0d40c60d89f96d5471c;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index ccb901f..ab89de1 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -35,6 +35,8 @@ (node (make-if :test pred :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 (continuation-dest pred) node) (ir1-convert start pred test) (link-node-to-previous-continuation node pred) @@ -344,15 +346,6 @@ macrobindings (lambda (&key vars) (ir1-translate-locally body start cont :vars vars)))) - -;;; not really a special form, but.. -(def-ir1-translator declare ((&rest stuff) start cont) - (declare (ignore stuff)) - ;; We ignore START and CONT too, but we can't use DECLARE IGNORE to - ;; tell the compiler about it here, because the DEF-IR1-TRANSLATOR - ;; macro would put the DECLARE in the wrong place, so.. - start cont - (compiler-error "misplaced declaration")) ;;;; %PRIMITIVE ;;;; @@ -435,60 +428,22 @@ be a lambda expression." (if (consp thing) (case (car thing) - ((lambda) + ((lambda named-lambda instance-lambda lambda-with-lexenv) (reference-leaf start cont - (ir1-convert-lambda thing - :debug-name (debug-namify - "#'~S" thing)))) - ((setf) + (ir1-convert-lambdalike + thing + :debug-name (debug-namify "#'~S" thing) + :allow-debug-catch-tag t))) + ((setf sb!pcl::class-predicate sb!pcl::slot-accessor) (let ((var (find-lexically-apparent-fun thing "as the argument to FUNCTION"))) (reference-leaf start cont var))) - ((instance-lambda) - (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing)) - :debug-name (debug-namify "#'~S" - thing)))) - (setf (getf (functional-plist res) :fin-function) t) - (reference-leaf start cont res))) (t (compiler-error "~S is not a legal function name." thing))) (let ((var (find-lexically-apparent-fun thing "as the argument to FUNCTION"))) (reference-leaf start cont var)))) - -;;; `(NAMED-LAMBDA ,NAME ,@REST) is like `(FUNCTION (LAMBDA ,@REST)), -;;; except that the value of NAME is passed to the compiler for use in -;;; creation of debug information for the resulting function. -;;; -;;; NAME can be a legal function name or some arbitrary other thing. -;;; -;;; If NAME is a legal function name, then the caller should be -;;; planning to set (FDEFINITION NAME) to the created function. -;;; (Otherwise the debug names will be inconsistent and thus -;;; unnecessarily confusing.) -;;; -;;; Arbitrary other things are appropriate for naming things which are -;;; not the FDEFINITION of NAME. E.g. -;;; NAME = (:FLET FOO BAR) -;;; for the FLET function in -;;; (DEFUN BAR (X) -;;; (FLET ((FOO (Y) (+ X Y))) -;;; FOO)) -;;; or -;;; NAME = (:METHOD PRINT-OBJECT :AROUND (STARSHIP T)) -;;; for the function used to implement -;;; (DEFMETHOD PRINT-OBJECT :AROUND ((SS STARSHIP) STREAM) ...). -(def-ir1-translator named-lambda ((name &rest rest) start cont) - (let* ((fun (if (legal-fun-name-p name) - (ir1-convert-lambda `(lambda ,@rest) - :source-name name) - (ir1-convert-lambda `(lambda ,@rest) - :debug-name name))) - (leaf (reference-leaf start cont fun))) - (when (legal-fun-name-p name) - (assert-global-function-definition-type name fun)) - leaf)) ;;;; FUNCALL @@ -507,7 +462,8 @@ (def-ir1-translator %funcall ((function &rest args) start cont) (let ((fun-cont (make-continuation))) (ir1-convert start fun-cont function) - (assert-continuation-type fun-cont (specifier-type 'function)) + (assert-continuation-type fun-cont (specifier-type 'function) + (lexenv-policy *lexenv*)) (ir1-convert-combination-args fun-cont cont args))) ;;; This source transform exists to reduce the amount of work for the @@ -574,15 +530,17 @@ 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." - (multiple-value-bind (forms decls) (parse-body body nil) - (multiple-value-bind (vars values) (extract-let-vars bindings 'let) - (let ((fun-cont (make-continuation))) - (let* ((*lexenv* (process-decls decls vars nil cont)) - (fun (ir1-convert-lambda-body - forms vars - :debug-name (debug-namify "LET ~S" bindings)))) - (reference-leaf start fun-cont fun)) - (ir1-convert-combination-args fun-cont cont values))))) + (if (null bindings) + (ir1-translate-locally body start cont) + (multiple-value-bind (forms decls) (parse-body body nil) + (multiple-value-bind (vars values) (extract-let-vars bindings 'let) + (let ((fun-cont (make-continuation))) + (let* ((*lexenv* (process-decls decls vars nil cont)) + (fun (ir1-convert-lambda-body + forms vars + :debug-name (debug-namify "LET ~S" bindings)))) + (reference-leaf start fun-cont fun)) + (ir1-convert-combination-args fun-cont cont values)))))) (def-ir1-translator let* ((bindings &body body) start cont) @@ -656,7 +614,8 @@ (ir1-convert-lambda d :source-name n :debug-name (debug-namify - "FLET ~S" n))) + "FLET ~S" n) + :allow-debug-catch-tag t)) names defs)) (*lexenv* (make-lexenv :default (process-decls decls nil fvars cont) @@ -691,7 +650,8 @@ (ir1-convert-lambda def :source-name name :debug-name (debug-namify - "LABELS ~S" name))) + "LABELS ~S" name) + :allow-debug-catch-tag t)) names defs)))) ;; Modify all the references to the dummy function leaves so @@ -747,13 +707,18 @@ ;;; many branches there are going to be. (defun ir1ize-the-or-values (type cont lexenv place) (declare (type continuation cont) (type lexenv lexenv)) - (let* ((ctype (if (typep type 'ctype) type (compiler-values-specifier-type type))) - (old-type (or (lexenv-find cont type-restrictions) - *wild-type*)) - (intersects (values-types-equal-or-intersect old-type ctype)) - (new (values-type-intersection old-type ctype))) + (let* ((atype (if (typep type 'ctype) type (compiler-values-specifier-type type))) + (old-atype (or (lexenv-find cont type-restrictions) + *wild-type*)) + (old-ctype (or (lexenv-find cont weakend-type-restrictions) + *wild-type*)) + (intersects (values-types-equal-or-intersect old-atype atype)) + (new-atype (values-type-intersection old-atype atype)) + (new-ctype (values-type-intersection + old-ctype (maybe-weaken-check atype (lexenv-policy lexenv))))) (when (null (find-uses cont)) - (setf (continuation-asserted-type cont) new)) + (setf (continuation-asserted-type cont) new-atype) + (setf (continuation-type-to-check cont) new-ctype)) (when (and (not intersects) ;; FIXME: Is it really right to look at *LEXENV* here, ;; instead of looking at the LEXENV argument? Why? @@ -761,10 +726,11 @@ (= inhibit-warnings 3)))) ;FIXME: really OK to suppress? (compiler-warn "The type ~S ~A conflicts with an enclosing assertion:~% ~S" - (type-specifier ctype) + (type-specifier atype) place - (type-specifier old-type))) - (make-lexenv :type-restrictions `((,cont . ,new)) + (type-specifier old-atype))) + (make-lexenv :type-restrictions `((,cont . ,new-atype)) + :weakend-type-restrictions `((,cont . ,new-ctype)) :default lexenv))) ;;; Assert that FORM evaluates to the specified type (which may be a @@ -841,8 +807,11 @@ (defun setq-var (start cont var value) (declare (type continuation start cont) (type basic-var var)) (let ((dest (make-continuation))) - (setf (continuation-asserted-type dest) (leaf-type var)) (ir1-convert start dest value) + (assert-continuation-type dest + (or (lexenv-find var type-restrictions) + (leaf-type var)) + (lexenv-policy *lexenv*)) (let ((res (make-set :var var :value dest))) (setf (continuation-dest dest) res) (setf (leaf-ever-used var) t) @@ -852,7 +821,7 @@ ;;;; CATCH, THROW and UNWIND-PROTECT -;;; We turn THROW into a multiple-value-call of a magical function, +;;; We turn THROW into a MULTIPLE-VALUE-CALL of a magical function, ;;; since as as far as IR1 is concerned, it has no interesting ;;; properties other than receiving multiple-values. (def-ir1-translator throw ((tag result) start cont) @@ -987,8 +956,6 @@ fun `(%coerce-callable-to-fun ,fun))) (setf (continuation-dest fun-cont) node) - (assert-continuation-type fun-cont - (specifier-type '(or function symbol))) (collect ((arg-conts)) (let ((this-start fun-cont)) (dolist (arg args) @@ -1038,6 +1005,7 @@ (ir1-convert start dummy-start result) (with-continuation-type-assertion + ;; FIXME: policy (cont (continuation-asserted-type dummy-start) "of the first form") (substitute-continuation-uses cont dummy-start)) @@ -1054,20 +1022,17 @@ ;;;; interface to defining macros -;;;; FIXME: -;;;; classic CMU CL comment: -;;;; DEFMACRO and DEFUN expand into calls to %DEFxxx functions -;;;; so that we get a chance to see what is going on. We define -;;;; IR1 translators for these functions which look at the -;;;; definition and then generate a call to the %%DEFxxx function. -;;;; Alas, this implementation doesn't do the right thing for -;;;; non-toplevel uses of these forms, so this should probably -;;;; be changed to use EVAL-WHEN instead. - -;;; Return a new source path with any stuff intervening between the -;;; current path and the first form beginning with NAME stripped off. -;;; This is used to hide the guts of DEFmumble macros to prevent -;;; annoying error messages. +;;; Old CMUCL comment: +;;; +;;; Return a new source path with any stuff intervening between the +;;; current path and the first form beginning with NAME stripped +;;; off. This is used to hide the guts of DEFmumble macros to +;;; prevent annoying error messages. +;;; +;;; Now that we have implementations of DEFmumble macros in terms of +;;; EVAL-WHEN, this function is no longer used. However, it might be +;;; worth figuring out why it was used, and maybe doing analogous +;;; munging to the functions created in the expanders for the macros. (defun revert-source-path (name) (do ((path *current-path* (cdr path))) ((null path) *current-path*) @@ -1075,28 +1040,3 @@ (when (or (eq first name) (eq first 'original-source-start)) (return path))))) - -(def-ir1-translator %define-compiler-macro ((name def lambda-list doc) - start cont - :kind :function) - (let ((name (eval name)) - (def (second def))) ; We don't want to make a function just yet... - - (when (eq (info :function :kind name) :special-form) - (compiler-error "attempt to define a compiler-macro for special form ~S" - name)) - - (setf (info :function :compiler-macro-function name) - (coerce def 'function)) - - (let* ((*current-path* (revert-source-path 'define-compiler-macro)) - (fun (ir1-convert-lambda def - :debug-name (debug-namify - "DEFINE-COMPILER-MACRO ~S" - name)))) - (setf (functional-arg-documentation fun) (eval lambda-list)) - - (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc))) - - (when sb!xc:*compile-print* - (compiler-mumble "~&; converted ~S~%" name))))