\f
;;;; special forms for control
-(def-ir1-translator progn ((&rest forms) start cont)
+(def-ir1-translator progn ((&rest forms) start next result)
#!+sb-doc
"Progn Form*
Evaluates each Form in order, returning the values of the last form. With no
forms, returns NIL."
- (ir1-convert-progn-body start cont forms))
+ (ir1-convert-progn-body start next result forms))
-(def-ir1-translator if ((test then &optional else) start cont)
+(def-ir1-translator if ((test then &optional else) start next result)
#!+sb-doc
"If Predicate Then [Else]
If Predicate evaluates to non-null, evaluate Then and returns its values,
otherwise evaluate Else and return its values. Else defaults to NIL."
- (let* ((pred (make-continuation))
- (then-cont (make-continuation))
- (then-block (continuation-starts-block then-cont))
- (else-cont (make-continuation))
- (else-block (continuation-starts-block else-cont))
- (dummy-cont (make-continuation))
- (node (make-if :test pred
+ (let* ((pred-ctran (make-ctran))
+ (pred-lvar (make-lvar))
+ (then-ctran (make-ctran))
+ (then-block (ctran-starts-block then-ctran))
+ (else-ctran (make-ctran))
+ (else-block (ctran-starts-block else-ctran))
+ (node (make-if :test pred-lvar
: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)
- (use-continuation node dummy-cont)
+ (setf (lvar-dest pred-lvar) node)
+ (ir1-convert start pred-ctran pred-lvar test)
+ (link-node-to-previous-ctran node pred-ctran)
- (let ((start-block (continuation-block pred)))
+ (let ((start-block (ctran-block pred-ctran)))
(setf (block-last start-block) node)
- (continuation-starts-block cont)
+ (ctran-starts-block next)
(link-blocks start-block then-block)
(link-blocks start-block else-block))
- (ir1-convert then-cont cont then)
- (ir1-convert else-cont cont else)))
+ (ir1-convert then-ctran next result then)
+ (ir1-convert else-ctran next result else)))
\f
;;;; BLOCK and TAGBODY
;;; body in the modified environment. We make CONT start a block now,
;;; since if it was done later, the block would be in the wrong
;;; environment.
-(def-ir1-translator block ((name &rest forms) start cont)
+(def-ir1-translator block ((name &rest forms) start next result)
#!+sb-doc
"Block Name Form*
Evaluate the Forms as a PROGN. Within the lexical scope of the body,
result of Value-Form."
(unless (symbolp name)
(compiler-error "The block name ~S is not a symbol." name))
- (continuation-starts-block cont)
- (let* ((dummy (make-continuation))
+ (ctran-starts-block next)
+ (let* ((dummy (make-ctran))
(entry (make-entry))
(cleanup (make-cleanup :kind :block
:mess-up entry)))
(push entry (lambda-entries (lexenv-lambda *lexenv*)))
(setf (entry-cleanup entry) cleanup)
- (link-node-to-previous-continuation entry start)
- (use-continuation entry dummy)
+ (link-node-to-previous-ctran entry start)
+ (use-ctran entry dummy)
- (let* ((env-entry (list entry cont))
+ (let* ((env-entry (list entry next result))
(*lexenv* (make-lexenv :blocks (list (cons name env-entry))
:cleanup cleanup)))
- (push env-entry (continuation-lexenv-uses cont))
- (ir1-convert-progn-body dummy cont forms))))
+ (ir1-convert-progn-body dummy next result forms))))
-(def-ir1-translator return-from ((name &optional value) start cont)
+(def-ir1-translator return-from ((name &optional value) start next result)
#!+sb-doc
"Return-From Block-Name Value-Form
Evaluate the Value-Form, returning its values from the lexically enclosing
;; BLOCK-HOME-LAMBDA-OR-NULL) more obscure, and it might be better
;; to get rid of it, perhaps using a special placeholder value
;; to indicate the orphanedness of the code.
- (continuation-starts-block cont)
+ (declare (ignore result))
+ (ctran-starts-block next)
(let* ((found (or (lexenv-find name blocks)
(compiler-error "return for unknown block: ~S" name)))
- (value-cont (make-continuation))
+ (value-ctran (make-ctran))
+ (value-lvar (make-lvar))
(entry (first found))
(exit (make-exit :entry entry
- :value value-cont)))
+ :value value-lvar)))
(push exit (entry-exits entry))
- (setf (continuation-dest value-cont) exit)
- (ir1-convert start value-cont value)
- (link-node-to-previous-continuation exit value-cont)
- (let ((home-lambda (continuation-home-lambda-or-null start)))
+ (setf (lvar-dest value-lvar) exit)
+ (ir1-convert start value-ctran value-lvar value)
+ (link-node-to-previous-ctran exit value-ctran)
+ (let ((home-lambda (ctran-home-lambda-or-null start)))
(when home-lambda
(push entry (lambda-calls-or-closes home-lambda))))
- (use-continuation exit (second found))))
+ (use-continuation exit (second found) (third found))))
;;; Return a list of the segments of a TAGBODY. Each segment looks
;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
;;; each tag, building up the tag list for LEXENV-TAGS as we go.
;;; Finally, convert each segment with the precomputed Start and Cont
;;; values.
-(def-ir1-translator tagbody ((&rest statements) start cont)
+(def-ir1-translator tagbody ((&rest statements) start next result)
#!+sb-doc
"Tagbody {Tag | Statement}*
Define tags for used with GO. The Statements are evaluated in order
to the next statement following that tag. A Tag must an integer or a
symbol. A statement must be a list. Other objects are illegal within the
body."
- (continuation-starts-block cont)
- (let* ((dummy (make-continuation))
+ (ctran-starts-block next)
+ (let* ((dummy (make-ctran))
(entry (make-entry))
(segments (parse-tagbody statements))
(cleanup (make-cleanup :kind :tagbody
:mess-up entry)))
(push entry (lambda-entries (lexenv-lambda *lexenv*)))
(setf (entry-cleanup entry) cleanup)
- (link-node-to-previous-continuation entry start)
- (use-continuation entry dummy)
+ (link-node-to-previous-ctran entry start)
+ (use-ctran entry dummy)
(collect ((tags)
(starts)
- (conts))
+ (ctrans))
(starts dummy)
(dolist (segment (rest segments))
- (let* ((tag-cont (make-continuation))
- (tag (list (car segment) entry tag-cont)))
- (conts tag-cont)
- (starts tag-cont)
- (continuation-starts-block tag-cont)
- (tags tag)
- (push (cdr tag) (continuation-lexenv-uses tag-cont))))
- (conts cont)
+ (let* ((tag-ctran (make-ctran))
+ (tag (list (car segment) entry tag-ctran)))
+ (ctrans tag-ctran)
+ (starts tag-ctran)
+ (ctran-starts-block tag-ctran)
+ (tags tag)))
+ (ctrans next)
(let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))
- (mapc (lambda (segment start cont)
- (ir1-convert-progn-body start cont (rest segment)))
- segments (starts) (conts))))))
+ (mapc (lambda (segment start end)
+ (ir1-convert-progn-body start end
+ (when (eq end next) result)
+ (rest segment)))
+ segments (starts) (ctrans))))))
;;; Emit an EXIT node without any value.
-(def-ir1-translator go ((tag) start cont)
+(def-ir1-translator go ((tag) start next result)
#!+sb-doc
"Go Tag
Transfer control to the named Tag in the lexically enclosing TAGBODY. This
is constrained to be used only within the dynamic extent of the TAGBODY."
- (continuation-starts-block cont)
+ (ctran-starts-block next)
(let* ((found (or (lexenv-find tag tags :test #'eql)
(compiler-error "attempt to GO to nonexistent tag: ~S"
tag)))
(entry (first found))
(exit (make-exit :entry entry)))
(push exit (entry-exits entry))
- (link-node-to-previous-continuation exit start)
- (let ((home-lambda (continuation-home-lambda-or-null start)))
+ (link-node-to-previous-ctran exit start)
+ (let ((home-lambda (ctran-home-lambda-or-null start)))
(when home-lambda
(push entry (lambda-calls-or-closes home-lambda))))
- (use-continuation exit (second found))))
+ (use-ctran exit (second found))))
\f
;;;; translators for compiler-magic special forms
;;; 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.
-(def-ir1-translator eval-when ((situations &rest forms) start cont)
+(def-ir1-translator eval-when ((situations &rest forms) start next result)
#!+sb-doc
"EVAL-WHEN (Situation*) Form*
Evaluate the Forms in the specified Situations (any of :COMPILE-TOPLEVEL,
:LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)."
(multiple-value-bind (ct lt e) (parse-eval-when-situations situations)
(declare (ignore ct lt))
- (ir1-convert-progn-body start cont (and e forms)))
+ (ir1-convert-progn-body start next result (and e forms)))
(values))
;;; common logic for MACROLET and SYMBOL-MACROLET
;;; 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)
+(defun macrolet-definitionize-fun (context lexenv)
+ (flet ((fail (control &rest args)
(ecase context
- (:compile `(compiler-error ,control ,@args))
- (:eval `(error 'simple-program-error
- :format-control ,control
- :format-arguments (list ,@args))))))
- `(lambda (definition)
+ (:compile (apply #'compiler-error control args))
+ (:eval (error 'simple-program-error
+ :format-control control
+ :format-arguments 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))
+ (fail "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))
- (with-unique-names (whole 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)
+ (unless (symbolp name)
+ (fail "The local macro name ~S is not a symbol." name))
+ (unless (listp arglist)
+ (fail "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)
+ `(,name macro .
+ ,(compile-in-lexenv
+ nil
+ `(lambda (,whole ,environment)
+ ,@local-decls
+ ,body)
+ lexenv))))))))
+
+(defun funcall-in-macrolet-lexenv (definitions fun context)
(%funcall-in-foomacrolet-lexenv
- (macrolet-definitionize-fun :compile (make-restricted-lexenv *lexenv*))
+ (macrolet-definitionize-fun context (make-restricted-lexenv *lexenv*))
:funs
definitions
fun))
-(def-ir1-translator macrolet ((definitions &rest body) start cont)
+(def-ir1-translator macrolet ((definitions &rest body) start next result)
#!+sb-doc
"MACROLET ({(Name Lambda-List Form*)}*) Body-Form*
Evaluate the Body-Forms in an environment with the specified local macros
definitions
(lambda (&key funs)
(declare (ignore funs))
- (ir1-translate-locally body start cont))))
+ (ir1-translate-locally body start next result))
+ :compile))
-(defmacro symbol-macrolet-definitionize-fun (context)
- (flet ((make-error-form (control &rest args)
+(defun symbol-macrolet-definitionize-fun (context)
+ (flet ((fail (control &rest args)
(ecase context
- (:compile `(compiler-error ,control ,@args))
- (:eval `(error 'simple-program-error
- :format-control ,control
- :format-arguments (list ,@args))))))
- `(lambda (definition)
+ (:compile (apply #'compiler-error control args))
+ (:eval (error 'simple-program-error
+ :format-control control
+ :format-arguments 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)
- ,(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))
- ,(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)
+ (fail "malformed symbol/expansion pair: ~S" definition))
+ (destructuring-bind (name expansion) definition
+ (unless (symbolp name)
+ (fail "The local symbol macro name ~S is not a symbol." name))
+ (let ((kind (info :variable :kind name)))
+ (when (member kind '(:special :constant))
+ (fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S"
+ kind name)))
+ `(,name . (MACRO . ,expansion))))))
+
+(defun funcall-in-symbol-macrolet-lexenv (definitions fun context)
(%funcall-in-foomacrolet-lexenv
- (symbol-macrolet-definitionize-fun :compile)
+ (symbol-macrolet-definitionize-fun context)
:vars
definitions
fun))
-(def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont)
+(def-ir1-translator symbol-macrolet
+ ((macrobindings &body body) start next result)
#!+sb-doc
"SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
Define the Names as symbol macros with the given Expansions. Within the
(funcall-in-symbol-macrolet-lexenv
macrobindings
(lambda (&key vars)
- (ir1-translate-locally body start cont :vars vars))))
+ (ir1-translate-locally body start next result :vars vars))
+ :compile))
\f
;;;; %PRIMITIVE
;;;;
;;; BACKEND-TEMPLATE-NAMES to BACKEND-VOPS, and rename %PRIMITIVE to
;;; 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)
+(def-ir1-translator %primitive ((name &rest args) start next result)
(declare (type symbol name))
(let* ((template (or (gethash name *backend-template-names*)
(bug "undefined primitive ~A" name)))
(when (template-more-results-type template)
(bug "%PRIMITIVE was used with an unknown values template."))
- (ir1-convert start
- cont
+ (ir1-convert start next result
`(%%primitive ',template
',(eval-info-args
(subseq args required min))
\f
;;;; QUOTE
-(def-ir1-translator quote ((thing) start cont)
+(def-ir1-translator quote ((thing) start next result)
#!+sb-doc
"QUOTE Value
Return Value without evaluating it."
- (reference-constant start cont thing))
+ (reference-constant start next result thing))
\f
;;;; FUNCTION and NAMED-LAMBDA
-
-(def-ir1-translator function ((thing) start cont)
- #!+sb-doc
- "FUNCTION Name
- Return the lexically apparent definition of the function Name. Name may also
- be a lambda expression."
+(defun fun-name-leaf (thing)
(if (consp thing)
(cond
((member (car thing)
'(lambda named-lambda instance-lambda lambda-with-lexenv))
- (reference-leaf start
- cont
- (ir1-convert-lambdalike
+ (ir1-convert-lambdalike
thing
:debug-name (debug-namify "#'~S" thing)
- :allow-debug-catch-tag t)))
+ :allow-debug-catch-tag t))
((legal-fun-name-p thing)
- (let ((var (find-lexically-apparent-fun
- thing "as the argument to FUNCTION")))
- (reference-leaf start cont var)))
+ (find-lexically-apparent-fun
+ thing "as the argument to FUNCTION"))
(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))))
+ (find-lexically-apparent-fun
+ thing "as the argument to FUNCTION")))
+
+(def-ir1-translator function ((thing) start next result)
+ #!+sb-doc
+ "FUNCTION Name
+ Return the lexically apparent definition of the function Name. Name may also
+ be a lambda expression."
+ (reference-leaf start next result (fun-name-leaf thing)))
\f
;;;; FUNCALL
(deftransform funcall ((function &rest args) * *)
(let ((arg-names (make-gensym-list (length args))))
`(lambda (function ,@arg-names)
- (%funcall ,(if (csubtypep (continuation-type function)
+ (%funcall ,(if (csubtypep (lvar-type function)
(specifier-type 'function))
'function
'(%coerce-callable-to-fun function))
,@arg-names))))
-(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)
- (lexenv-policy *lexenv*))
- (ir1-convert-combination-args fun-cont cont args)))
+(def-ir1-translator %funcall ((function &rest args) start next result)
+ (if (and (consp function) (eq (car function) 'function))
+ (ir1-convert start next result
+ `(,(fun-name-leaf (second function)) ,@args))
+ (let ((fun-ctran (make-ctran))
+ (fun-lvar (make-lvar)))
+ (ir1-convert start fun-ctran fun-lvar `(the function ,function))
+ (ir1-convert-combination-args fun-ctran fun-lvar next result args))))
;;; This source transform exists to reduce the amount of work for the
;;; compiler. If the called function is a FUNCTION form, then convert
(values (vars) (vals))))
-(def-ir1-translator let ((bindings &body body)
- start cont)
+(def-ir1-translator let ((bindings &body body) start next result)
#!+sb-doc
"LET ({(Var [Value]) | Var}*) Declaration* Form*
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."
(if (null bindings)
- (ir1-translate-locally body start cont)
- (multiple-value-bind (forms decls) (parse-body body nil)
+ (ir1-translate-locally body start next result)
+ (multiple-value-bind (forms decls)
+ (parse-body body :doc-string-allowed 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))))))
+ (binding* ((fun-ctran (make-ctran))
+ (fun-lvar (make-lvar))
+ ((next result)
+ (processing-decls (decls vars nil next result)
+ (let ((fun (ir1-convert-lambda-body
+ forms vars
+ :debug-name (debug-namify "LET ~S"
+ bindings))))
+ (reference-leaf start fun-ctran fun-lvar fun))
+ (values next result))))
+ (ir1-convert-combination-args fun-ctran fun-lvar next result values))))))
(def-ir1-translator let* ((bindings &body body)
- start cont)
+ start next result)
#!+sb-doc
"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) (parse-body body nil)
+ (multiple-value-bind (forms decls)
+ (parse-body body :doc-string-allowed 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)))))
+ (processing-decls (decls vars nil start next)
+ (ir1-convert-aux-bindings start next result forms vars values)))))
;;; logic shared between IR1 translators for LOCALLY, MACROLET,
;;; and SYMBOL-MACROLET
;;; 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 &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 vars funs cont)))
- (ir1-convert-aux-bindings start cont forms nil nil))))
-
-(def-ir1-translator locally ((&body body) start cont)
+(defun ir1-translate-locally (body start next result &key vars funs)
+ (declare (type ctran start next) (type (or lvar null) result)
+ (type list body))
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+ (processing-decls (decls vars funs next result)
+ (ir1-convert-progn-body start next result forms))))
+
+(def-ir1-translator locally ((&body body) start next result)
#!+sb-doc
"LOCALLY Declaration* Form*
Sequentially evaluate the Forms in a lexical environment where the
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 cont))
+ (ir1-translate-locally body start next result))
\f
;;;; FLET and LABELS
(values (names) (defs))))
(def-ir1-translator flet ((definitions &body body)
- start cont)
+ start next result)
#!+sb-doc
"FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
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) (parse-body body nil)
+ (multiple-value-bind (forms decls)
+ (parse-body body :doc-string-allowed nil)
(multiple-value-bind (names defs)
(extract-flet-vars definitions 'flet)
- (let* ((fvars (mapcar (lambda (n d)
- (ir1-convert-lambda d
- :source-name n
- :debug-name (debug-namify
- "FLET ~S" n)
- :allow-debug-catch-tag t))
- names defs))
- (*lexenv* (make-lexenv
- :default (process-decls decls nil fvars cont)
- :funs (pairlis names fvars))))
- (ir1-convert-progn-body start cont forms)))))
-
-(def-ir1-translator labels ((definitions &body body) start cont)
+ (let ((fvars (mapcar (lambda (n d)
+ (ir1-convert-lambda d
+ :source-name n
+ :debug-name (debug-namify
+ "FLET ~S" n)
+ :allow-debug-catch-tag t))
+ names defs)))
+ (processing-decls (decls nil fvars next result)
+ (let ((*lexenv* (make-lexenv :funs (pairlis names fvars))))
+ (ir1-convert-progn-body start next result forms)))))))
+
+(def-ir1-translator labels ((definitions &body body) start next result)
#!+sb-doc
"LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
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) (parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
(multiple-value-bind (names defs)
(extract-flet-vars definitions 'labels)
- (let* (;; dummy LABELS functions, to be used as placeholders
+ (let* ( ;; dummy LABELS functions, to be used as placeholders
;; during construction of real LABELS functions
(placeholder-funs (mapcar (lambda (name)
(make-functional
(setf (cdr placeholder-cons) real-fun))
;; Voila.
- (let ((*lexenv* (make-lexenv
- :default (process-decls decls nil real-funs cont)
- ;; Use a proper FENV here (not the
- ;; placeholder used earlier) so that if the
- ;; lexical environment is used for inline
- ;; expansion we'll get the right functions.
- :funs (pairlis names real-funs))))
- (ir1-convert-progn-body start cont forms))))))
+ (processing-decls (decls nil real-funs next result)
+ (let ((*lexenv* (make-lexenv
+ ;; Use a proper FENV here (not the
+ ;; placeholder used earlier) so that if the
+ ;; lexical environment is used for inline
+ ;; expansion we'll get the right functions.
+ :funs (pairlis names real-funs))))
+ (ir1-convert-progn-body start next result forms)))))))
\f
;;;; the THE special operator, and friends
-;;; Do stuff to recognize a THE or VALUES declaration. CONT is the
-;;; continuation that the assertion applies to, TYPE is the type
-;;; specifier and LEXENV is the current lexical environment. NAME is
-;;; the name of the declaration we are doing, for use in error
-;;; messages.
-;;;
-;;; This is somewhat involved, since a type assertion may only be made
-;;; on a continuation, not on a node. We can't just set the
-;;; continuation asserted type and let it go at that, since there may
-;;; be parallel THE's for the same continuation, i.e.
-;;; (if ...
-;;; (the foo ...)
-;;; (the bar ...))
-;;;
-;;; In this case, our representation can do no better than the union
-;;; of these assertions. And if there is a branch with no assertion,
-;;; we have nothing at all. We really need to recognize scoping, since
-;;; we need to be able to discern between parallel assertions (which
-;;; we union) and nested ones (which we intersect).
-;;;
-;;; We represent the scoping by throwing our innermost (intersected)
-;;; assertion on CONT into the TYPE-RESTRICTIONS. As we go down, we
-;;; intersect our assertions together. If CONT has no uses yet, we
-;;; have not yet bottomed out on the first COND branch; in this case
-;;; we optimistically assume that this type will be the one we end up
-;;; with, and set the ASSERTED-TYPE to it. We can never get better
-;;; than the type that we have the first time we bottom out. Later
-;;; THE's (or the absence thereof) can only weaken this result.
-;;;
-;;; 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 place)
- (declare (type continuation cont) (type lexenv lexenv))
- (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-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 ~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)))
+;;; A logic shared among THE and TRULY-THE.
+(defun the-in-policy (type value policy start next result)
+ (let ((type (if (ctype-p type) type
+ (compiler-values-specifier-type type))))
+ (cond ((or (eq type *wild-type*)
+ (eq type *universal-type*)
+ (and (leaf-p value)
+ (values-subtypep (make-single-value-type (leaf-type value))
+ type))
+ (and (sb!xc:constantp value)
+ (ctypep (constant-form-value value)
+ (single-value-type type))))
+ (ir1-convert start next result value))
+ (t (let ((value-ctran (make-ctran))
+ (value-lvar (make-lvar)))
+ (ir1-convert start value-ctran value-lvar value)
+ (let ((cast (make-cast value-lvar type policy)))
+ (link-node-to-previous-ctran cast value-ctran)
+ (setf (lvar-dest value-lvar) cast)
+ (use-continuation cast next result)))))))
;;; Assert that FORM evaluates to the specified type (which may be a
-;;; VALUES type).
-;;;
-;;; FIXME: In a version of CMU CL that I used at Cadabra ca. 20000101,
-;;; 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)
- (with-continuation-type-assertion (cont (compiler-values-specifier-type type)
- "in THE declaration")
- (ir1-convert start cont value)))
+;;; 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))
;;; 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.
-;;;
-;;; Since the CONTINUATION-DERIVED-TYPE is computed as the union of
-;;; its uses's types, setting it won't work. Instead we must intersect
-;;; the type with the uses's DERIVED-TYPE.
-(def-ir1-translator truly-the ((type value) start cont)
+(def-ir1-translator truly-the ((type value) start next result)
#!+sb-doc
+ ""
(declare (inline member))
- (let ((type (compiler-values-specifier-type type))
- (old (find-uses cont)))
- (ir1-convert start cont value)
- (do-uses (use cont)
- (unless (member use old :test #'eq)
- (derive-node-type use type)))))
+ #-nil
+ (let ((type (coerce-to-values (compiler-values-specifier-type type)))
+ (old (find-uses result)))
+ (ir1-convert start next result value)
+ (do-uses (use result)
+ (unless (memq use old)
+ (derive-node-type use type))))
+ #+nil
+ (the-in-policy type value '((type-check . 0)) start cont))
\f
;;;; SETQ
;;; 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)
+(def-ir1-translator setq ((&whole source &rest things) start next result)
(let ((len (length things)))
(when (oddp len)
(compiler-error "odd number of args to SETQ: ~S" source))
(when (constant-p leaf)
(compiler-error "~S is a constant and thus can't be set." name))
(when (lambda-var-p leaf)
- (let ((home-lambda (continuation-home-lambda-or-null start)))
+ (let ((home-lambda (ctran-home-lambda-or-null start)))
(when home-lambda
(pushnew leaf (lambda-calls-or-closes home-lambda))))
(when (lambda-var-ignorep leaf)
(compiler-style-warn
"~S is being set even though it was declared to be ignored."
name)))
- (setq-var start cont leaf (second things)))
+ (setq-var start next result leaf (second things)))
(cons
(aver (eq (car leaf) 'MACRO))
- (ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
+ ;; FIXME: [Free] type declaration. -- APD, 2002-01-26
+ (ir1-convert start next result
+ `(setf ,(cdr leaf) ,(second things))))
(heap-alien-info
- (ir1-convert start cont
+ (ir1-convert start next result
`(%set-heap-alien ',leaf ,(second things))))))
(collect ((sets))
(do ((thing things (cddr thing)))
((endp thing)
- (ir1-convert-progn-body start cont (sets)))
+ (ir1-convert-progn-body start next result (sets)))
(sets `(setq ,(first thing) ,(second thing))))))))
;;; This is kind of like REFERENCE-LEAF, but we generate a SET node.
;;; This should only need to be called in SETQ.
-(defun setq-var (start cont var value)
- (declare (type continuation start cont) (type basic-var var))
- (let ((dest (make-continuation)))
- (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)
+(defun setq-var (start next result var value)
+ (declare (type ctran start next) (type (or lvar null) result)
+ (type basic-var var))
+ (let ((dest-ctran (make-ctran))
+ (dest-lvar (make-lvar))
+ (type (or (lexenv-find var type-restrictions)
+ (leaf-type var))))
+ (ir1-convert start dest-ctran dest-lvar `(the ,type ,value))
+ (let ((res (make-set :var var :value dest-lvar)))
+ (setf (lvar-dest dest-lvar) res)
(setf (leaf-ever-used var) t)
(push res (basic-var-sets var))
- (link-node-to-previous-continuation res dest)
- (use-continuation res cont))))
+ (link-node-to-previous-ctran res dest-ctran)
+ (use-continuation res next result))))
\f
;;;; CATCH, THROW and UNWIND-PROTECT
;;; 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)
+(def-ir1-translator throw ((tag result) start next result-lvar)
#!+sb-doc
"Throw Tag Form
Do a non-local exit, return the values of Form from the CATCH whose tag
evaluates to the same thing as Tag."
- (ir1-convert start cont
+ (ir1-convert start next result-lvar
`(multiple-value-call #'%throw ,tag ,result)))
;;; This is a special special form used to instantiate a cleanup as
;;; and introduce the cleanup into the lexical environment. We
;;; back-patch the ENTRY-CLEANUP for the current cleanup to be the new
;;; cleanup, since this inner cleanup is the interesting one.
-(def-ir1-translator %within-cleanup ((kind mess-up &body body) start cont)
- (let ((dummy (make-continuation))
- (dummy2 (make-continuation)))
- (ir1-convert start dummy mess-up)
- (let* ((mess-node (continuation-use dummy))
+(def-ir1-translator %within-cleanup
+ ((kind mess-up &body body) start next result)
+ (let ((dummy (make-ctran))
+ (dummy2 (make-ctran)))
+ (ir1-convert start dummy nil mess-up)
+ (let* ((mess-node (ctran-use dummy))
(cleanup (make-cleanup :kind kind
:mess-up mess-node))
(old-cup (lexenv-cleanup *lexenv*))
(*lexenv* (make-lexenv :cleanup cleanup)))
(setf (entry-cleanup (cleanup-mess-up old-cup)) cleanup)
- (ir1-convert dummy dummy2 '(%cleanup-point))
- (ir1-convert-progn-body dummy2 cont body))))
+ (ir1-convert dummy dummy2 nil '(%cleanup-point))
+ (ir1-convert-progn-body dummy2 next result body))))
;;; This is a special special form that makes an "escape function"
;;; which returns unknown values from named block. We convert the
;;;
;;; Note that environment analysis replaces references to escape
;;; functions with references to the corresponding NLX-INFO structure.
-(def-ir1-translator %escape-fun ((tag) start cont)
+(def-ir1-translator %escape-fun ((tag) start next result)
(let ((fun (ir1-convert-lambda
`(lambda ()
(return-from ,tag (%unknown-values)))
:debug-name (debug-namify "escape function for ~S" tag))))
(setf (functional-kind fun) :escape)
- (reference-leaf start cont fun)))
+ (reference-leaf start next result fun)))
;;; Yet another special special form. This one looks up a local
;;; function and smashes it to a :CLEANUP function, as well as
;;; referencing it.
-(def-ir1-translator %cleanup-fun ((name) start cont)
+(def-ir1-translator %cleanup-fun ((name) start next result)
(let ((fun (lexenv-find name funs)))
(aver (lambda-p fun))
(setf (functional-kind fun) :cleanup)
- (reference-leaf start cont fun)))
+ (reference-leaf start next result fun)))
-(def-ir1-translator catch ((tag &body body) start cont)
+(def-ir1-translator catch ((tag &body body) start next result)
#!+sb-doc
"Catch Tag Form*
Evaluate TAG and instantiate it as a catcher while the body forms are
;; "escape function" that does a lexical exit, and instantiate the
;; cleanup using %WITHIN-CLEANUP.
(ir1-convert
- start cont
+ start next result
(with-unique-names (exit-block)
`(block ,exit-block
(%within-cleanup
(%catch (%escape-fun ,exit-block) ,tag)
,@body)))))
-(def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
+(def-ir1-translator unwind-protect
+ ((protected &body cleanup) start next result)
#!+sb-doc
"Unwind-Protect Protected Cleanup*
Evaluate the form PROTECTED, returning its values. The CLEANUP forms are
;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of
;; an XEP.
(ir1-convert
- start cont
+ start next result
(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
\f
;;;; multiple-value stuff
-(def-ir1-translator multiple-value-call ((fun &rest args) start cont)
+(def-ir1-translator multiple-value-call ((fun &rest args) start next result)
#!+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."
- (let* ((fun-cont (make-continuation))
+ (let* ((fun-ctran (make-ctran))
+ (fun-lvar (make-lvar))
(node (if args
;; If there are arguments, MULTIPLE-VALUE-CALL
;; turns into an MV-COMBINATION.
- (make-mv-combination fun-cont)
+ (make-mv-combination fun-lvar)
;; 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
+ (make-combination fun-lvar))))
+ (ir1-convert start fun-ctran fun-lvar
(if (and (consp fun) (eq (car fun) 'function))
fun
`(%coerce-callable-to-fun ,fun)))
- (setf (continuation-dest fun-cont) node)
- (collect ((arg-conts))
- (let ((this-start fun-cont))
+ (setf (lvar-dest fun-lvar) node)
+ (collect ((arg-lvars))
+ (let ((this-start fun-ctran))
(dolist (arg args)
- (let ((this-cont (make-continuation node)))
- (ir1-convert this-start this-cont arg)
- (setq this-start this-cont)
- (arg-conts this-cont)))
- (link-node-to-previous-continuation node this-start)
- (use-continuation node cont)
- (setf (basic-combination-args node) (arg-conts))))))
+ (let ((this-ctran (make-ctran))
+ (this-lvar (make-lvar node)))
+ (ir1-convert this-start this-ctran this-lvar arg)
+ (setq this-start this-ctran)
+ (arg-lvars this-lvar)))
+ (link-node-to-previous-ctran node this-start)
+ (use-continuation node next result)
+ (setf (basic-combination-args node) (arg-lvars))))))
;;; MULTIPLE-VALUE-PROG1 is represented implicitly in IR1 by having a
;;; the result code use result continuation (CONT), but transfer
;;; Nested MV-PROG1's work because during conversion of the result
;;; form, we use dummy continuation whose block is the true control
;;; destination.
-(def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont)
+(def-ir1-translator multiple-value-prog1
+ ((values-form &rest forms) start next result)
#!+sb-doc
"MULTIPLE-VALUE-PROG1 Values-Form Form*
Evaluate Values-Form and then the Forms, but return all the values of
Values-Form."
- (continuation-starts-block cont)
- (let* ((dummy-result (make-continuation))
- (dummy-start (make-continuation))
- (cont-block (continuation-block cont)))
- (continuation-starts-block dummy-start)
- (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))
-
- (continuation-starts-block dummy-result)
- (ir1-convert-progn-body dummy-start dummy-result forms)
- (let ((end-block (continuation-block dummy-result)))
- (dolist (pred (block-pred end-block))
- (unlink-blocks pred end-block)
- (link-blocks pred cont-block))
- (aver (not (continuation-dest dummy-result)))
- (delete-continuation dummy-result)
- (remove-from-dfo end-block))))
+ (let ((dummy (make-ctran)))
+ (ir1-convert start dummy result values-form)
+ (ir1-convert-progn-body dummy next nil forms)))
\f
;;;; interface to defining macros
projects / sbcl.git / blobdiff