to optimize code which uses those definitions? Setting this true
gives non-ANSI, early-CMU-CL behavior. It can be useful for improving
the efficiency of stable code.")
+
+;;; *ALLOW-DEBUG-CATCH-TAG* controls whether we should allow the
+;;; insertion a (CATCH ...) around code to allow the debugger RETURN
+;;; command to function.
+(defvar *allow-debug-catch-tag* t)
\f
;;;; namespace management utilities
;;; predicate didn't exist.
;;;
;;; This predicate was added to fix bug 138 in SBCL. In some obscure
-;;; circumstances, it was possible for a *FREE-FUNS* to contain a
+;;; circumstances, it was possible for a *FREE-FUNS* entry to contain a
;;; DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object contained IR1
;;; stuff (NODEs, BLOCKs...) referring to an already compiled (aka
;;; "dead") component. When this IR1 stuff was reused in a new
;; (sbcl-0.pre7.118) is this one:
(and (defined-fun-p free-fun)
(let ((functional (defined-fun-functional free-fun)))
- (and (lambda-p functional)
- (or
- ;; (The main reason for this first test is to bail out
- ;; early in cases where the LAMBDA-COMPONENT call in
- ;; the second test would fail because links it needs
- ;; are uninitialized or invalid.)
- ;;
- ;; If the BIND node for this LAMBDA is null, then
- ;; according to the slot comments, the LAMBDA has been
- ;; deleted or its call has been deleted. In that case,
- ;; it seems rather questionable to reuse it, and
- ;; certainly it shouldn't be necessary to reuse it, so
- ;; we cheerfully declare it invalid.
- (null (lambda-bind functional))
- ;; If this IR1 stuff belongs to a dead component, then
- ;; we can't reuse it without getting into bizarre
- ;; confusion.
- (eql (component-info (lambda-component functional)) :dead))))))
+ (or (and functional
+ (eql (functional-kind functional) :deleted))
+ (and (lambda-p functional)
+ (or
+ ;; (The main reason for this first test is to bail
+ ;; out early in cases where the LAMBDA-COMPONENT
+ ;; call in the second test would fail because links
+ ;; it needs are uninitialized or invalid.)
+ ;;
+ ;; If the BIND node for this LAMBDA is null, then
+ ;; according to the slot comments, the LAMBDA has
+ ;; been deleted or its call has been deleted. In
+ ;; that case, it seems rather questionable to reuse
+ ;; it, and certainly it shouldn't be necessary to
+ ;; reuse it, so we cheerfully declare it invalid.
+ (null (lambda-bind functional))
+ ;; If this IR1 stuff belongs to a dead component,
+ ;; then we can't reuse it without getting into
+ ;; bizarre confusion.
+ (eql (component-info (lambda-component functional))
+ :dead)))))))
;;; If NAME already has a valid entry in *FREE-FUNS*, then return
;;; the value. Otherwise, make a new GLOBAL-VAR using information from
;;; names a macro or special form, then we error out using the
;;; supplied context which indicates what we were trying to do that
;;; demanded a function.
+(declaim (ftype (function (t string) global-var) find-free-fun))
(defun find-free-fun (name context)
- (declare (string context))
- (declare (values global-var))
(or (let ((old-free-fun (gethash name *free-funs*)))
(and (not (invalid-free-fun-p old-free-fun))
old-free-fun))
;;; corresponding value. Otherwise, we make a new leaf using
;;; information from the global environment and enter it in
;;; *FREE-VARS*. If the variable is unknown, then we emit a warning.
+(declaim (ftype (function (t) (or leaf cons heap-alien-info)) find-free-var))
(defun find-free-var (name)
- (declare (values (or leaf heap-alien-info)))
(unless (symbolp name)
(compiler-error "Variable name is not a symbol: ~S." name))
(or (gethash name *free-vars*)
(case kind
(:alien
(info :variable :alien-info name))
+ ;; FIXME: The return value in this case should really be
+ ;; of type SB!C::LEAF. I don't feel too badly about it,
+ ;; because the MACRO idiom is scattered throughout this
+ ;; file, but it should be cleaned up so we're not
+ ;; throwing random conses around. --njf 2002-03-23
+ (:macro
+ (let ((expansion (info :variable :macro-expansion name))
+ (type (type-specifier (info :variable :type name))))
+ `(MACRO . (the ,type ,expansion))))
(:constant
(let ((value (info :variable :constant-value name)))
(make-constant :value value
(eval-when (:compile-toplevel :load-toplevel :execute)
;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD)
;; below. -- AL 20010227
- (defconstant list-to-hash-table-threshold 32))
+ (def!constant list-to-hash-table-threshold 32))
(defun maybe-emit-make-load-forms (constant)
(let ((things-processed nil)
(count 0))
(push node-block (block-pred block))
(add-continuation-use node cont)
(unless (eq (continuation-asserted-type cont) *wild-type*)
- (let ((new (values-type-union (continuation-asserted-type cont)
- (or (lexenv-find cont type-restrictions)
- *wild-type*))))
- (when (type/= new (continuation-asserted-type cont))
- (setf (continuation-asserted-type cont) new)
+ (let* ((restriction (or (lexenv-find cont type-restrictions)
+ *wild-type*))
+ (wrestriction (or (lexenv-find cont weakend-type-restrictions)
+ *wild-type*))
+ (newatype (values-type-union (continuation-asserted-type cont)
+ restriction))
+ (newctype (values-type-union (continuation-type-to-check cont)
+ wrestriction)))
+ (when (or (type/= newatype (continuation-asserted-type cont))
+ (type/= newctype (continuation-type-to-check cont)))
+ (setf (continuation-asserted-type cont) newatype)
+ (setf (continuation-type-to-check cont) newctype)
(reoptimize-continuation cont))))))
\f
;;;; exported functions
cont
form
&optional
- (proxy ``(error "execution of a form compiled with errors:~% ~S"
- ',,form)))
+ (proxy ``(error 'simple-program-error
+ :format-control "execution of a form compiled with errors:~% ~S"
+ :format-arguments (list ',,form))))
&body body)
- (let ((skip (gensym "SKIP")))
+ (with-unique-names (skip)
`(block ,skip
(catch 'ir1-error-abort
(let ((*compiler-error-bailout*
opname
:debug-name (debug-namify
"LAMBDA CAR ~S"
- opname)))))))))
+ opname)
+ :allow-debug-catch-tag t))))))))
(values))
;; Generate a reference to a manifest constant, creating a new leaf
(use-continuation res cont)))
(values)))
-;;; Add FUN to the COMPONENT-REANALYZE-FUNS, unless it's some trivial
-;;; type for which reanalysis is a trivial no-op, or unless it doesn't
-;;; belong in this component at all.
+;;; Add FUNCTIONAL to the COMPONENT-REANALYZE-FUNCTIONALS, unless it's
+;;; some trivial type for which reanalysis is a trivial no-op, or
+;;; unless it doesn't belong in this component at all.
;;;
-;;; FUN is returned.
-(defun maybe-reanalyze-fun (fun)
- (declare (type functional fun))
+;;; FUNCTIONAL is returned.
+(defun maybe-reanalyze-functional (functional)
+ (aver (not (eql (functional-kind functional) :deleted))) ; bug 148
(aver-live-component *current-component*)
- ;; When FUN is of a type for which reanalysis isn't a trivial no-op
- (when (typep fun '(or optional-dispatch clambda))
+ ;; When FUNCTIONAL is of a type for which reanalysis isn't a trivial
+ ;; no-op
+ (when (typep functional '(or optional-dispatch clambda))
- ;; When FUN knows its component
- (when (lambda-p fun)
- (aver (eql (lambda-component fun) *current-component*)))
+ ;; When FUNCTIONAL knows its component
+ (when (lambda-p functional)
+ (aver (eql (lambda-component functional) *current-component*)))
- (pushnew fun (component-reanalyze-funs *current-component*)))
+ (pushnew functional
+ (component-reanalyze-functionals *current-component*)))
- fun)
+ functional)
;;; Generate a REF node for LEAF, frobbing the LEAF structure as
;;; needed. If LEAF represents a defined function which has already
;;; functional instead.
(defun reference-leaf (start cont leaf)
(declare (type continuation start cont) (type leaf leaf))
- (let* ((leaf (or (and (defined-fun-p leaf)
- (not (eq (defined-fun-inlinep leaf)
- :notinline))
- (let ((fun (defined-fun-functional leaf)))
- (when (and fun (not (functional-kind fun)))
- (maybe-reanalyze-fun fun))))
- leaf))
- (res (make-ref (or (lexenv-find leaf type-restrictions)
- (leaf-type leaf))
- leaf)))
- (push res (leaf-refs leaf))
- (setf (leaf-ever-used leaf) t)
- (link-node-to-previous-continuation res start)
- (use-continuation res cont)))
+ (with-continuation-type-assertion
+ (cont (or (lexenv-find leaf type-restrictions) *wild-type*)
+ "in DECLARE")
+ (let* ((leaf (or (and (defined-fun-p leaf)
+ (not (eq (defined-fun-inlinep leaf)
+ :notinline))
+ (let ((functional (defined-fun-functional leaf)))
+ (when (and functional
+ (not (functional-kind functional)))
+ (maybe-reanalyze-functional functional))))
+ leaf))
+ (res (make-ref (leaf-type leaf)
+ leaf)))
+ (push res (leaf-refs leaf))
+ (setf (leaf-ever-used leaf) t)
+ (link-node-to-previous-continuation res start)
+ (use-continuation res cont))))
;;; Convert a reference to a symbolic constant or variable. If the
;;; symbol is entered in the LEXENV-VARS we use that definition,
(values))
;;; Convert anything that looks like a special form, global function
-;;; or macro call.
+;;; or compiler-macro call.
(defun ir1-convert-global-functoid (start cont form)
(declare (type continuation start cont) (list form))
- (let* ((fun (first form))
- (translator (info :function :ir1-convert fun))
- (cmacro (info :function :compiler-macro-function fun)))
- (cond (translator (funcall translator start cont form))
- ((and cmacro
- (not (eq (info :function :inlinep fun)
- :notinline)))
- (let ((res (careful-expand-macro cmacro form)))
+ (let* ((fun-name (first form))
+ (translator (info :function :ir1-convert fun-name))
+ (cmacro-fun (sb!xc:compiler-macro-function fun-name *lexenv*)))
+ (cond (translator
+ (when cmacro-fun
+ (compiler-warn "ignoring compiler macro for special form"))
+ (funcall translator start cont form))
+ ((and cmacro-fun
+ ;; gotcha: If you look up the DEFINE-COMPILER-MACRO
+ ;; macro in the ANSI spec, you might think that
+ ;; suppressing compiler-macro expansion when NOTINLINE
+ ;; is some pre-ANSI hack. However, if you look up the
+ ;; NOTINLINE declaration, you'll find that ANSI
+ ;; requires this behavior after all.
+ (not (eq (info :function :inlinep fun-name) :notinline)))
+ (let ((res (careful-expand-macro cmacro-fun form)))
(if (eq res form)
- (ir1-convert-global-functoid-no-cmacro start cont form fun)
+ (ir1-convert-global-functoid-no-cmacro
+ start cont form fun-name)
(ir1-convert start cont res))))
(t
- (ir1-convert-global-functoid-no-cmacro start cont form fun)))))
+ (ir1-convert-global-functoid-no-cmacro start cont form fun-name)))))
;;; Handle the case of where the call was not a compiler macro, or was
;;; a compiler macro and passed.
(defun muffle-warning-or-die ()
(muffle-warning)
- (error "internal error -- no MUFFLE-WARNING restart"))
+ (bug "no MUFFLE-WARNING restart"))
;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping
;;; errors which occur during the macroexpansion.
;; or the cross-compiler which encountered the problem?"
#+sb-xc-host "(in cross-compiler macroexpansion of ~S)"
form))))
- (handler-bind (;; When cross-compiling, we can get style warnings
- ;; about e.g. undefined functions. An unhandled
- ;; CL:STYLE-WARNING (as opposed to a
- ;; SB!C::COMPILER-NOTE) would cause FAILURE-P to be
- ;; set on the return from #'SB!XC:COMPILE-FILE, which
- ;; would falsely indicate an error sufficiently
- ;; serious that we should stop the build process. To
- ;; avoid this, we translate CL:STYLE-WARNING
- ;; conditions from the host Common Lisp into
- ;; cross-compiler SB!C::COMPILER-NOTE calls. (It
- ;; might be cleaner to just make Python use
- ;; CL:STYLE-WARNING internally, so that the
- ;; significance of any host Common Lisp
- ;; CL:STYLE-WARNINGs is understood automatically. But
- ;; for now I'm not motivated to do this. -- WHN
- ;; 19990412)
- (style-warning (lambda (c)
- (compiler-note "~@<~A~:@_~A~:@_~A~:>"
- (wherestring) hint c)
- (muffle-warning-or-die)))
- ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for
+ (handler-bind ((style-warning (lambda (c)
+ (compiler-style-warn
+ "~@<~A~:@_~A~@:_~A~:>"
+ (wherestring) hint c)
+ (muffle-warning-or-die)))
+ ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for
;; Debian Linux, anyway) raises a CL:WARNING
;; condition (not a CL:STYLE-WARNING) for undefined
;; symbols when converting interpreted functions,
;; and this code does so, by crudely suppressing all
;; warnings in cross-compilation macroexpansion. --
;; WHN 19990412
- #+cmu
+ #+(and cmu sb-xc-host)
(warning (lambda (c)
(compiler-note
"~@<~A~:@_~
(wherestring)
c)
(muffle-warning-or-die)))
+ #-(and cmu sb-xc-host)
+ (warning (lambda (c)
+ (compiler-warn "~@<~A~:@_~A~@:_~A~:>"
+ (wherestring) hint c)
+ (muffle-warning-or-die)))
(error (lambda (c)
(compiler-error "~@<~A~:@_~A~@:_~A~:>"
(wherestring) hint c))))
(let ((node (make-combination fun-cont)))
(setf (continuation-dest fun-cont) node)
(assert-continuation-type fun-cont
- (specifier-type '(or function symbol)))
+ (specifier-type '(or function symbol))
+ (lexenv-policy *lexenv*))
+ (setf (continuation-%externally-checkable-type fun-cont) nil)
(collect ((arg-conts))
(let ((this-start fun-cont))
(dolist (arg args)
(setf (continuation-%type-check fun-cont) nil)))
(values))
-;;; Convert a call to a local function. If the function has already
-;;; been LET converted, then throw FUN to LOCAL-CALL-LOSSAGE. This
-;;; should only happen when we are converting inline expansions for
-;;; local functions during optimization.
-(defun ir1-convert-local-combination (start cont form fun)
- (if (functional-kind fun)
- (throw 'local-call-lossage fun)
- (ir1-convert-combination start cont form
- (maybe-reanalyze-fun fun))))
+;;; Convert a call to a local function, or if the function has already
+;;; been LET converted, then throw FUNCTIONAL to
+;;; LOCALL-ALREADY-LET-CONVERTED. The THROW should only happen when we
+;;; are converting inline expansions for local functions during
+;;; optimization.
+(defun ir1-convert-local-combination (start cont form functional)
+
+ ;; The test here is for "when LET converted", as a translation of
+ ;; the old CMU CL comments into code. Unfortunately, the old CMU CL
+ ;; comments aren't specific enough to tell whether the correct
+ ;; translation is FUNCTIONAL-SOMEWHAT-LETLIKE-P or
+ ;; FUNCTIONAL-LETLIKE-P or what. The old CMU CL code assumed that
+ ;; any non-null FUNCTIONAL-KIND meant that the function "had been
+ ;; LET converted", which might even be right, but seems fragile, so
+ ;; we try to be pickier.
+ (when (or
+ ;; looks LET-converted
+ (functional-somewhat-letlike-p functional)
+ ;; It's possible for a LET-converted function to end up
+ ;; deleted later. In that case, for the purposes of this
+ ;; analysis, it is LET-converted: LET-converted functionals
+ ;; are too badly trashed to expand them inline, and deleted
+ ;; LET-converted functionals are even worse.
+ (eql (functional-kind functional) :deleted))
+ (throw 'locall-already-let-converted functional))
+ ;; Any other non-NIL KIND value is a case we haven't found a
+ ;; justification for, and at least some such values (e.g. :EXTERNAL
+ ;; and :TOPLEVEL) seem obviously wrong.
+ (aver (null (functional-kind functional)))
+
+ (ir1-convert-combination start
+ cont
+ form
+ (maybe-reanalyze-functional functional)))
\f
;;;; PROCESS-DECLS
(setf found (cdr var)))))
found))
-;;; Called by Process-Decls to deal with a variable type declaration.
-;;; If a lambda-var being bound, we intersect the type with the vars
-;;; type, otherwise we add a type-restriction on the var. If a symbol
+;;; Called by PROCESS-DECLS to deal with a variable type declaration.
+;;; If a LAMBDA-VAR being bound, we intersect the type with the var's
+;;; type, otherwise we add a type restriction on the var. If a symbol
;;; macro, we just wrap a THE around the expansion.
(defun process-type-decl (decl res vars)
(declare (list decl vars) (type lexenv res))
- (let ((type (specifier-type (first decl))))
+ (let ((type (compiler-specifier-type (first decl))))
(collect ((restr nil cons)
- (new-vars nil cons))
+ (new-vars nil cons))
(dolist (var-name (rest decl))
(let* ((bound-var (find-in-bindings vars var-name))
(var (or bound-var
(find-free-var var-name))))
(etypecase var
(leaf
- (let* ((old-type (or (lexenv-find var type-restrictions)
- (leaf-type var)))
- (int (if (or (fun-type-p type)
- (fun-type-p old-type))
- type
- (type-approx-intersection2 old-type type))))
- (cond ((eq int *empty-type*)
- (unless (policy *lexenv* (= inhibit-warnings 3))
- (compiler-warn
- "The type declarations ~S and ~S for ~S conflict."
- (type-specifier old-type) (type-specifier type)
- var-name)))
- (bound-var (setf (leaf-type bound-var) int))
- (t
- (restr (cons var int))))))
+ (flet ((process-var (var bound-var)
+ (let* ((old-type (or (lexenv-find var type-restrictions)
+ (leaf-type var)))
+ (int (if (or (fun-type-p type)
+ (fun-type-p old-type))
+ type
+ (type-approx-intersection2 old-type type))))
+ (cond ((eq int *empty-type*)
+ (unless (policy *lexenv* (= inhibit-warnings 3))
+ (compiler-warn
+ "The type declarations ~S and ~S for ~S conflict."
+ (type-specifier old-type) (type-specifier type)
+ var-name)))
+ (bound-var (setf (leaf-type bound-var) int))
+ (t
+ (restr (cons var int)))))))
+ (process-var var bound-var)
+ (awhen (and (lambda-var-p var)
+ (lambda-var-specvar var))
+ (process-var it nil))))
(cons
;; FIXME: non-ANSI weirdness
(aver (eq (car var) 'MACRO))
(new-vars `(,var-name . (MACRO . (the ,(first decl)
- ,(cdr var))))))
+ ,(cdr var))))))
(heap-alien-info
(compiler-error
"~S is an alien variable, so its type can't be declared."
;;; declarations that constrain the type of lexically apparent
;;; functions.
(defun process-ftype-decl (spec res names fvars)
- (declare (list spec names fvars) (type lexenv res))
- (let ((type (specifier-type spec)))
+ (declare (type type-specifier spec)
+ (type list names fvars)
+ (type lexenv res))
+ (let ((type (compiler-specifier-type spec)))
(collect ((res nil cons))
(dolist (name names)
(let ((found (find name fvars
(make-lexenv :default res :funs new-fenv)
res)))
-;;; Like FIND-IN-BINDINGS, but looks for #'foo in the fvars.
+;;; like FIND-IN-BINDINGS, but looks for #'FOO in the FVARS
(defun find-in-bindings-or-fbindings (name vars fvars)
(declare (list vars fvars))
(if (consp name)
)
((functional-p var)
(setf (leaf-ever-used var) t))
- ((lambda-var-specvar var)
+ ((and (lambda-var-specvar var) (eq (first spec) 'ignore))
;; ANSI's definition for "Declaration IGNORE, IGNORABLE"
;; requires that this be a STYLE-WARNING, not a full WARNING.
(compiler-style-warn "declaring special variable ~S to be ignored"
(special (process-special-decl spec res vars))
(ftype
(unless (cdr spec)
- (compiler-error "No type specified in FTYPE declaration: ~S" spec))
+ (compiler-error "no type specified in FTYPE declaration: ~S" spec))
(process-ftype-decl (second spec) res (cddr spec) fvars))
((inline notinline maybe-inline)
(process-inline-decl spec res fvars))
`(values ,@types))
cont
res
- 'values))))
+ "in VALUES declaration"))))
(dynamic-extent
(when (policy *lexenv* (> speed inhibit-warnings))
(compiler-note
(dolist (decl decls)
(dolist (spec (rest decl))
(unless (consp spec)
- (compiler-error "malformed declaration specifier ~S in ~S"
- spec
- decl))
+ (compiler-error "malformed declaration specifier ~S in ~S" spec decl))
(setq env (process-1-decl spec env vars fvars cont))))
env)
(unless (symbolp name)
(compiler-error "The lambda variable ~S is not a symbol." name))
(when (member name names-so-far :test #'eq)
- (compiler-error "The variable ~S occurs more than once in the lambda-list."
+ (compiler-error "The variable ~S occurs more than once in the lambda list."
name))
(let ((kind (info :variable :kind name)))
(when (or (keywordp name) (eq kind :constant))
:where-from (leaf-where-from specvar)
:specvar specvar)))
(t
- (note-lexical-binding name)
(make-lambda-var :%source-name name)))))
;;; Make the default keyword for a &KEY arg, checking that the keyword
-;;; isn't already used by one of the VARS. We also check that the
-;;; keyword isn't the magical :ALLOW-OTHER-KEYS.
+;;; isn't already used by one of the VARS.
(declaim (ftype (function (symbol list t) keyword) make-keyword-for-arg))
(defun make-keyword-for-arg (symbol vars keywordify)
(let ((key (if (and keywordify (not (keywordp symbol)))
(keywordicate symbol)
symbol)))
- (when (eq key :allow-other-keys)
- (compiler-error "No &KEY arg can be called :ALLOW-OTHER-KEYS."))
(dolist (var vars)
(let ((info (lambda-var-arg-info var)))
(when (and info
(eq (arg-info-kind info) :keyword)
(eq (arg-info-key info) key))
(compiler-error
- "The keyword ~S appears more than once in the lambda-list."
+ "The keyword ~S appears more than once in the lambda list."
key))))
key))
(declaim (ftype (function (list) (values list boolean boolean list list))
make-lambda-vars))
(defun make-lambda-vars (list)
- (multiple-value-bind (required optional restp rest keyp keys allowp aux
+ (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
morep more-context more-count)
(parse-lambda-list list)
+ (declare (ignore auxp)) ; since we just iterate over AUX regardless
(collect ((vars)
(names-so-far)
(aux-vars)
(dolist (spec optional)
(if (atom spec)
(let ((var (varify-lambda-arg spec (names-so-far))))
- (setf (lambda-var-arg-info var) (make-arg-info :kind :optional))
+ (setf (lambda-var-arg-info var)
+ (make-arg-info :kind :optional))
(vars var)
(names-so-far spec))
(let* ((name (first spec))
;;; Create a lambda node out of some code, returning the result. The
;;; bindings are specified by the list of VAR structures VARS. We deal
;;; with adding the names to the LEXENV-VARS for the conversion. The
-;;; result is added to the NEW-FUNS in the *CURRENT-COMPONENT* and
-;;; linked to the component head and tail.
+;;; result is added to the NEW-FUNCTIONALS in the *CURRENT-COMPONENT*
+;;; and linked to the component head and tail.
;;;
;;; We detect special bindings here, replacing the original VAR in the
;;; lambda list with a temporary variable. We then pass a list of the
aux-vals
result
(source-name '.anonymous.)
- debug-name)
+ debug-name
+ (note-lexical-bindings t))
(declare (list body vars aux-vars aux-vals)
(type (or continuation null) result))
(svars var)
(new-venv (cons (leaf-source-name specvar) specvar)))
(t
- (note-lexical-binding (leaf-source-name var))
+ (when note-lexical-bindings
+ (note-lexical-binding (leaf-source-name var)))
(new-venv (cons (leaf-source-name var) var))))))
(let ((*lexenv* (make-lexenv :vars (new-venv)
:cleanup nil)))
(setf (bind-lambda bind) lambda)
(setf (node-lexenv bind) *lexenv*)
-
+
(let ((cont1 (make-continuation))
(cont2 (make-continuation)))
(continuation-starts-block cont1)
(link-node-to-previous-continuation bind cont1)
(use-continuation bind cont2)
- (ir1-convert-special-bindings cont2 result body aux-vars aux-vals
- (svars)))
+ (ir1-convert-special-bindings cont2 result body
+ aux-vars aux-vals (svars)))
(let ((block (continuation-block result)))
(when block
(setf (lambda-tail-set lambda) tail-set)
(setf (lambda-return lambda) return)
(setf (continuation-dest result) return)
+ (setf (continuation-%externally-checkable-type result) nil)
(setf (block-last block) return)
(link-node-to-previous-continuation return result)
(use-continuation return dummy))
(link-blocks block (component-tail *current-component*))))))
(link-blocks (component-head *current-component*) (node-block bind))
- (push lambda (component-new-funs *current-component*))
+ (push lambda (component-new-functionals *current-component*))
lambda))
(declare (type clambda fun) (list vars vals defaults))
(let* ((fvars (reverse vars))
(arg-vars (mapcar (lambda (var)
- (unless (lambda-var-specvar var)
- (note-lexical-binding (leaf-source-name var)))
(make-lambda-var
:%source-name (leaf-source-name var)
:type (leaf-type var)
:where-from (leaf-where-from var)
:specvar (lambda-var-specvar var)))
fvars))
- (fun (ir1-convert-lambda-body `((%funcall ,fun
- ,@(reverse vals)
- ,@defaults))
- arg-vars
- :debug-name "&OPTIONAL processor")))
+ (fun (collect ((default-bindings)
+ (default-vals))
+ (dolist (default defaults)
+ (if (constantp default)
+ (default-vals default)
+ (let ((var (gensym)))
+ (default-bindings `(,var ,default))
+ (default-vals var))))
+ (ir1-convert-lambda-body `((let (,@(default-bindings))
+ (%funcall ,fun
+ ,@(reverse vals)
+ ,@(default-vals))))
+ arg-vars
+ :debug-name "&OPTIONAL processor"
+ :note-lexical-bindings nil))))
(mapc (lambda (var arg-var)
(when (cdr (leaf-refs arg-var))
(setf (leaf-ever-used var) t)))
(n-allowp (gensym "N-ALLOWP-"))
(n-losep (gensym "N-LOSEP-"))
(allowp (or (optional-dispatch-allowp res)
- (policy *lexenv* (zerop safety)))))
+ (policy *lexenv* (zerop safety))))
+ (found-allow-p nil))
(temps `(,n-index (1- ,n-count)) n-key n-value-temp)
(body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp)))
(default (arg-info-default info))
(keyword (arg-info-key info))
(supplied-p (arg-info-supplied-p info))
- (n-value (gensym "N-VALUE-")))
- (temps `(,n-value ,default))
- (cond (supplied-p
- (let ((n-supplied (gensym "N-SUPPLIED-")))
- (temps n-supplied)
- (arg-vals n-value n-supplied)
- (tests `((eq ,n-key ',keyword)
- (setq ,n-supplied t)
- (setq ,n-value ,n-value-temp)))))
- (t
- (arg-vals n-value)
- (tests `((eq ,n-key ',keyword)
- (setq ,n-value ,n-value-temp)))))))
+ (n-value (gensym "N-VALUE-"))
+ (clause (cond (supplied-p
+ (let ((n-supplied (gensym "N-SUPPLIED-")))
+ (temps n-supplied)
+ (arg-vals n-value n-supplied)
+ `((eq ,n-key ',keyword)
+ (setq ,n-supplied t)
+ (setq ,n-value ,n-value-temp))))
+ (t
+ (arg-vals n-value)
+ `((eq ,n-key ',keyword)
+ (setq ,n-value ,n-value-temp))))))
+ (when (and (not allowp) (eq keyword :allow-other-keys))
+ (setq found-allow-p t)
+ (setq clause
+ (append clause `((setq ,n-allowp ,n-value-temp)))))
+
+ (temps `(,n-value ,default))
+ (tests clause)))
(unless allowp
(temps n-allowp n-losep)
- (tests `((eq ,n-key :allow-other-keys)
- (setq ,n-allowp ,n-value-temp)))
+ (unless found-allow-p
+ (tests `((eq ,n-key :allow-other-keys)
+ (setq ,n-allowp ,n-value-temp))))
(tests `(t
(setq ,n-losep ,n-key))))
`((let ,(temps)
,@(body)
(%funcall ,(optional-dispatch-main-entry res)
- . ,(arg-vals)))) ; FIXME: What is the '.'? ,@?
+ ,@(arg-vals))))
(arg-vars)
- :debug-name (debug-namify "~S processing" '&more))))
+ :debug-name (debug-namify "~S processing" '&more)
+ :note-lexical-bindings nil)))
(setf (optional-dispatch-more-entry res) ep))))
(values))
:aux-vars (append (bind-vars) aux-vars)
:aux-vals (append (bind-vals) aux-vals)
:result cont
- :debug-name (debug-namify "varargs entry point for ~A"
+ :debug-name (debug-namify "varargs entry for ~A"
(as-debug-name source-name
debug-name))))
(last-entry (convert-optional-entry main-entry default-vars
:%debug-name debug-name))
(min (or (position-if #'lambda-var-arg-info vars) (length vars))))
(aver-live-component *current-component*)
- (push res (component-new-funs *current-component*))
+ (push res (component-new-functionals *current-component*))
(ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals
cont source-name debug-name)
(setf (optional-dispatch-min-args res) min)
res))
;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf.
-(defun ir1-convert-lambda (form &key (source-name '.anonymous.) debug-name)
+(defun ir1-convert-lambda (form &key (source-name '.anonymous.)
+ debug-name
+ allow-debug-catch-tag)
(unless (consp form)
(compiler-error "A ~S was found when expecting a lambda expression:~% ~S"
"The lambda expression has a missing or non-list lambda list:~% ~S"
form))
- (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
- (make-lambda-vars (cadr form))
- (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr form))
- (let* ((result-cont (make-continuation))
- (*lexenv* (process-decls decls
- (append aux-vars vars)
- nil result-cont))
- (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
- (ir1-convert-hairy-lambda forms vars keyp
- allow-other-keys
- aux-vars aux-vals result-cont
- :source-name source-name
- :debug-name debug-name)
- (ir1-convert-lambda-body forms vars
- :aux-vars aux-vars
- :aux-vals aux-vals
- :result result-cont
- :source-name source-name
- :debug-name debug-name))))
- (setf (functional-inline-expansion res) form)
- (setf (functional-arg-documentation res) (cadr form))
- res))))
+ (let ((*allow-debug-catch-tag* (and *allow-debug-catch-tag* allow-debug-catch-tag)))
+ (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
+ (make-lambda-vars (cadr form))
+ (multiple-value-bind (forms decls) (parse-body (cddr form))
+ (let* ((result-cont (make-continuation))
+ (*lexenv* (process-decls decls
+ (append aux-vars vars)
+ nil result-cont))
+ (forms (if (and *allow-debug-catch-tag*
+ (policy *lexenv* (> debug (max speed space))))
+ `((catch (make-symbol "SB-DEBUG-CATCH-TAG")
+ ,@forms))
+ forms))
+ (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
+ (ir1-convert-hairy-lambda forms vars keyp
+ allow-other-keys
+ aux-vars aux-vals result-cont
+ :source-name source-name
+ :debug-name debug-name)
+ (ir1-convert-lambda-body forms vars
+ :aux-vars aux-vars
+ :aux-vals aux-vals
+ :result result-cont
+ :source-name source-name
+ :debug-name debug-name))))
+ (setf (functional-inline-expansion res) form)
+ (setf (functional-arg-documentation res) (cadr form))
+ res)))))
+
+;;; helper for LAMBDA-like things, to massage them into a form
+;;; suitable for IR1-CONVERT-LAMBDA.
+;;;
+;;; KLUDGE: We cons up a &REST list here, maybe for no particularly
+;;; good reason. It's probably lost in the noise of all the other
+;;; consing, but it's still inelegant. And we force our called
+;;; functions to do full runtime keyword parsing, ugh. -- CSR,
+;;; 2003-01-25
+(defun ir1-convert-lambdalike (thing &rest args
+ &key (source-name '.anonymous.)
+ debug-name allow-debug-catch-tag)
+ (ecase (car thing)
+ ((lambda) (apply #'ir1-convert-lambda thing args))
+ ((instance-lambda)
+ (let ((res (apply #'ir1-convert-lambda
+ `(lambda ,@(cdr thing)) args)))
+ (setf (getf (functional-plist res) :fin-function) t)
+ res))
+ ((named-lambda)
+ (let ((name (cadr thing)))
+ (if (legal-fun-name-p name)
+ (let ((res (apply #'ir1-convert-lambda `(lambda ,@(cddr thing))
+ :source-name name
+ :debug-name nil
+ args)))
+ (assert-global-function-definition-type name res)
+ res)
+ (apply #'ir1-convert-lambda `(lambda ,@(cddr thing))
+ :debug-name name args))))
+ ((lambda-with-lexenv) (apply #'ir1-convert-inline-lambda thing args))))
\f
;;;; defining global functions
;;; reflect the state at the definition site.
(defun ir1-convert-inline-lambda (fun &key
(source-name '.anonymous.)
- debug-name)
+ debug-name
+ allow-debug-catch-tag)
(destructuring-bind (decls macros symbol-macros &rest body)
(if (eq (car fun) 'lambda-with-lexenv)
(cdr fun)
:policy (lexenv-policy *lexenv*))))
(ir1-convert-lambda `(lambda ,@body)
:source-name source-name
- :debug-name debug-name))))
+ :debug-name debug-name
+ :allow-debug-catch-tag nil))))
-;;; Get a DEFINED-FUN object for a function we are about to
-;;; define. If the function has been forward referenced, then
-;;; substitute for the previous references.
+;;; Get a DEFINED-FUN object for a function we are about to define. If
+;;; the function has been forward referenced, then substitute for the
+;;; previous references.
(defun get-defined-fun (name)
(proclaim-as-fun-name name)
(let ((found (find-free-fun name "shouldn't happen! (defined-fun)")))
(unless (eq (defined-fun-inlinep var) :inline)
(setf (defined-fun-inline-expansion var) nil))
(let* ((name (leaf-source-name var))
- (fun (funcall converter lambda :source-name name))
+ (fun (funcall converter lambda
+ :source-name name))
(fun-info (info :function :info name)))
(setf (functional-inlinep fun) (defined-fun-inlinep var))
(assert-new-definition var fun)
(setf (defined-fun-inline-expansion var) var-expansion)
- ;; If definitely not an interpreter stub, then substitute for any
- ;; old references.
+ ;; If definitely not an interpreter stub, then substitute for
+ ;; any old references.
(unless (or (eq (defined-fun-inlinep var) :notinline)
(not *block-compile*)
(and fun-info
projects / sbcl.git / blobdiff