X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=ce061231bb4bbdeedfd62853ea72502c738439d3;hb=78164d7ec6e90551208719b0445286eccf35c451;hp=8eb3b485b18e0786503edc55cc41527b712c43dd;hpb=71985ecfdc880e6c11a191d799313de9b4e0c12b;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 8eb3b48..ce06123 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) @@ -268,14 +270,17 @@ :format-arguments (list ,@args)))))) `(lambda (definition) (unless (list-of-length-at-least-p definition 2) - ,(make-error-form "The list ~S is too short to be a legal local macro definition." 'definition)) + ,(make-error-form + "The list ~S is too short to be a legal local macro definition." + 'definition)) (destructuring-bind (name arglist &body body) definition (unless (symbolp name) ,(make-error-form "The local macro name ~S is not a symbol." 'name)) (unless (listp arglist) - ,(make-error-form "The local macro argument list ~S is not a list." 'arglist)) - (let ((whole (gensym "WHOLE")) - (environment (gensym "ENVIRONMENT"))) + ,(make-error-form + "The local macro argument list ~S is not a list." + 'arglist)) + (with-unique-names (whole environment) (multiple-value-bind (body local-decls) (parse-defmacro arglist whole body name 'macrolet :environment environment) @@ -344,15 +349,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 +431,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 @@ -575,15 +533,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) @@ -657,7 +617,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) @@ -692,7 +653,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 @@ -748,7 +710,9 @@ ;;; many branches there are going to be. (defun ir1ize-the-or-values (type cont lexenv place) (declare (type continuation cont) (type lexenv lexenv)) - (let* ((atype (if (typep type 'ctype) type (compiler-values-specifier-type type))) + (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) @@ -756,7 +720,8 @@ (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))))) + old-ctype + (maybe-weaken-check atype (lexenv-policy lexenv))))) (when (null (find-uses cont)) (setf (continuation-asserted-type cont) new-atype) (setf (continuation-type-to-check cont) new-ctype)) @@ -849,7 +814,10 @@ (declare (type continuation start cont) (type basic-var var)) (let ((dest (make-continuation))) (ir1-convert start dest value) - (assert-continuation-type dest (leaf-type var) (lexenv-policy *lexenv*)) + (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) @@ -916,45 +884,40 @@ (setf (functional-kind fun) :cleanup) (reference-leaf start cont fun))) -;;; 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. (def-ir1-translator catch ((tag &body body) start cont) #!+sb-doc "Catch Tag Form* - Evaluates Tag and instantiates it as a catcher while the body forms are - evaluated in an implicit PROGN. If a THROW is done to Tag within the dynamic + 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. (ir1-convert start cont - (let ((exit-block (gensym "EXIT-BLOCK-"))) + (with-unique-names (exit-block) `(block ,exit-block (%within-cleanup :catch (%catch (%escape-fun ,exit-block) ,tag) ,@body))))) -;;; 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 -;;; use %CLEANUP-FUN on this to indicate that reference by -;;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of -;;; an XEP. (def-ir1-translator unwind-protect ((protected &body cleanup) start cont) #!+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 + 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 + ;; use %CLEANUP-FUN on this to indicate that reference by + ;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of + ;; an XEP. (ir1-convert start cont - (let ((cleanup-fun (gensym "CLEANUP-FUN-")) - (drop-thru-tag (gensym "DROP-THRU-TAG-")) - (exit-tag (gensym "EXIT-TAG-")) - (next (gensym "NEXT")) - (start (gensym "START")) - (count (gensym "COUNT"))) + (with-unique-names (cleanup-fun drop-thru-tag exit-tag next start count) `(flet ((,cleanup-fun () ,@cleanup nil)) ;; FIXME: If we ever get DYNAMIC-EXTENT working, then ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT, @@ -973,30 +936,28 @@ ;;;; multiple-value stuff -;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an -;;; MV-COMBINATION. -;;; -;;; If there are no arguments, then we convert to a normal -;;; combination, ensuring that a MV-COMBINATION always has at least -;;; one argument. This can be regarded as an optimization, but it is -;;; more important for simplifying compilation of MV-COMBINATIONS. (def-ir1-translator multiple-value-call ((fun &rest args) start cont) #!+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." + 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* ((fun-cont (make-continuation)) (node (if args + ;; If there are arguments, MULTIPLE-VALUE-CALL + ;; turns into an MV-COMBINATION. (make-mv-combination fun-cont) + ;; If there are no arguments, then we convert to a + ;; normal combination, ensuring that a MV-COMBINATION + ;; always has at least one argument. This can be + ;; regarded as an optimization, but it is more + ;; important for simplifying compilation of + ;; MV-COMBINATIONS. (make-combination fun-cont)))) (ir1-convert start fun-cont (if (and (consp fun) (eq (car fun) 'function)) fun `(%coerce-callable-to-fun ,fun))) (setf (continuation-dest fun-cont) node) - (assert-continuation-type fun-cont - (specifier-type '(or function symbol)) - (lexenv-policy *lexenv*)) (collect ((arg-conts)) (let ((this-start fun-cont)) (dolist (arg args)