X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=4c5a861faa30d3863016c7b28fb86075855263fc;hb=e38cf29945f9ff0cfbf614c0c216be60e2515175;hp=809d384dbdc28f28c9d108b5381234d8dd29abcd;hpb=24bc431a3403af05c5df601d09c0d0c27cb500b2;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 809d384..4c5a861 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) @@ -77,7 +79,7 @@ (setf (entry-cleanup entry) cleanup) (link-node-to-previous-continuation entry start) (use-continuation entry dummy) - + (let* ((env-entry (list entry cont)) (*lexenv* (make-lexenv :blocks (list (cons name env-entry)) :cleanup cleanup))) @@ -177,7 +179,7 @@ (starts dummy) (dolist (segment (rest segments)) (let* ((tag-cont (make-continuation)) - (tag (list (car segment) entry tag-cont))) + (tag (list (car segment) entry tag-cont))) (conts tag-cont) (starts tag-cont) (continuation-starts-block tag-cont) @@ -222,7 +224,7 @@ ;;; are ignored for non-top-level forms. For non-top-level forms, an ;;; eval-when specifying the :EXECUTE situation is treated as an ;;; implicit PROGN including the forms in the body of the EVAL-WHEN -;;; form; otherwise, the forms in the body are ignored. +;;; form; otherwise, the forms in the body are ignored. (def-ir1-translator eval-when ((situations &rest forms) start cont) #!+sb-doc "EVAL-WHEN (Situation*) Form* @@ -250,33 +252,46 @@ (compiler-style-warn "duplicate definitions in ~S" definitions)) (let* ((processed-definitions (mapcar definitionize-fun definitions)) (*lexenv* (make-lexenv definitionize-keyword processed-definitions))) - (funcall fun))) + (funcall fun definitionize-keyword processed-definitions))) -;;; Tweak *LEXENV* to include the DEFINITIONS from a MACROLET, then +;;; Tweak LEXENV to include the DEFINITIONS from a MACROLET, then ;;; call FUN (with no arguments). ;;; ;;; This is split off from the IR1 convert method so that it can be -;;; shared by the special-case top level MACROLET processing code. +;;; shared by the special-case top level MACROLET processing code, and +;;; further split so that the special-case MACROLET processing code in +;;; EVAL can likewise make use of it. +(defmacro macrolet-definitionize-fun (context lexenv) + (flet ((make-error-form (control &rest args) + (ecase context + (:compile `(compiler-error ,control ,@args)) + (:eval `(error 'simple-program-error + :format-control ,control + :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)) + (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"))) + (multiple-value-bind (body local-decls) + (parse-defmacro arglist whole body name 'macrolet + :environment environment) + `(,name macro . + ,(compile-in-lexenv + nil + `(lambda (,whole ,environment) + ,@local-decls + (block ,name ,body)) + ,lexenv)))))))) + (defun funcall-in-macrolet-lexenv (definitions fun) (%funcall-in-foomacrolet-lexenv - (lambda (definition) - (unless (list-of-length-at-least-p definition 2) - (compiler-error - "The list ~S is too short to be a legal local macro definition." - definition)) - (destructuring-bind (name arglist &body body) definition - (unless (symbolp name) - (compiler-error "The local macro name ~S is not a symbol." name)) - (let ((whole (gensym "WHOLE")) - (environment (gensym "ENVIRONMENT"))) - (multiple-value-bind (body local-decls) - (parse-defmacro arglist whole body name 'macrolet - :environment environment) - `(,name macro . - ,(compile nil - `(lambda (,whole ,environment) - ,@local-decls - (block ,name ,body)))))))) + (macrolet-definitionize-fun :compile (make-restricted-lexenv *lexenv*)) :funs definitions fun)) @@ -286,30 +301,42 @@ "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. The - Forms are evaluated in the null environment." - (funcall-in-macrolet-lexenv definitions - (lambda () - (ir1-translate-locally body start cont)))) + destructuring lambda list, and the Forms evaluate to the expansion.." + (funcall-in-macrolet-lexenv + definitions + (lambda (&key funs) + (declare (ignore funs)) + (ir1-translate-locally body start cont)))) -(defun funcall-in-symbol-macrolet-lexenv (definitions fun) - (%funcall-in-foomacrolet-lexenv - (lambda (definition) - (unless (proper-list-of-length-p definition 2) - (compiler-error "malformed symbol/expansion pair: ~S" definition)) +(defmacro symbol-macrolet-definitionize-fun (context) + (flet ((make-error-form (control &rest args) + (ecase context + (:compile `(compiler-error ,control ,@args)) + (:eval `(error 'simple-program-error + :format-control ,control + :format-arguments (list ,@args)))))) + `(lambda (definition) + (unless (proper-list-of-length-p definition 2) + ,(make-error-form "malformed symbol/expansion pair: ~S" 'definition)) (destructuring-bind (name expansion) definition (unless (symbolp name) - (compiler-error - "The local symbol macro name ~S is not a symbol." - name)) + ,(make-error-form + "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)))) + ,(make-error-form + "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" + 'kind 'name))) + `(,name . (MACRO . ,expansion))))))1 + +(defun funcall-in-symbol-macrolet-lexenv (definitions fun) + (%funcall-in-foomacrolet-lexenv + (symbol-macrolet-definitionize-fun :compile) :vars definitions fun)) - + (def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont) #!+sb-doc "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form* @@ -317,8 +344,8 @@ body, references to a Name will effectively be replaced with the Expansion." (funcall-in-symbol-macrolet-lexenv macrobindings - (lambda () - (ir1-translate-locally body start cont)))) + (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) @@ -410,58 +437,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) (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) - (reference-leaf start - cont - (if (legal-fun-name-p name) - (ir1-convert-lambda `(lambda ,@rest) - :source-name name) - (ir1-convert-lambda `(lambda ,@rest) - :debug-name name)))) ;;;; FUNCALL @@ -480,7 +471,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 @@ -575,10 +567,10 @@ ;;; but we don't need to worry about that within an IR1 translator, ;;; since toplevel-formness is picked off by PROCESS-TOPLEVEL-FOO ;;; forms before we hit the IR1 transform level. -(defun ir1-translate-locally (body start cont) +(defun ir1-translate-locally (body start cont &key vars funs) (declare (type list body) (type continuation start cont)) (multiple-value-bind (forms decls) (parse-body body nil) - (let ((*lexenv* (process-decls decls nil nil cont))) + (let ((*lexenv* (process-decls decls vars funs cont))) (ir1-convert-aux-bindings start cont forms nil nil)))) (def-ir1-translator locally ((&body body) start cont) @@ -629,7 +621,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) @@ -664,7 +657,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 @@ -718,28 +712,32 @@ ;;; 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 ir1ize-the-or-values (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)) - (old-type (or (lexenv-find cont type-restrictions) - *wild-type*)) - (intersects (values-types-equal-or-intersect old-type ctype)) - (int (values-type-intersection old-type ctype)) - (new (if intersects int old-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) + *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? (not (policy *lexenv* (= inhibit-warnings 3)))) ;FIXME: really OK to suppress? (compiler-warn - "The type ~S in ~S declaration conflicts with an ~ - enclosing assertion:~% ~S" - (type-specifier ctype) - name - (type-specifier old-type))) - (make-lexenv :type-restrictions `((,cont . ,new)) + "The type ~S ~A conflicts with an enclosing assertion:~% ~S" + (type-specifier atype) + place + (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 @@ -749,7 +747,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* (ir1ize-the-or-values type cont *lexenv* 'the))) + (with-continuation-type-assertion (cont (compiler-values-specifier-type type) + "in THE declaration") (ir1-convert start cont value))) ;;; This is like the THE special form, except that it believes @@ -763,7 +762,7 @@ (def-ir1-translator truly-the ((type value) start cont) #!+sb-doc (declare (inline member)) - (let ((type (values-specifier-type type)) + (let ((type (compiler-values-specifier-type type)) (old (find-uses cont))) (ir1-convert start cont value) (do-uses (use cont) @@ -815,8 +814,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) @@ -826,7 +828,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) @@ -961,8 +963,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) @@ -1011,7 +1011,11 @@ (continuation-starts-block dummy-start) (ir1-convert start dummy-start result) - (substitute-continuation-uses cont dummy-start) + (with-continuation-type-assertion + ;; FIXME: policy + (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) @@ -1025,20 +1029,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*) @@ -1046,101 +1047,3 @@ (when (or (eq first name) (eq first 'original-source-start)) (return path))))) - -;;; Warn about incompatible or illegal definitions and add the macro -;;; to the compiler environment. -;;; -;;; Someday we could check for macro arguments being incompatibly -;;; redefined. Doing this right will involve finding the old macro -;;; lambda-list and comparing it with the new one. -(def-ir1-translator %defmacro ((qname qdef lambda-list doc) start cont - :kind :function) - (let (;; QNAME is typically a quoted name. I think the idea is to - ;; let %DEFMACRO work as an ordinary function when - ;; interpreting. Whatever the reason the quote is there, we - ;; don't want it any more. -- WHN 19990603 - (name (eval qname)) - ;; QDEF should be a sharp-quoted definition. We don't want to - ;; make a function of it just yet, so we just drop the - ;; sharp-quote. - (def (progn - (aver (eq 'function (first qdef))) - (aver (proper-list-of-length-p qdef 2)) - (second qdef)))) - - (/show "doing IR1 translator for %DEFMACRO" name) - - (unless (symbolp name) - (compiler-error "The macro name ~S is not a symbol." name)) - - (ecase (info :function :kind name) - ((nil)) - (:function - (remhash name *free-funs*) - (undefine-fun-name name) - (compiler-warn - "~S is being redefined as a macro when it was ~ - previously ~(~A~) to be a function." - name - (info :function :where-from name))) - (:macro) - (:special-form - (compiler-error "The special form ~S can't be redefined as a macro." - name))) - - (setf (info :function :kind name) :macro - (info :function :where-from name) :defined - (info :function :macro-function name) (coerce def 'function)) - - (let* ((*current-path* (revert-source-path 'defmacro)) - (fun (ir1-convert-lambda def - :debug-name (debug-namify "DEFMACRO ~S" - name)))) - (setf (functional-arg-documentation fun) (eval lambda-list)) - - (ir1-convert start cont `(%%defmacro ',name ,fun ,doc))) - - (when sb!xc:*compile-print* - ;; FIXME: It would be nice to convert this, and the other places - ;; which create compiler diagnostic output prefixed by - ;; semicolons, to use some common utility which automatically - ;; prefixes all its output with semicolons. (The addition of - ;; semicolon prefixes was introduced ca. sbcl-0.6.8.10 as the - ;; "MNA compiler message patch", and implemented by modifying a - ;; bunch of output statements on a case-by-case basis, which - ;; seems unnecessarily error-prone and unclear, scattering - ;; implicit information about output style throughout the - ;; system.) Starting by rewriting COMPILER-MUMBLE to add - ;; semicolon prefixes would be a good start, and perhaps also: - ;; * Add semicolon prefixes for "FOO assembled" messages emitted - ;; when e.g. src/assembly/x86/assem-rtns.lisp is processed. - ;; * At least some debugger output messages deserve semicolon - ;; prefixes too: - ;; ** restarts table - ;; ** "Within the debugger, you can type HELP for help." - (compiler-mumble "~&; converted ~S~%" name)))) - -(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))))