X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir1-translators.lisp;h=cb8e3a32c4309e08a1418cd9ded3096ebe8b2c89;hb=e1ba5a0d68ff8d4c8e688cd6a951aea1d56b1b61;hp=50efcc3eb1ee3caaab0c369df4399aa2855950c9;hpb=29a9ccc860532b32c566aec095f570e999a9c52c;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 50efcc3..cb8e3a3 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -12,7 +12,7 @@ (in-package "SB!C") -;;;; control special forms +;;;; special forms for control (def-ir1-translator progn ((&rest forms) start cont) #!+sb-doc @@ -84,7 +84,6 @@ (push env-entry (continuation-lexenv-uses cont)) (ir1-convert-progn-body dummy cont forms)))) - (def-ir1-translator return-from ((name &optional value) start cont) #!+sb-doc "Return-From Block-Name Value-Form @@ -244,7 +243,7 @@ definitions fun) (declare (type function definitionize-fun fun)) - (declare (type (member :variables :functions) definitionize-keyword)) + (declare (type (member :vars :funs) definitionize-keyword)) (declare (type list definitions)) (unless (= (length definitions) (length (remove-duplicates definitions :key #'first))) @@ -278,7 +277,7 @@ `(lambda (,whole ,environment) ,@local-decls (block ,name ,body)))))))) - :functions + :funs definitions fun)) @@ -303,8 +302,11 @@ (compiler-error "The local symbol macro name ~S is not a symbol." name)) + (let ((kind (info :variable :kind name))) + (when (member kind '(:special :constant)) + (compiler-error "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" kind name))) `(,name . (MACRO . ,expansion)))) - :variables + :vars definitions fun)) @@ -356,39 +358,32 @@ ;;; VOP or %VOP.. -- WHN 2001-06-11 ;;; FIXME: Look at doing this ^, it doesn't look too hard actually. (def-ir1-translator %primitive ((name &rest args) start cont) - (unless (symbolp name) - (compiler-error "internal error: Primitive name ~S is not a symbol." name)) + (declare (type symbol name)) (let* ((template (or (gethash name *backend-template-names*) - (compiler-error - "internal error: Primitive name ~A is not defined." - name))) + (bug "undefined primitive ~A" name))) (required (length (template-arg-types template))) (info (template-info-arg-count template)) (min (+ required info)) (nargs (length args))) (if (template-more-args-type template) (when (< nargs min) - (compiler-error "internal error: Primitive ~A was called ~ - with ~R argument~:P, ~ - but wants at least ~R." - name - nargs - min)) + (bug "Primitive ~A was called with ~R argument~:P, ~ + but wants at least ~R." + name + nargs + min)) (unless (= nargs min) - (compiler-error "internal error: Primitive ~A was called ~ - with ~R argument~:P, ~ - but wants exactly ~R." - name - nargs - min))) + (bug "Primitive ~A was called with ~R argument~:P, ~ + but wants exactly ~R." + name + nargs + min))) (when (eq (template-result-types template) :conditional) - (compiler-error - "%PRIMITIVE was used with a conditional template.")) + (bug "%PRIMITIVE was used with a conditional template.")) (when (template-more-results-type template) - (compiler-error - "%PRIMITIVE was used with an unknown values template.")) + (bug "%PRIMITIVE was used with an unknown values template.")) (ir1-convert start cont @@ -441,36 +436,39 @@ ;;; except that the value of NAME is passed to the compiler for use in ;;; creation of debug information for the resulting function. ;;; -;;; Eventually we might use this for NAME values other than legal -;;; function names, e.g. +;;; 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 (STARSHIP T)) +;;; NAME = (:METHOD PRINT-OBJECT :AROUND (STARSHIP T)) ;;; for the function used to implement -;;; (DEFMETHOD PRINT-OBJECT ((SS STARSHIP) STREAM) ...). -;;; However, as of this writing (while defining/implementing it in -;;; sbcl-0.pre7.108) NAME is always a legal function name. -;;; -;;; 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.) +;;; (DEFMETHOD PRINT-OBJECT :AROUND ((SS STARSHIP) STREAM) ...). (def-ir1-translator named-lambda ((name &rest rest) start cont) (reference-leaf start cont - (ir1-convert-lambda `(lambda ,@rest) - :source-name name))) + (if (legal-fun-name-p name) + (ir1-convert-lambda `(lambda ,@rest) + :source-name name) + (ir1-convert-lambda `(lambda ,@rest) + :debug-name name)))) ;;;; FUNCALL ;;; FUNCALL is implemented on %FUNCALL, which can only call functions ;;; (not symbols). %FUNCALL is used directly in some places where the ;;; call should always be open-coded even if FUNCALL is :NOTINLINE. -(deftransform funcall ((function &rest args) * * :when :both) +(deftransform funcall ((function &rest args) * *) (let ((arg-names (make-gensym-list (length args)))) `(lambda (function ,@arg-names) (%funcall ,(if (csubtypep (continuation-type function) @@ -495,7 +493,6 @@ (values nil t))) (deftransform %coerce-callable-to-fun ((thing) (function) * - :when :both :important t) "optimize away possible call to FDEFINITION at runtime" 'thing) @@ -506,16 +503,16 @@ ;;;; any pervasive declarations also affect the evaluation of the ;;;; arguments.) -;;; Given a list of binding specifiers in the style of Let, return: +;;; Given a list of binding specifiers in the style of LET, return: ;;; 1. The list of var structures for the variables bound. ;;; 2. The initial value form for each variable. ;;; ;;; The variable names are checked for legality and globally special ;;; variables are marked as such. Context is the name of the form, for ;;; error reporting purposes. -(declaim (ftype (function (list symbol) (values list list list)) - extract-let-variables)) -(defun extract-let-variables (bindings context) +(declaim (ftype (function (list symbol) (values list list)) + extract-let-vars)) +(defun extract-let-vars (bindings context) (collect ((vars) (vals) (names)) @@ -528,7 +525,7 @@ (cond ((atom spec) (let ((var (get-var spec))) (vars var) - (names (cons spec var)) + (names spec) (vals nil))) (t (unless (proper-list-of-length-p spec 1 2) @@ -541,7 +538,7 @@ (names name) (vals (second spec))))))) - (values (vars) (vals) (names)))) + (values (vars) (vals)))) (def-ir1-translator let ((bindings &body body) start cont) @@ -550,14 +547,15 @@ 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) (sb!sys:parse-body body nil) - (multiple-value-bind (vars values) (extract-let-variables bindings 'let) - (let* ((*lexenv* (process-decls decls vars nil cont)) - (fun-cont (make-continuation)) - (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))))) + (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) @@ -565,8 +563,8 @@ "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." - (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) - (multiple-value-bind (vars values) (extract-let-variables bindings 'let*) + (multiple-value-bind (forms decls) (parse-body body nil) + (multiple-value-bind (vars values) (extract-let-vars bindings 'let*) (let ((*lexenv* (process-decls decls vars nil cont))) (ir1-convert-aux-bindings start cont forms vars values))))) @@ -579,7 +577,7 @@ ;;; forms before we hit the IR1 transform level. (defun ir1-translate-locally (body start cont) (declare (type list body) (type continuation start cont)) - (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) + (multiple-value-bind (forms decls) (parse-body body nil) (let ((*lexenv* (process-decls decls nil nil cont))) (ir1-convert-aux-bindings start cont forms nil nil)))) @@ -599,9 +597,8 @@ ;;; ;;; The function names are checked for legality. CONTEXT is the name ;;; of the form, for error reporting. -(declaim (ftype (function (list symbol) (values list list)) - extract-flet-variables)) -(defun extract-flet-variables (definitions context) +(declaim (ftype (function (list symbol) (values list list)) extract-flet-vars)) +(defun extract-flet-vars (definitions context) (collect ((names) (defs)) (dolist (def definitions) @@ -611,7 +608,7 @@ (let ((name (first def))) (check-fun-name name) (names name) - (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr def)) + (multiple-value-bind (forms decls) (parse-body (cddr def)) (defs `(lambda ,(second def) ,@decls (block ,(fun-name-block-name name) @@ -625,9 +622,9 @@ 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." - (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) + (multiple-value-bind (forms decls) (parse-body body nil) (multiple-value-bind (names defs) - (extract-flet-variables definitions 'flet) + (extract-flet-vars definitions 'flet) (let* ((fvars (mapcar (lambda (n d) (ir1-convert-lambda d :source-name n @@ -636,7 +633,7 @@ names defs)) (*lexenv* (make-lexenv :default (process-decls decls nil fvars cont) - :functions (pairlis names fvars)))) + :funs (pairlis names fvars)))) (ir1-convert-progn-body start cont forms))))) (def-ir1-translator labels ((definitions &body body) start cont) @@ -645,9 +642,9 @@ 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." - (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) + (multiple-value-bind (forms decls) (parse-body body nil) (multiple-value-bind (names defs) - (extract-flet-variables definitions 'labels) + (extract-flet-vars definitions 'labels) (let* (;; dummy LABELS functions, to be used as placeholders ;; during construction of real LABELS functions (placeholder-funs (mapcar (lambda (name) @@ -662,8 +659,7 @@ ;; the real LABELS functions, compiled in a LEXENV which ;; includes the dummy LABELS functions (real-funs - (let ((*lexenv* (make-lexenv - :functions placeholder-fenv))) + (let ((*lexenv* (make-lexenv :funs placeholder-fenv))) (mapcar (lambda (name def) (ir1-convert-lambda def :source-name name @@ -685,7 +681,7 @@ ;; placeholder used earlier) so that if the ;; lexical environment is used for inline ;; expansion we'll get the right functions. - :functions (pairlis names real-funs)))) + :funs (pairlis names real-funs)))) (ir1-convert-progn-body start cont forms)))))) ;;;; the THE special operator, and friends @@ -722,9 +718,9 @@ ;;; We make this work by getting USE-CONTINUATION to do the unioning ;;; across COND branches. We can't do it here, since we don't know how ;;; many branches there are going to be. -(defun do-the-stuff (type cont lexenv name) +(defun ir1ize-the-or-values (type cont lexenv place) (declare (type continuation cont) (type lexenv lexenv)) - (let* ((ctype (values-specifier-type type)) + (let* ((ctype (if (typep type 'ctype) type (values-specifier-type type))) (old-type (or (lexenv-find cont type-restrictions) *wild-type*)) (intersects (values-types-equal-or-intersect old-type ctype)) @@ -733,13 +729,15 @@ (when (null (find-uses cont)) (setf (continuation-asserted-type cont) new)) (when (and (not intersects) + ;; FIXME: Is it really right to look at *LEXENV* here, + ;; instead of looking at the LEXENV argument? Why? (not (policy *lexenv* (= inhibit-warnings 3)))) ;FIXME: really OK to suppress? (compiler-warn - "The type ~S in ~S declaration conflicts with an ~ + "The type ~S ~A conflicts with an ~ enclosing assertion:~% ~S" (type-specifier ctype) - name + place (type-specifier old-type))) (make-lexenv :type-restrictions `((,cont . ,new)) :default lexenv))) @@ -751,7 +749,8 @@ ;;; this didn't seem to expand into an assertion, at least for ALIEN ;;; values. Check that SBCL doesn't have this problem. (def-ir1-translator the ((type value) start cont) - (let ((*lexenv* (do-the-stuff type cont *lexenv* 'the))) + (with-continuation-type-assertion (cont (values-specifier-type type) + "in THE declaration") (ir1-convert start cont value))) ;;; This is like the THE special form, except that it believes @@ -774,17 +773,17 @@ ;;;; SETQ -;;; If there is a definition in LEXENV-VARIABLES, just set that, -;;; otherwise look at the global information. If the name is for a -;;; constant, then error out. +;;; If there is a definition in LEXENV-VARS, just set that, otherwise +;;; look at the global information. If the name is for a constant, +;;; then error out. (def-ir1-translator setq ((&whole source &rest things) start cont) (let ((len (length things))) (when (oddp len) (compiler-error "odd number of args to SETQ: ~S" source)) (if (= len 2) (let* ((name (first things)) - (leaf (or (lexenv-find name variables) - (find-free-variable name)))) + (leaf (or (lexenv-find name vars) + (find-free-var name)))) (etypecase leaf (leaf (when (constant-p leaf) @@ -799,7 +798,7 @@ (compiler-style-warn "~S is being set even though it was declared to be ignored." name))) - (set-variable start cont leaf (second things))) + (setq-var start cont leaf (second things))) (cons (aver (eq (car leaf) 'MACRO)) (ir1-convert start cont `(setf ,(cdr leaf) ,(second things)))) @@ -814,7 +813,7 @@ ;;; This is kind of like REFERENCE-LEAF, but we generate a SET node. ;;; This should only need to be called in SETQ. -(defun set-variable (start cont var value) +(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)) @@ -880,7 +879,7 @@ ;;; function and smashes it to a :CLEANUP function, as well as ;;; referencing it. (def-ir1-translator %cleanup-fun ((name) start cont) - (let ((fun (lexenv-find name functions))) + (let ((fun (lexenv-find name funs))) (aver (lambda-p fun)) (setf (functional-kind fun) :cleanup) (reference-leaf start cont fun))) @@ -1013,7 +1012,10 @@ (continuation-starts-block dummy-start) (ir1-convert start dummy-start result) - (substitute-continuation-uses cont dummy-start) + (with-continuation-type-assertion + (cont (continuation-asserted-type dummy-start) + "of the first form") + (substitute-continuation-uses cont dummy-start)) (continuation-starts-block dummy-result) (ir1-convert-progn-body dummy-start dummy-result forms)