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)
+(defvar *fun-names-in-this-file* nil)
\f
;;;; namespace management utilities
+(defun fun-lexically-notinline-p (name)
+ (let ((fun (lexenv-find name funs :test #'equal)))
+ ;; a declaration will trump a proclamation
+ (if (and fun (defined-fun-p fun))
+ (eq (defined-fun-inlinep fun) :notinline)
+ (eq (info :function :inlinep name) :notinline))))
+
;;; Return a GLOBAL-VAR structure usable for referencing the global
;;; function NAME.
(defun find-free-really-fun (name)
;; definedness at runtime, which is what matters.
#-sb-xc-host (not (fboundp name)))
(note-undefined-reference name :function))
- (make-global-var :kind :global-function
- :%source-name name
- :type (if (or *derive-function-types*
- (eq where :declared))
- (info :function :type name)
- (specifier-type 'function))
- :where-from where)))
+ (make-global-var
+ :kind :global-function
+ :%source-name name
+ :type (if (or *derive-function-types*
+ (eq where :declared)
+ (and (member name *fun-names-in-this-file* :test #'equal)
+ (not (fun-lexically-notinline-p name))))
+ (info :function :type name)
+ (specifier-type 'function))
+ :where-from where)))
;;; Has the *FREE-FUNS* entry FREE-FUN become invalid?
;;;
;;; 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))
+(declaim (ftype (sfunction (t string) global-var) find-free-fun))
(defun find-free-fun (name context)
(or (let ((old-free-fun (gethash name *free-funs*)))
(and (not (invalid-free-fun-p old-free-fun))
:inline-expansion expansion
:inlinep inlinep
:where-from (info :function :where-from name)
- :type (info :function :type name))
+ :type (if (eq inlinep :notinline)
+ (specifier-type 'function)
+ (info :function :type name)))
(find-free-really-fun name))))))))
;;; Return the LEAF structure for the lexically apparent function
;;; definition of NAME.
-(declaim (ftype (function (t string) leaf) find-lexically-apparent-fun))
+(declaim (ftype (sfunction (t string) leaf) find-lexically-apparent-fun))
(defun find-lexically-apparent-fun (name context)
(let ((var (lexenv-find name funs :test #'equal)))
(cond (var
;;; 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))
+(declaim (ftype (sfunction (t) (or leaf cons heap-alien-info)) find-free-var))
(defun find-free-var (name)
(unless (symbolp name)
(compiler-error "Variable name is not a symbol: ~S." name))
;; can't contain other objects
(unless (typep value
'(or #-sb-xc-host unboxed-array
+ #+sb-xc-host (simple-array (unsigned-byte 8) (*))
symbol
number
character
;;;; some flow-graph hacking utilities
;;; This function sets up the back link between the node and the
-;;; continuation which continues at it.
-(defun link-node-to-previous-continuation (node cont)
- (declare (type node node) (type continuation cont))
- (aver (not (continuation-next cont)))
- (setf (continuation-next cont) node)
- (setf (node-prev node) cont))
+;;; ctran which continues at it.
+(defun link-node-to-previous-ctran (node ctran)
+ (declare (type node node) (type ctran ctran))
+ (aver (not (ctran-next ctran)))
+ (setf (ctran-next ctran) node)
+ (setf (node-prev node) ctran))
-;;; This function is used to set the continuation for a node, and thus
-;;; determine what receives the value and what is evaluated next. If
-;;; the continuation has no block, then we make it be in the block
-;;; that the node is in. If the continuation heads its block, we end
-;;; our block and link it to that block. If the continuation is not
-;;; currently used, then we set the DERIVED-TYPE for the continuation
-;;; to that of the node, so that a little type propagation gets done.
-#!-sb-fluid (declaim (inline use-continuation))
-(defun use-continuation (node cont)
- (declare (type node node) (type continuation cont))
- (let ((node-block (continuation-block (node-prev node))))
- (case (continuation-kind cont)
- (:unused
- (setf (continuation-block cont) node-block)
- (setf (continuation-kind cont) :inside-block)
- (setf (continuation-use cont) node)
- (setf (node-cont node) cont))
- (t
- (%use-continuation node cont)))))
-(defun %use-continuation (node cont)
- (declare (type node node) (type continuation cont) (inline member))
- (let ((block (continuation-block cont))
- (node-block (continuation-block (node-prev node))))
- (aver (eq (continuation-kind cont) :block-start))
+;;; This function is used to set the ctran for a node, and thus
+;;; determine what is evaluated next. If the ctran has no block, then
+;;; we make it be in the block that the node is in. If the ctran heads
+;;; its block, we end our block and link it to that block.
+#!-sb-fluid (declaim (inline use-ctran))
+(defun use-ctran (node ctran)
+ (declare (type node node) (type ctran ctran))
+ (if (eq (ctran-kind ctran) :unused)
+ (let ((node-block (ctran-block (node-prev node))))
+ (setf (ctran-block ctran) node-block)
+ (setf (ctran-kind ctran) :inside-block)
+ (setf (ctran-use ctran) node)
+ (setf (node-next node) ctran))
+ (%use-ctran node ctran)))
+(defun %use-ctran (node ctran)
+ (declare (type node node) (type ctran ctran) (inline member))
+ (let ((block (ctran-block ctran))
+ (node-block (ctran-block (node-prev node))))
+ (aver (eq (ctran-kind ctran) :block-start))
(when (block-last node-block)
(error "~S has already ended." node-block))
(setf (block-last node-block) node)
(setf (block-succ node-block) (list block))
(when (memq node-block (block-pred block))
(error "~S is already a predecessor of ~S." node-block block))
- (push node-block (block-pred block))
- (add-continuation-use node cont)
- (reoptimize-continuation cont)))
+ (push node-block (block-pred block))))
+
+;;; This function is used to set the ctran for a node, and thus
+;;; determine what receives the value.
+(defun use-lvar (node lvar)
+ (declare (type valued-node node) (type (or lvar null) lvar))
+ (aver (not (node-lvar node)))
+ (when lvar
+ (setf (node-lvar node) lvar)
+ (cond ((null (lvar-uses lvar))
+ (setf (lvar-uses lvar) node))
+ ((listp (lvar-uses lvar))
+ (aver (not (memq node (lvar-uses lvar))))
+ (push node (lvar-uses lvar)))
+ (t
+ (aver (neq node (lvar-uses lvar)))
+ (setf (lvar-uses lvar) (list node (lvar-uses lvar)))))
+ (reoptimize-lvar lvar)))
+
+#!-sb-fluid(declaim (inline use-continuation))
+(defun use-continuation (node ctran lvar)
+ (use-ctran node ctran)
+ (use-lvar node lvar))
\f
;;;; exported functions
(declare (list path))
(let* ((*current-path* path)
(component (make-empty-component))
- (*current-component* component))
- (setf (component-name component) "initial component")
+ (*current-component* component)
+ (*allow-instrumenting* t))
+ (setf (component-name component) 'initial-component)
(setf (component-kind component) :initial)
(let* ((forms (if for-value `(,form) `(,form nil)))
(res (ir1-convert-lambda-body
forms ()
- :debug-name (debug-namify "top level form ~S" form))))
+ :debug-name (debug-name 'top-level-form form))))
(setf (functional-entry-fun res) res
(functional-arg-documentation res) ()
(functional-kind res) :toplevel)
\f
;;;; IR1-CONVERT, macroexpansion and special form dispatching
+(declaim (ftype (sfunction (ctran ctran (or lvar null) t) (values))
+ ir1-convert))
(macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws
- ;; out of the body and converts a proxy form instead.
- (ir1-error-bailout ((start
- cont
- form
- &optional
- (proxy ``(error 'simple-program-error
- :format-control "execution of a form compiled with errors:~% ~S"
- :format-arguments (list ',,form))))
- &body body)
- (with-unique-names (skip)
- `(block ,skip
- (catch 'ir1-error-abort
+ ;; out of the body and converts a condition signalling form
+ ;; instead. The source form is converted to a string since it
+ ;; may contain arbitrary non-externalizable objects.
+ (ir1-error-bailout ((start next result form) &body body)
+ (with-unique-names (skip condition)
+ `(block ,skip
+ (let ((,condition (catch 'ir1-error-abort
(let ((*compiler-error-bailout*
- (lambda ()
- (throw 'ir1-error-abort nil))))
+ (lambda (&optional e)
+ (throw 'ir1-error-abort e))))
,@body
- (return-from ,skip nil)))
- (ir1-convert ,start ,cont ,proxy)))))
+ (return-from ,skip nil)))))
+ (ir1-convert ,start ,next ,result
+ (make-compiler-error-form ,condition ,form)))))))
;; Translate FORM into IR1. The code is inserted as the NEXT of the
- ;; continuation START. CONT is the continuation which receives the
- ;; value of the FORM to be translated. The translators call this
- ;; function recursively to translate their subnodes.
+ ;; CTRAN START. RESULT is the LVAR which receives the value of the
+ ;; FORM to be translated. The translators call this function
+ ;; recursively to translate their subnodes.
;;
;; As a special hack to make life easier in the compiler, a LEAF
;; IR1-converts into a reference to that LEAF structure. This allows
;; the creation using backquote of forms that contain leaf
;; references, without having to introduce dummy names into the
;; namespace.
- (declaim (ftype (function (continuation continuation t) (values)) ir1-convert))
- (defun ir1-convert (start cont form)
- (ir1-error-bailout (start cont form)
+ (defun ir1-convert (start next result form)
+ (ir1-error-bailout (start next result form)
(let ((*current-path* (or (gethash form *source-paths*)
(cons form *current-path*))))
- (if (atom form)
- (cond ((and (symbolp form) (not (keywordp form)))
- (ir1-convert-var start cont form))
- ((leaf-p form)
- (reference-leaf start cont form))
- (t
- (reference-constant start cont form)))
- (let ((opname (car form)))
- (cond ((or (symbolp opname) (leaf-p opname))
- (let ((lexical-def (if (leaf-p opname)
- opname
- (lexenv-find opname funs))))
- (typecase lexical-def
- (null (ir1-convert-global-functoid start cont form))
- (functional
- (ir1-convert-local-combination start
- cont
- form
- lexical-def))
- (global-var
- (ir1-convert-srctran start cont lexical-def form))
- (t
- (aver (and (consp lexical-def)
- (eq (car lexical-def) 'macro)))
- (ir1-convert start cont
- (careful-expand-macro (cdr lexical-def)
- form))))))
- ((or (atom opname) (not (eq (car opname) 'lambda)))
- (compiler-error "illegal function call"))
- (t
- ;; implicitly (LAMBDA ..) because the LAMBDA
- ;; expression is the CAR of an executed form
- (ir1-convert-combination start
- cont
- form
- (ir1-convert-lambda
- opname
- :debug-name (debug-namify
- "LAMBDA CAR ~S"
- opname)
- :allow-debug-catch-tag t))))))))
+ (cond ((step-form-p form)
+ (ir1-convert-step start next result form))
+ ((atom form)
+ (cond ((and (symbolp form) (not (keywordp form)))
+ (ir1-convert-var start next result form))
+ ((leaf-p form)
+ (reference-leaf start next result form))
+ (t
+ (reference-constant start next result form))))
+ (t
+ (let ((opname (car form)))
+ (cond ((or (symbolp opname) (leaf-p opname))
+ (let ((lexical-def (if (leaf-p opname)
+ opname
+ (lexenv-find opname funs))))
+ (typecase lexical-def
+ (null
+ (ir1-convert-global-functoid start next result
+ form))
+ (functional
+ (ir1-convert-local-combination start next result
+ form
+ lexical-def))
+ (global-var
+ (ir1-convert-srctran start next result
+ lexical-def form))
+ (t
+ (aver (and (consp lexical-def)
+ (eq (car lexical-def) 'macro)))
+ (ir1-convert start next result
+ (careful-expand-macro (cdr lexical-def)
+ form))))))
+ ((or (atom opname) (not (eq (car opname) 'lambda)))
+ (compiler-error "illegal function call"))
+ (t
+ ;; implicitly (LAMBDA ..) because the LAMBDA
+ ;; expression is the CAR of an executed form
+ (ir1-convert-combination start next result
+ form
+ (ir1-convert-lambda
+ opname
+ :debug-name (debug-name
+ 'lambda-car
+ opname))))))))))
(values))
-
+
;; Generate a reference to a manifest constant, creating a new leaf
;; if necessary. If we are producing a fasl file, make sure that
;; MAKE-LOAD-FORM gets used on any parts of the constant that it
;; needs to be.
- (defun reference-constant (start cont value)
- (declare (type continuation start cont)
+ (defun reference-constant (start next result value)
+ (declare (type ctran start next)
+ (type (or lvar null) result)
(inline find-constant))
- (ir1-error-bailout
- (start cont value '(error "attempt to reference undumpable constant"))
+ (ir1-error-bailout (start next result value)
(when (producing-fasl-file)
(maybe-emit-make-load-forms value))
(let* ((leaf (find-constant value))
(res (make-ref leaf)))
(push res (leaf-refs leaf))
- (link-node-to-previous-continuation res start)
- (use-continuation res cont)))
+ (link-node-to-previous-ctran res start)
+ (use-continuation res next result)))
(values)))
;;; Add FUNCTIONAL to the COMPONENT-REANALYZE-FUNCTIONALS, unless it's
;;; needed. If LEAF represents a defined function which has already
;;; been converted, and is not :NOTINLINE, then reference the
;;; functional instead.
-(defun reference-leaf (start cont leaf)
- (declare (type continuation start cont) (type leaf leaf))
+(defun reference-leaf (start next result leaf)
+ (declare (type ctran start next) (type (or lvar null) result) (type leaf leaf))
+ (when (functional-p leaf)
+ (assure-functional-live-p leaf))
(let* ((type (lexenv-find leaf type-restrictions))
(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)))
+ (not (functional-kind functional))
+ ;; Bug MISC.320: ir1-transform
+ ;; can create a reference to a
+ ;; inline-expanded function,
+ ;; defined in another component.
+ (not (and (lambda-p functional)
+ (neq (lambda-component functional)
+ *current-component*))))
(maybe-reanalyze-functional functional))))
+ (when (and (lambda-p leaf)
+ (memq (functional-kind leaf)
+ '(nil :optional)))
+ (maybe-reanalyze-functional leaf))
leaf))
(ref (make-ref leaf)))
(push ref (leaf-refs leaf))
(setf (leaf-ever-used leaf) t)
- (link-node-to-previous-continuation ref start)
- (cond (type (let* ((ref-cont (make-continuation))
- (cast (make-cast ref-cont
+ (link-node-to-previous-ctran ref start)
+ (cond (type (let* ((ref-ctran (make-ctran))
+ (ref-lvar (make-lvar))
+ (cast (make-cast ref-lvar
(make-single-value-type type)
(lexenv-policy *lexenv*))))
- (setf (continuation-dest ref-cont) cast)
- (use-continuation ref ref-cont)
- (link-node-to-previous-continuation cast ref-cont)
- (use-continuation cast cont)))
- (t (use-continuation ref cont)))))
+ (setf (lvar-dest ref-lvar) cast)
+ (use-continuation ref ref-ctran ref-lvar)
+ (link-node-to-previous-ctran cast ref-ctran)
+ (use-continuation cast next result)))
+ (t (use-continuation ref next result)))))
;;; Convert a reference to a symbolic constant or variable. If the
;;; symbol is entered in the LEXENV-VARS we use that definition,
;;; otherwise we find the current global definition. This is also
;;; where we pick off symbol macro and alien variable references.
-(defun ir1-convert-var (start cont name)
- (declare (type continuation start cont) (symbol name))
+(defun ir1-convert-var (start next result name)
+ (declare (type ctran start next) (type (or lvar null) result) (symbol name))
(let ((var (or (lexenv-find name vars) (find-free-var name))))
(etypecase var
(leaf
(when (lambda-var-p var)
- (let ((home (continuation-home-lambda-or-null start)))
+ (let ((home (ctran-home-lambda-or-null start)))
(when home
(pushnew var (lambda-calls-or-closes home))))
(when (lambda-var-ignorep var)
;; (ANSI's specification for the IGNORE declaration requires
;; that this be a STYLE-WARNING, not a full WARNING.)
- (compiler-style-warn "reading an ignored variable: ~S" name)))
- (reference-leaf start cont var))
+ #-sb-xc-host
+ (compiler-style-warn "reading an ignored variable: ~S" name)
+ ;; there's no need for us to accept ANSI's lameness when
+ ;; processing our own code, though.
+ #+sb-xc-host
+ (warn "reading an ignored variable: ~S" name)))
+ (reference-leaf start next result var))
(cons
(aver (eq (car var) 'MACRO))
;; FIXME: [Free] type declarations. -- APD, 2002-01-26
- (ir1-convert start cont (cdr var)))
+ (ir1-convert start next result (cdr var)))
(heap-alien-info
- (ir1-convert start cont `(%heap-alien ',var)))))
+ (ir1-convert start next result `(%heap-alien ',var)))))
(values))
;;; Convert anything that looks like a special form, global function
;;; or compiler-macro call.
-(defun ir1-convert-global-functoid (start cont form)
- (declare (type continuation start cont) (list form))
+(defun ir1-convert-global-functoid (start next result form)
+ (declare (type ctran start next) (type (or lvar null) result) (list 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))
+ (funcall translator start next result form))
((and cmacro-fun
;; gotcha: If you look up the DEFINE-COMPILER-MACRO
;; macro in the ANSI spec, you might think that
(let ((res (careful-expand-macro cmacro-fun form)))
(if (eq res form)
(ir1-convert-global-functoid-no-cmacro
- start cont form fun-name)
- (ir1-convert start cont res))))
+ start next result form fun-name)
+ (ir1-convert start next result res))))
(t
- (ir1-convert-global-functoid-no-cmacro start cont form fun-name)))))
+ (ir1-convert-global-functoid-no-cmacro start next result
+ form fun-name)))))
;;; Handle the case of where the call was not a compiler macro, or was
;;; a compiler macro and passed.
-(defun ir1-convert-global-functoid-no-cmacro (start cont form fun)
- (declare (type continuation start cont) (list form))
+(defun ir1-convert-global-functoid-no-cmacro (start next result form fun)
+ (declare (type ctran start next) (type (or lvar null) result)
+ (list form))
;; FIXME: Couldn't all the INFO calls here be converted into
;; standard CL functions, like MACRO-FUNCTION or something?
;; And what happens with lexically-defined (MACROLET) macros
;; here, anyway?
(ecase (info :function :kind fun)
(:macro
- (ir1-convert start
- cont
+ (ir1-convert start next result
(careful-expand-macro (info :function :macro-function fun)
form)))
((nil :function)
- (ir1-convert-srctran start
- cont
+ (ir1-convert-srctran start next result
(find-free-fun fun "shouldn't happen! (no-cmacro)")
form))))
;; WHN 19990412
#+(and cmu sb-xc-host)
(warning (lambda (c)
- (compiler-note
+ (compiler-notify
"~@<~A~:@_~
~A~:@_~
~@<(KLUDGE: That was a non-STYLE WARNING. ~
(muffle-warning-or-die)))
#-(and cmu sb-xc-host)
(warning (lambda (c)
- (compiler-warn "~@<~A~:@_~A~@:_~A~:>"
- (wherestring) hint c)
+ (warn "~@<~A~:@_~A~@:_~A~:>"
+ (wherestring) hint c)
(muffle-warning-or-die)))
(error (lambda (c)
(compiler-error "~@<~A~:@_~A~@:_~A~:>"
;;; Convert a bunch of forms, discarding all the values except the
;;; last. If there aren't any forms, then translate a NIL.
-(declaim (ftype (function (continuation continuation list) (values))
+(declaim (ftype (sfunction (ctran ctran (or lvar null) list) (values))
ir1-convert-progn-body))
-(defun ir1-convert-progn-body (start cont body)
+(defun ir1-convert-progn-body (start next result body)
(if (endp body)
- (reference-constant start cont nil)
+ (reference-constant start next result nil)
(let ((this-start start)
(forms body))
(loop
(let ((form (car forms)))
(when (endp (cdr forms))
- (ir1-convert this-start cont form)
+ (ir1-convert this-start next result form)
(return))
- (let ((this-cont (make-continuation)))
- (ir1-convert this-start this-cont form)
- (setq this-start this-cont
+ (let ((this-ctran (make-ctran)))
+ (ir1-convert this-start this-ctran nil form)
+ (setq this-start this-ctran
forms (cdr forms)))))))
(values))
\f
;;; Convert a function call where the function FUN is a LEAF. FORM is
;;; the source for the call. We return the COMBINATION node so that
;;; the caller can poke at it if it wants to.
-(declaim (ftype (function (continuation continuation list leaf) combination)
+(declaim (ftype (sfunction (ctran ctran (or lvar null) list leaf) combination)
ir1-convert-combination))
-(defun ir1-convert-combination (start cont form fun)
- (let ((fun-cont (make-continuation)))
- (ir1-convert start fun-cont `(the (or function symbol) ,fun))
- (ir1-convert-combination-args fun-cont cont (cdr form))))
+(defun ir1-convert-combination (start next result form fun)
+ (let ((ctran (make-ctran))
+ (fun-lvar (make-lvar)))
+ (ir1-convert start ctran fun-lvar `(the (or function symbol) ,fun))
+ (ir1-convert-combination-args fun-lvar ctran next result (cdr form))))
;;; Convert the arguments to a call and make the COMBINATION
-;;; node. FUN-CONT is the continuation which yields the function to
-;;; call. ARGS is the list of arguments for the call, which defaults
-;;; to the cdr of source. We return the COMBINATION node.
-(defun ir1-convert-combination-args (fun-cont cont args)
- (declare (type continuation fun-cont cont) (list args))
- (let ((node (make-combination fun-cont)))
- (setf (continuation-dest fun-cont) node)
- (collect ((arg-conts))
- (let ((this-start fun-cont))
+;;; node. FUN-LVAR yields the function to call. ARGS is the list of
+;;; arguments for the call, which defaults to the cdr of source. We
+;;; return the COMBINATION node.
+(defun ir1-convert-combination-args (fun-lvar start next result args)
+ (declare (type ctran start next)
+ (type lvar fun-lvar)
+ (type (or lvar null) result)
+ (list args))
+ (let ((node (make-combination fun-lvar)))
+ (setf (lvar-dest fun-lvar) node)
+ (collect ((arg-lvars))
+ (let ((this-start start))
(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 (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 (combination-args node) (arg-lvars))))
node))
;;; Convert a call to a global function. If not :NOTINLINE, then we do
;;; expansion, but is :INLINE, then give an efficiency note (unless a
;;; known function which will quite possibly be open-coded.) Next, we
;;; go to ok-combination conversion.
-(defun ir1-convert-srctran (start cont var form)
- (declare (type continuation start cont) (type global-var var))
+(defun ir1-convert-srctran (start next result var form)
+ (declare (type ctran start next) (type (or lvar null) result)
+ (type global-var var))
(let ((inlinep (when (defined-fun-p var)
(defined-fun-inlinep var))))
(if (eq inlinep :notinline)
- (ir1-convert-combination start cont form var)
+ (ir1-convert-combination start next result form var)
(let ((transform (info :function
:source-transform
(leaf-source-name var))))
- (if transform
- (multiple-value-bind (result pass) (funcall transform form)
- (if pass
- (ir1-convert-maybe-predicate start cont form var)
- (ir1-convert start cont result)))
- (ir1-convert-maybe-predicate start cont form var))))))
+ (if transform
+ (multiple-value-bind (transformed pass) (funcall transform form)
+ (if pass
+ (ir1-convert-maybe-predicate start next result form var)
+ (ir1-convert start next result transformed)))
+ (ir1-convert-maybe-predicate start next result form var))))))
-;;; If the function has the PREDICATE attribute, and the CONT's DEST
+;;; If the function has the PREDICATE attribute, and the RESULT's DEST
;;; isn't an IF, then we convert (IF <form> T NIL), ensuring that a
;;; predicate always appears in a conditional context.
;;;
;;; If the function isn't a predicate, then we call
;;; IR1-CONVERT-COMBINATION-CHECKING-TYPE.
-(defun ir1-convert-maybe-predicate (start cont form var)
- (declare (type continuation start cont) (list form) (type global-var var))
+(defun ir1-convert-maybe-predicate (start next result form var)
+ (declare (type ctran start next)
+ (type (or lvar null) result)
+ (list form)
+ (type global-var var))
(let ((info (info :function :info (leaf-source-name var))))
(if (and info
(ir1-attributep (fun-info-attributes info) predicate)
- (not (if-p (continuation-dest cont))))
- (ir1-convert start cont `(if ,form t nil))
- (ir1-convert-combination-checking-type start cont form var))))
+ (not (if-p (and result (lvar-dest result)))))
+ (ir1-convert start next result `(if ,form t nil))
+ (ir1-convert-combination-checking-type start next result form var))))
;;; Actually really convert a global function call that we are allowed
;;; to early-bind.
;;; call is legal.
;;;
;;; If the call is legal, we also propagate type assertions from the
-;;; function type to the arg and result continuations. We do this now
-;;; so that IR1 optimize doesn't have to redundantly do the check
-;;; later so that it can do the type propagation.
-(defun ir1-convert-combination-checking-type (start cont form var)
- (declare (type continuation start cont) (list form) (type leaf var))
- (let* ((node (ir1-convert-combination start cont form var))
- (fun-cont (basic-combination-fun node))
+;;; function type to the arg and result lvars. We do this now so that
+;;; IR1 optimize doesn't have to redundantly do the check later so
+;;; that it can do the type propagation.
+(defun ir1-convert-combination-checking-type (start next result form var)
+ (declare (type ctran start next) (type (or lvar null) result)
+ (list form)
+ (type leaf var))
+ (let* ((node (ir1-convert-combination start next result form var))
+ (fun-lvar (basic-combination-fun node))
(type (leaf-type var)))
(when (validate-call-type node type t)
- (setf (continuation-%derived-type fun-cont)
+ (setf (lvar-%derived-type fun-lvar)
(make-single-value-type type))
- (setf (continuation-reoptimize fun-cont) nil)))
+ (setf (lvar-reoptimize fun-lvar) nil)))
(values))
;;; Convert a call to a local function, or if the function has already
;;; 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
+(defun ir1-convert-local-combination (start next result form functional)
+ (assure-functional-live-p functional)
+ (ir1-convert-combination start next result
form
(maybe-reanalyze-functional functional)))
\f
;;; LAMBDA-VAR for that name, or NIL if it isn't found. We return the
;;; *last* variable with that name, since LET* bindings may be
;;; duplicated, and declarations always apply to the last.
-(declaim (ftype (function (list symbol) (or lambda-var list))
+(declaim (ftype (sfunction (list symbol) (or lambda-var list))
find-in-bindings))
(defun find-in-bindings (vars name)
(let ((found nil))
(collect ((restr nil cons)
(new-vars nil cons))
(dolist (var-name (rest decl))
+ (when (boundp var-name)
+ (compiler-assert-symbol-home-package-unlocked
+ var-name "declaring the type of ~A"))
(let* ((bound-var (find-in-bindings vars var-name))
(var (or bound-var
(lexenv-find var-name vars)
(find-free-var var-name))))
(etypecase var
(leaf
- (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)))))))
+ (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))
+ (warn
+ 'type-warning
+ :format-control
+ "The type declarations ~S and ~S for ~S conflict."
+ :format-arguments
+ (list
+ (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))
(let ((type (compiler-specifier-type spec)))
(collect ((res nil cons))
(dolist (name names)
+ (when (fboundp name)
+ (compiler-assert-symbol-home-package-unlocked name
+ "declaring the ftype of ~A"))
(let ((found (find name fvars
:key #'leaf-source-name
:test #'equal)))
(found
(setf (leaf-type found) type)
(assert-definition-type found type
- :unwinnage-fun #'compiler-note
+ :unwinnage-fun #'compiler-notify
:where "FTYPE declaration"))
(t
(res (cons (find-lexically-apparent-fun
(declare (list spec vars) (type lexenv res))
(collect ((new-venv nil cons))
(dolist (name (cdr spec))
+ (compiler-assert-symbol-home-package-unlocked name "declaring ~A special")
(let ((var (find-in-bindings vars name)))
(etypecase var
(cons
(make-lexenv :default res :vars (new-venv))
res)))
-;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP.
+;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP
+;;; (and TYPE if notinline).
(defun make-new-inlinep (var inlinep)
(declare (type global-var var) (type inlinep inlinep))
(let ((res (make-defined-fun
:%source-name (leaf-source-name var)
:where-from (leaf-where-from var)
- :type (leaf-type var)
+ :type (if (and (eq inlinep :notinline)
+ (not (eq (leaf-where-from var) :declared)))
+ (specifier-type 'function)
+ (leaf-type var))
:inlinep inlinep)))
(when (defined-fun-p var)
(setf (defined-fun-inline-expansion res)
(etypecase found
(functional
(when (policy *lexenv* (>= speed inhibit-warnings))
- (compiler-note "ignoring ~A declaration not at ~
- definition of local function:~% ~S"
- sense name)))
+ (compiler-notify "ignoring ~A declaration not at ~
+ definition of local function:~% ~S"
+ sense name)))
(global-var
(push (cons name (make-new-inlinep found sense))
new-fenv)))))))
(compiler-style-warn "declaring unknown variable ~S to be ignored"
name))
;; FIXME: This special case looks like non-ANSI weirdness.
- ((and (consp var) (consp (cdr var)) (eq (cadr var) 'macro))
+ ((and (consp var) (eq (car var) 'macro))
;; Just ignore the IGNORE decl.
)
((functional-p var)
(setf (lambda-var-ignorep var) t)))))
(values))
+(defun process-dx-decl (names vars fvars)
+ (flet ((maybe-notify (control &rest args)
+ (when (policy *lexenv* (> speed inhibit-warnings))
+ (apply #'compiler-notify control args))))
+ (if (policy *lexenv* (= stack-allocate-dynamic-extent 3))
+ (dolist (name names)
+ (cond
+ ((symbolp name)
+ (let* ((bound-var (find-in-bindings vars name))
+ (var (or bound-var
+ (lexenv-find name vars)
+ (find-free-var name))))
+ (etypecase var
+ (leaf
+ (if bound-var
+ (setf (leaf-dynamic-extent var) t)
+ (maybe-notify
+ "ignoring DYNAMIC-EXTENT declaration for free ~S"
+ name)))
+ (cons
+ (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name))
+ (heap-alien-info
+ (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S"
+ name)))))
+ ((and (consp name)
+ (eq (car name) 'function)
+ (null (cddr name))
+ (valid-function-name-p (cadr name)))
+ (let* ((fname (cadr name))
+ (bound-fun (find fname fvars
+ :key #'leaf-source-name
+ :test #'equal)))
+ (etypecase bound-fun
+ (leaf
+ #!+stack-allocatable-closures
+ (setf (leaf-dynamic-extent bound-fun) t)
+ #!-stack-allocatable-closures
+ (maybe-notify
+ "ignoring DYNAMIC-EXTENT declaration on a function ~S ~
+ (not supported on this platform)." fname))
+ (cons
+ (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname))
+ (null
+ (maybe-notify
+ "ignoring DYNAMIC-EXTENT declaration for free ~S"
+ fname)))))
+ (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name))))
+ (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names))))
+
;;; FIXME: This is non-ANSI, so the default should be T, or it should
;;; go away, I think.
(defvar *suppress-values-declaration* nil
"If true, processing of the VALUES declaration is inhibited.")
;;; Process a single declaration spec, augmenting the specified LEXENV
-;;; RES and returning it as a result. VARS and FVARS are as described in
+;;; RES. Return RES and result type. VARS and FVARS are as described
;;; PROCESS-DECLS.
-(defun process-1-decl (raw-spec res vars fvars cont)
+(defun process-1-decl (raw-spec res vars fvars)
(declare (type list raw-spec vars fvars))
(declare (type lexenv res))
- (declare (type continuation cont))
- (let ((spec (canonized-decl-spec raw-spec)))
- (case (first spec)
- (special (process-special-decl spec res vars))
- (ftype
- (unless (cdr 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))
- ((ignore ignorable)
- (process-ignore-decl spec vars fvars)
- res)
- (optimize
- (make-lexenv
- :default res
- :policy (process-optimize-decl spec (lexenv-policy res))))
- (type
- (process-type-decl (cdr spec) res vars))
- (values ;; FIXME -- APD, 2002-01-26
- (if t ; *suppress-values-declaration*
- res
- (let ((types (cdr spec)))
- (ir1ize-the-or-values (if (eql (length types) 1)
- (car types)
- `(values ,@types))
- cont
- res
- "in VALUES declaration"))))
- (dynamic-extent
- (when (policy *lexenv* (> speed inhibit-warnings))
- (compiler-note
- "compiler limitation: ~
- ~% There's no special support for DYNAMIC-EXTENT (so it's ignored)."))
- res)
- (t
- (unless (info :declaration :recognized (first spec))
- (compiler-warn "unrecognized declaration ~S" raw-spec))
- res))))
+ (let ((spec (canonized-decl-spec raw-spec))
+ (result-type *wild-type*))
+ (values
+ (case (first spec)
+ (special (process-special-decl spec res vars))
+ (ftype
+ (unless (cdr 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))
+ ((ignore ignorable)
+ (process-ignore-decl spec vars fvars)
+ res)
+ (optimize
+ (make-lexenv
+ :default res
+ :policy (process-optimize-decl spec (lexenv-policy res))))
+ (muffle-conditions
+ (make-lexenv
+ :default res
+ :handled-conditions (process-muffle-conditions-decl
+ spec (lexenv-handled-conditions res))))
+ (unmuffle-conditions
+ (make-lexenv
+ :default res
+ :handled-conditions (process-unmuffle-conditions-decl
+ spec (lexenv-handled-conditions res))))
+ (type
+ (process-type-decl (cdr spec) res vars))
+ (values
+ (unless *suppress-values-declaration*
+ (let ((types (cdr spec)))
+ (setq result-type
+ (compiler-values-specifier-type
+ (if (singleton-p types)
+ (car types)
+ `(values ,@types)))))
+ res))
+ (dynamic-extent
+ (process-dx-decl (cdr spec) vars fvars)
+ res)
+ ((disable-package-locks enable-package-locks)
+ (make-lexenv
+ :default res
+ :disabled-package-locks (process-package-lock-decl
+ spec (lexenv-disabled-package-locks res))))
+ (t
+ (unless (info :declaration :recognized (first spec))
+ (compiler-warn "unrecognized declaration ~S" raw-spec))
+ res))
+ result-type)))
;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR
;;; and FUNCTIONAL structures which are being bound. In addition to
-;;; filling in slots in the leaf structures, we return a new LEXENV
+;;; filling in slots in the leaf structures, we return a new LEXENV,
;;; which reflects pervasive special and function type declarations,
-;;; (NOT)INLINE declarations and OPTIMIZE declarations. CONT is the
-;;; continuation affected by VALUES declarations.
+;;; (NOT)INLINE declarations and OPTIMIZE declarations, and type of
+;;; VALUES declarations.
;;;
;;; This is also called in main.lisp when PROCESS-FORM handles a use
;;; of LOCALLY.
-(defun process-decls (decls vars fvars cont &optional (env *lexenv*))
- (declare (list decls vars fvars) (type continuation cont))
- (dolist (decl decls)
- (dolist (spec (rest decl))
- (unless (consp spec)
- (compiler-error "malformed declaration specifier ~S in ~S" spec decl))
- (setq env (process-1-decl spec env vars fvars cont))))
- env)
+(defun process-decls (decls vars fvars &optional (env *lexenv*))
+ (declare (list decls vars fvars))
+ (let ((result-type *wild-type*))
+ (dolist (decl decls)
+ (dolist (spec (rest decl))
+ (unless (consp spec)
+ (compiler-error "malformed declaration specifier ~S in ~S" spec decl))
+ (multiple-value-bind (new-env new-result-type)
+ (process-1-decl spec env vars fvars)
+ (setq env new-env)
+ (unless (eq new-result-type *wild-type*)
+ (setq result-type
+ (values-type-intersection result-type new-result-type))))))
+ (values env result-type)))
+
+(defun %processing-decls (decls vars fvars ctran lvar fun)
+ (multiple-value-bind (*lexenv* result-type)
+ (process-decls decls vars fvars)
+ (cond ((eq result-type *wild-type*)
+ (funcall fun ctran lvar))
+ (t
+ (let ((value-ctran (make-ctran))
+ (value-lvar (make-lvar)))
+ (multiple-value-prog1
+ (funcall fun value-ctran value-lvar)
+ (let ((cast (make-cast value-lvar result-type
+ (lexenv-policy *lexenv*))))
+ (link-node-to-previous-ctran cast value-ctran)
+ (setf (lvar-dest value-lvar) cast)
+ (use-continuation cast ctran lvar))))))))
+(defmacro processing-decls ((decls vars fvars ctran lvar) &body forms)
+ (check-type ctran symbol)
+ (check-type lvar symbol)
+ `(%processing-decls ,decls ,vars ,fvars ,ctran ,lvar
+ (lambda (,ctran ,lvar) ,@forms)))
;;; Return the SPECVAR for NAME to use when we see a local SPECIAL
;;; declaration. If there is a global variable of that name, then
projects / sbcl.git / blobdiff