(in-package "SB!C")
\f
-;;;; control special forms
+;;;; special forms for control
(def-ir1-translator progn ((&rest forms) start cont)
#!+sb-doc
:alternative else-block)))
(setf (continuation-dest pred) node)
(ir1-convert start pred test)
- (prev-link node pred)
+ (link-node-to-previous-continuation node pred)
(use-continuation node dummy-cont)
(let ((start-block (continuation-block pred)))
(continuation-starts-block cont)
(link-blocks start-block then-block)
- (link-blocks start-block else-block)
+ (link-blocks start-block else-block))
- (ir1-convert then-cont cont then)
- (ir1-convert else-cont cont else))))
+ (ir1-convert then-cont cont then)
+ (ir1-convert else-cont cont else)))
\f
;;;; BLOCK and TAGBODY
-;;;; We make an Entry node to mark the start and a :Entry cleanup to
-;;;; mark its extent. When doing GO or RETURN-FROM, we emit an Exit
+;;;; We make an ENTRY node to mark the start and a :ENTRY cleanup to
+;;;; mark its extent. When doing GO or RETURN-FROM, we emit an EXIT
;;;; node.
;;; Make a :ENTRY cleanup and emit an ENTRY node, then convert the
:mess-up entry)))
(push entry (lambda-entries (lexenv-lambda *lexenv*)))
(setf (entry-cleanup entry) cleanup)
- (prev-link entry start)
+ (link-node-to-previous-continuation entry start)
(use-continuation entry dummy)
(let* ((env-entry (list entry cont))
(push env-entry (continuation-lexenv-uses cont))
(ir1-convert-progn-body dummy cont forms))))
-
-;;; We make CONT start a block just so that it will have a block
-;;; assigned. People assume that when they pass a continuation into
-;;; IR1-CONVERT as CONT, it will have a block when it is done.
-(def-ir1-translator return-from ((name &optional value)
- start cont)
+(def-ir1-translator return-from ((name &optional value) start cont)
#!+sb-doc
"Return-From Block-Name Value-Form
Evaluate the Value-Form, returning its values from the lexically enclosing
BLOCK Block-Name. This is constrained to be used only within the dynamic
extent of the BLOCK."
+ ;; CMU CL comment:
+ ;; We make CONT start a block just so that it will have a block
+ ;; assigned. People assume that when they pass a continuation into
+ ;; IR1-CONVERT as CONT, it will have a block when it is done.
+ ;; KLUDGE: Note that this block is basically fictitious. In the code
+ ;; (BLOCK B (RETURN-FROM B) (SETQ X 3))
+ ;; it's the block which answers the question "which block is
+ ;; the (SETQ X 3) in?" when the right answer is that (SETQ X 3) is
+ ;; dead code and so doesn't really have a block at all. The existence
+ ;; of this block, and that way that it doesn't explicitly say
+ ;; "I'm actually nowhere at all" makes some logic (e.g.
+ ;; 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)
(let* ((found (or (lexenv-find name blocks)
(compiler-error "return for unknown block: ~S" name)))
(push exit (entry-exits entry))
(setf (continuation-dest value-cont) exit)
(ir1-convert start value-cont value)
- (prev-link exit value-cont)
+ (link-node-to-previous-continuation exit value-cont)
+ (let ((home-lambda (continuation-home-lambda-or-null start)))
+ (when home-lambda
+ (push entry (lambda-calls-or-closes home-lambda))))
(use-continuation exit (second found))))
;;; Return a list of the segments of a TAGBODY. Each segment looks
:mess-up entry)))
(push entry (lambda-entries (lexenv-lambda *lexenv*)))
(setf (entry-cleanup entry) cleanup)
- (prev-link entry start)
+ (link-node-to-previous-continuation entry start)
(use-continuation entry dummy)
(collect ((tags)
is constrained to be used only within the dynamic extent of the TAGBODY."
(continuation-starts-block cont)
(let* ((found (or (lexenv-find tag tags :test #'eql)
- (compiler-error "Go to nonexistent tag: ~S." tag)))
+ (compiler-error "attempt to GO to nonexistent tag: ~S"
+ tag)))
(entry (first found))
(exit (make-exit :entry entry)))
(push exit (entry-exits entry))
- (prev-link exit start)
+ (link-node-to-previous-continuation exit start)
+ (let ((home-lambda (continuation-home-lambda-or-null start)))
+ (when home-lambda
+ (push entry (lambda-calls-or-closes home-lambda))))
(use-continuation exit (second found))))
\f
;;;; translators for compiler-magic special forms
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)))
- (compiler-style-warning "duplicate definitions in ~S" definitions))
+ (compiler-style-warn "duplicate definitions in ~S" definitions))
(let* ((processed-definitions (mapcar definitionize-fun definitions))
(*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
(funcall fun)))
`(lambda (,whole ,environment)
,@local-decls
(block ,name ,body))))))))
- :functions
+ :funs
definitions
fun))
(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))
;;; 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
,@(subseq args 0 required)
,@(subseq args min)))))
\f
-;;;; QUOTE and FUNCTION
+;;;; QUOTE
(def-ir1-translator quote ((thing) start cont)
#!+sb-doc
"QUOTE Value
Return Value without evaluating it."
(reference-constant start cont 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."
+ be a lambda expression."
(if (consp thing)
(case (car thing)
((lambda)
:debug-name (debug-namify
"#'~S" thing))))
((setf)
- (let ((var (find-lexically-apparent-function
+ (let ((var (find-lexically-apparent-fun
thing "as the argument to FUNCTION")))
(reference-leaf start cont var)))
((instance-lambda)
(reference-leaf start cont res)))
(t
(compiler-error "~S is not a legal function name." thing)))
- (let ((var (find-lexically-apparent-function
+ (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))))
\f
;;;; 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)
;;; compiler. If the called function is a FUNCTION form, then convert
;;; directly to %FUNCALL, instead of waiting around for type
;;; inference.
-(def-source-transform funcall (function &rest args)
+(define-source-transform funcall (function &rest args)
(if (and (consp function) (eq (car function) 'function))
`(%funcall ,function ,@args)
(values nil t)))
(deftransform %coerce-callable-to-fun ((thing) (function) *
- :when :both
:important t)
"optimize away possible call to FDEFINITION at runtime"
'thing)
;;;; 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))
(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)
(names name)
(vals (second spec)))))))
- (values (vars) (vals) (names))))
+ (values (vars) (vals))))
(def-ir1-translator let ((bindings &body body)
start cont)
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 (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)
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 (vars values) (extract-let-vars bindings 'let*)
(let ((*lexenv* (process-decls decls vars nil cont)))
(ir1-convert-aux-bindings start cont forms vars values)))))
;;;
;;; 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)
the lexically apparent function definition in the enclosing environment."
(multiple-value-bind (forms decls) (sb!sys: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
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)
each other."
(multiple-value-bind (forms decls) (sb!sys: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)
"LABELS placeholder ~S"
name)))
names))
+ ;; (like PAIRLIS but guaranteed to preserve ordering:)
+ (placeholder-fenv (mapcar #'cons names placeholder-funs))
;; the real LABELS functions, compiled in a LEXENV which
;; includes the dummy LABELS functions
(real-funs
- (let ((*lexenv* (make-lexenv
- :functions (pairlis names placeholder-funs))))
+ (let ((*lexenv* (make-lexenv :funs placeholder-fenv)))
(mapcar (lambda (name def)
(ir1-convert-lambda def
:source-name name
;; Modify all the references to the dummy function leaves so
;; that they point to the real function leaves.
- (loop for real-fun in real-funs and placeholder-fun in placeholder-funs
- do (substitute-leaf real-fun placeholder-fun))
+ (loop for real-fun in real-funs and
+ placeholder-cons in placeholder-fenv do
+ (substitute-leaf real-fun (cdr placeholder-cons))
+ (setf (cdr placeholder-cons) real-fun))
;; Voila.
(let ((*lexenv* (make-lexenv
;; 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))))))
\f
;;;; the THE special operator, and friends
;;; 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 name)
(declare (type continuation cont) (type lexenv lexenv))
(let* ((ctype (values-specifier-type type))
(old-type (or (lexenv-find cont type-restrictions)
(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-warning
- "The type ~S in ~S declaration conflicts with an enclosing assertion:~% ~S"
+ (compiler-warn
+ "The type ~S in ~S declaration conflicts with an ~
+ enclosing assertion:~% ~S"
(type-specifier ctype)
name
(type-specifier old-type)))
;;; 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)))
+ (let ((*lexenv* (ir1ize-the-or-values type cont *lexenv* 'the)))
(ir1-convert start cont value)))
;;; This is like the THE special form, except that it believes
\f
;;;; 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)
(compiler-error "~S is a constant and thus can't be set." name))
- (when (and (lambda-var-p leaf)
- (lambda-var-ignorep leaf))
- ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
- ;; requires that this be a STYLE-WARNING, not a full warning.
- (compiler-style-warning
- "~S is being set even though it was declared to be ignored."
- name))
- (set-variable start cont leaf (second things)))
+ (when (lambda-var-p leaf)
+ (let ((home-lambda (continuation-home-lambda-or-null start)))
+ (when home-lambda
+ (pushnew leaf (lambda-calls-or-closes home-lambda))))
+ (when (lambda-var-ignorep leaf)
+ ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
+ ;; requires that this be a STYLE-WARNING, not a full warning.
+ (compiler-style-warn
+ "~S is being set even though it was declared to be ignored."
+ name)))
+ (setq-var start cont leaf (second things)))
(cons
(aver (eq (car leaf) 'MACRO))
(ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
;;; 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))
(setf (continuation-dest dest) res)
(setf (leaf-ever-used var) t)
(push res (basic-var-sets var))
- (prev-link res dest)
+ (link-node-to-previous-continuation res dest)
(use-continuation res cont))))
\f
;;;; CATCH, THROW and UNWIND-PROTECT
`(multiple-value-call #'%throw ,tag ,result)))
;;; This is a special special form used to instantiate a cleanup as
-;;; the current cleanup within the body. KIND is a the kind of cleanup
+;;; the current cleanup within the body. KIND is the kind of cleanup
;;; to make, and MESS-UP is a form that does the mess-up action. We
;;; make the MESS-UP be the USE of the MESS-UP form's continuation,
;;; and introduce the cleanup into the lexical environment. We
;;;
;;; Note that environment analysis replaces references to escape
;;; functions with references to the corresponding NLX-INFO structure.
-(def-ir1-translator %escape-function ((tag) start cont)
+(def-ir1-translator %escape-fun ((tag) start cont)
(let ((fun (ir1-convert-lambda
`(lambda ()
(return-from ,tag (%unknown-values)))
;;; 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-function ((name) start cont)
- (let ((fun (lexenv-find name functions)))
+(def-ir1-translator %cleanup-fun ((name) start cont)
+ (let ((fun (lexenv-find name funs)))
(aver (lambda-p fun))
(setf (functional-kind fun) :cleanup)
(reference-leaf start cont fun)))
`(block ,exit-block
(%within-cleanup
:catch
- (%catch (%escape-function ,exit-block) ,tag)
+ (%catch (%escape-fun ,exit-block) ,tag)
,@body)))))
-;;; UNWIND-PROTECT is similar to CATCH, but more hairy. We make the
+;;; 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-FUNCTION on this to indicate that reference by
-;;; %UNWIND-PROTECT ISN'T "real", and thus doesn't cause creation of
+;;; 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
`(flet ((,cleanup-fun () ,@cleanup nil))
;; FIXME: If we ever get DYNAMIC-EXTENT working, then
;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
- ;; and something can be done to make %ESCAPE-FUNCTION have
+ ;; and something can be done to make %ESCAPE-FUN have
;; dynamic extent too.
(block ,drop-thru-tag
(multiple-value-bind (,next ,start ,count)
(block ,exit-tag
(%within-cleanup
:unwind-protect
- (%unwind-protect (%escape-function ,exit-tag)
- (%cleanup-function ,cleanup-fun))
+ (%unwind-protect (%escape-fun ,exit-tag)
+ (%cleanup-fun ,cleanup-fun))
(return-from ,drop-thru-tag ,protected)))
(,cleanup-fun)
(%continue-unwind ,next ,start ,count)))))))
(ir1-convert this-start this-cont arg)
(setq this-start this-cont)
(arg-conts this-cont)))
- (prev-link node this-start)
+ (link-node-to-previous-continuation node this-start)
(use-continuation node cont)
(setf (basic-combination-args node) (arg-conts))))))
(ecase (info :function :kind name)
((nil))
(:function
- (remhash name *free-functions*)
+ (remhash name *free-funs*)
(undefine-fun-name name)
- (compiler-warning
+ (compiler-warn
"~S is being redefined as a macro when it was ~
previously ~(~A~) to be a function."
name
projects / sbcl.git / blobdiff