s/function/fun in...
...valid-function
...seen-function
...arg-function
...cached-function
...setf-function
...escape-function
...cleanup-function
...propagate-function
...really-function
...free-function
...apparent-function
...extract-function
...function-continuation
...function-info
...continuation-function
...coerce-function
...first-function
...core-function
...initial-function
...function-entry
...function-subtype
...compute-function
...function-epilogue
...function-prologue
s/set-up-function-translation/!set-up-fun-translation/
"*BACKEND-T-PRIMITIVE-TYPE*"
"*CODE-SEGMENT*"
- "*COUNT-VOP-USAGES*" "*ELSEWHERE*" "*FREE-FUNCTIONS*"
+ "*COUNT-VOP-USAGES*" "*ELSEWHERE*" "*FREE-FUNS*"
"*SETF-ASSUMED-FBOUNDP*"
"*SUPPRESS-VALUES-DECLARATION*"
"COMPILE-LAMBDA-FOR-DEFUN"
"%COMPILER-DEFUN" "COMPILER-ERROR"
"COMPONENT" "COMPONENT-HEADER-LENGTH"
- "COMPONENT-INFO" "COMPONENT-LIVE-TN" "COMPUTE-FUNCTION"
+ "COMPONENT-INFO" "COMPONENT-LIVE-TN" "COMPUTE-FUN"
"COMPUTE-OLD-NFP" "COPY-MORE-ARG"
"CURRENT-BINDING-POINTER" "CURRENT-NFP-TN"
"CURRENT-STACK-POINTER" "DEALLOC-ALIEN-STACK-SPACE"
"FDEFN-NAME" "FDEFN-FUN"
"FDEFN-MAKUNBOUND" "OUTER-FDEFN"
"%COERCE-CALLABLE-TO-FUN"
- "FUNCTION-SUBTYPE" "*MAXIMUM-ERROR-DEPTH*"
+ "FUN-SUBTYPE" "*MAXIMUM-ERROR-DEPTH*"
"%SET-SYMBOL-PLIST" "INFINITE-ERROR-PROTECT"
"FIND-CALLER-NAME-AND-FRAME"
"%SET-SYMBOL-VALUE" "%SET-SYMBOL-PACKAGE"
"*TARGET-MOST-POSITIVE-FIXNUM*"
"STATIC-SPACE-START" "STATIC-SPACE-END"
"TRACE-TABLE-CALL-SITE"
- "TRACE-TABLE-FUNCTION-EPILOGUE" "TRACE-TABLE-FUNCTION-PROLOGUE"
+ "TRACE-TABLE-FUN-EPILOGUE" "TRACE-TABLE-FUN-PROLOGUE"
"TRACE-TABLE-NORMAL" "N-WIDETAG-BITS" "WIDETAG-MASK"
"UNBOUND-MARKER-WIDETAG"
"UNSIGNED-IMMEDIATE-SC-NUMBER"
;;; ### For functions with XEPs, name could be represented more simply
;;; and compactly as some sort of info about with how to find the
-;;; FUNCTION-ENTRY that this is a function for. Actually, you really
+;;; function entry that this is a function for. Actually, you really
;;; hardly need any info. You can just chain through the functions in
;;; the component until you find the right one. Well, I guess you need
;;; to at least know which function is an XEP for the real function
`(funcall #'(setf ,(car form)))
t))))
-(defun get-setf-method-inverse (form inverse setf-function)
+(defun get-setf-method-inverse (form inverse setf-fun)
(let ((new-var (gensym))
(vars nil)
(vals nil))
(push x vals))
(setq vals (nreverse vals))
(values vars vals (list new-var)
- (if setf-function
+ (if setf-fun
`(,@inverse ,new-var ,@vars)
`(,@inverse ,@vars ,new-var))
`(,(car form) ,@vars))))
(unless (zerop (logand offset sb!vm:lowtag-mask))
(error "internal error: unaligned function object, offset = #X~X"
offset))
- (let ((fun (%primitive sb!c:compute-function code-object offset)))
+ (let ((fun (%primitive sb!c:compute-fun code-object offset)))
(setf (%simple-fun-self fun) fun)
(setf (%simple-fun-next fun) (%code-entry-points code-object))
(setf (%code-entry-points code-object) fun)
(sb!c::control-stack-pointer-sap))
;;; Return the header typecode for FUNCTION. Can be set with SETF.
-(defun function-subtype (function)
- (function-subtype function))
-(defun (setf function-subtype) (type function)
- (setf (function-subtype function) type))
+(defun fun-subtype (function)
+ (fun-subtype function))
+(defun (setf fun-subtype) (type function)
+ (setf (fun-subtype function) type))
;;; Extract the arglist from the function header FUNC.
(defun %simple-fun-arglist (func)
;;;; internal state
;;; a hash table that maps each traced function to the TRACE-INFO. The
-;;; entry for a closure is the shared function-entry object.
+;;; entry for a closure is the shared function entry object.
(defvar *traced-funs* (make-hash-table :test 'eq))
;;; A TRACE-INFO object represents all the information we need to
(*print-level* 3) ; ..print an interpreted function definition
;; FIXME: This find-the-function-name idiom ought to be
;; encapsulated in a function somewhere.
- (name (case (function-subtype object)
+ (name (case (fun-subtype object)
(#.sb!vm:closure-header-widetag "CLOSURE")
(#.sb!vm:simple-fun-header-widetag (%simple-fun-name object))
(t 'no-name-available)))
(sb!alien:define-alien-routine "save" (sb!alien:boolean)
(file sb!c-call:c-string)
- (initial-function (sb!alien:unsigned #.sb!vm:n-word-bits)))
+ (initial-fun (sb!alien:unsigned #.sb!vm:n-word-bits)))
;;; FIXME: When this is run without the PURIFY option,
;;; it seems to save memory all the way up to the high-water mark,
;;; length of the output sequence matches any length specified
;;; in RESULT-TYPE.
(defun %map (result-type function first-sequence &rest more-sequences)
- (let ((really-function (%coerce-callable-to-fun function)))
+ (let ((really-fun (%coerce-callable-to-fun function)))
;; Handle one-argument MAP NIL specially, using ETYPECASE to turn
;; it into something which can be DEFTRANSFORMed away. (It's
;; fairly important to handle this case efficiently, since
;; there's no consing overhead to dwarf our inefficiency.)
(if (and (null more-sequences)
(null result-type))
- (%map-for-effect-arity-1 really-function first-sequence)
+ (%map-for-effect-arity-1 really-fun first-sequence)
;; Otherwise, use the industrial-strength full-generality
;; approach, consing O(N-ARGS) temporary storage (which can have
;; DYNAMIC-EXTENT), then using O(N-ARGS * RESULT-LENGTH) time.
(let ((sequences (cons first-sequence more-sequences)))
(case (type-specifier-atom result-type)
- ((nil) (%map-for-effect really-function sequences))
- (list (%map-to-list really-function sequences))
+ ((nil) (%map-for-effect really-fun sequences))
+ (list (%map-to-list really-fun sequences))
((simple-vector simple-string vector string array simple-array
bit-vector simple-bit-vector base-string simple-base-string)
- (%map-to-vector result-type really-function sequences))
+ (%map-to-vector result-type really-fun sequences))
(t
(apply #'map
(result-type-or-lose result-type t)
- really-function
+ really-fun
sequences)))))))
(defun map (result-type function first-sequence &rest more-sequences)
(let ((alien-node (continuation-use alien)))
(typecase alien-node
(combination
- (extract-function-args alien '%sap-alien 2)
+ (extract-fun-args alien '%sap-alien 2)
'(lambda (sap type)
(declare (ignore type))
sap))
(unless (and (constant-continuation-p inside-amount)
(not (minusp (continuation-value inside-amount))))
(give-up-ir1-transform)))))
- (extract-function-args value 'ash 2)
+ (extract-fun-args value 'ash 2)
'(lambda (value amount1 amount2)
(ash value (+ amount1 amount2))))
\f
;; Make sure the function is aligned, and drop a label pointing to
;; this function header.
(align n-lowtag-bits)
- (trace-table-entry trace-table-function-prologue)
+ (trace-table-entry trace-table-fun-prologue)
(emit-label start-lab)
;; Allocate function header.
(inst simple-fun-header-word)
(nfp :scs (any-reg)))
(:info callee)
(:generator 2
- (trace-table-entry trace-table-function-prologue)
+ (trace-table-entry trace-table-fun-prologue)
(move csp-tn res)
(inst lda
csp-tn
(:ignore val-locs vals)
(:vop-var vop)
(:generator 6
- (trace-table-entry trace-table-function-epilogue)
+ (trace-table-entry trace-table-fun-epilogue)
(maybe-load-stack-tn ocfp-temp ocfp)
(maybe-load-stack-tn return-pc-temp return-pc)
(move cfp-tn csp-tn)
(:vop-var vop)
(:generator 6
;; Clear the number stack.
- (trace-table-entry trace-table-function-epilogue)
+ (trace-table-entry trace-table-fun-epilogue)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
(:vop-var vop)
(:generator 6
;; Clear the number stack.
- (trace-table-entry trace-table-function-epilogue)
+ (trace-table-entry trace-table-fun-epilogue)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
(:vop-var vop)
(:generator 13
- (trace-table-entry trace-table-function-epilogue)
+ (trace-table-entry trace-table-fun-epilogue)
(let ((not-single (gen-label)))
;; Clear the number stack.
(let ((cur-nfp (current-nfp-tn vop)))
(defenum (:prefix trace-table-)
normal
call-site
- function-prologue
- function-epilogue)
+ fun-prologue
+ fun-epilogue)
\f
;;;; static symbols
DONE))
-(define-vop (function-subtype)
- (:translate function-subtype)
+(define-vop (fun-subtype)
+ (:translate fun-subtype)
(:policy :fast-safe)
(:args (function :scs (descriptor-reg)))
(:results (result :scs (unsigned-reg)))
(:generator 6
(load-type result function (- fun-pointer-lowtag))))
-(define-vop (set-function-subtype)
- (:translate (setf function-subtype))
+(define-vop (set-fun-subtype)
+ (:translate (setf fun-subtype))
(:policy :fast-safe)
(:args (type :scs (unsigned-reg) :target result)
(function :scs (descriptor-reg)))
(inst subq ndescr other-pointer-lowtag ndescr)
(inst addq code ndescr sap)))
-(define-vop (compute-function)
+(define-vop (compute-fun)
(:args (code :scs (descriptor-reg))
(offset :scs (signed-reg unsigned-reg)))
(:arg-types * positive-fixnum)
(let ((info (info :function :info name))
(call-cost (template-cost (template-or-lose 'call-named))))
(if info
- (let ((templates (function-info-templates info)))
+ (let ((templates (fun-info-templates info)))
(if templates
(template-cost (first templates))
(case name
(cond ((eq cont (basic-combination-fun dest)) t)
((eq kind :local) t)
((member kind '(:full :error)) nil)
- ((function-info-ir2-convert kind) t)
+ ((fun-info-ir2-convert kind) t)
(t
- (dolist (template (function-info-templates kind) nil)
+ (dolist (template (fun-info-templates kind) nil)
(when (eq (template-ltn-policy template) :fast-safe)
(multiple-value-bind (val win)
- (valid-function-use dest (template-type template))
+ (valid-fun-use dest (template-type template))
(when (or val (not win)) (return t)))))))))
(t t))))
(values))
;;; Mark CONT as being a continuation with a manifest type error. We
-;;; set the kind to :ERROR, and clear any FUNCTION-INFO if the
+;;; set the kind to :ERROR, and clear any FUN-INFO if the
;;; continuation is an argument to a known call. The last is done so
;;; that the back end doesn't have to worry about type errors in
;;; arguments to known functions. This clearing is inhibited for
(when (and (combination-p dest)
(let ((kind (basic-combination-kind dest)))
(or (eq kind :full)
- (and (function-info-p kind)
- (not (function-info-ir2-convert kind))))))
+ (and (fun-info-p kind)
+ (not (fun-info-ir2-convert kind))))))
(setf (basic-combination-kind dest) :error)))
(values))
;;; explain the result. We bind *COMPILER-ERROR-CONTEXT* to the
;;; combination node so that COMPILER-WARNING and related functions
;;; will do the right thing if they are supplied.
-(defun valid-function-use (call type &key
- ((:argument-test *ctype-test-fun*) #'csubtypep)
- (result-test #'values-subtypep)
- (strict-result nil)
- ((:lossage-fun *lossage-fun*))
- ((:unwinnage-fun *unwinnage-fun*)))
+(defun valid-fun-use (call type &key
+ ((:argument-test *ctype-test-fun*) #'csubtypep)
+ (result-test #'values-subtypep)
+ (strict-result nil)
+ ((:lossage-fun *lossage-fun*))
+ ((:unwinnage-fun *unwinnage-fun*)))
(declare (type function result-test) (type combination call)
(type fun-type type))
(let* ((*lossage-detected* nil)
;;; *SEEN-BLOCKS* is a hashtable with true values for all blocks which
;;; appear in the DFO for one of the specified components.
;;;
-;;; *SEEN-FUNCTIONS* is similar, but records all the lambdas we
+;;; *SEEN-FUNS* is similar, but records all the lambdas we
;;; reached by recursing on top level functions.
+;;; FIXME: Is it really only LAMBDAs, not e.g. FUNCTIONALs? Then
+;;; shouldn't it be *SEEN-LAMBDAS*?
(defvar *seen-blocks* (make-hash-table :test 'eq))
-(defvar *seen-functions* (make-hash-table :test 'eq))
+(defvar *seen-funs* (make-hash-table :test 'eq))
;;; Barf if NODE is in a block which wasn't reached during the graph
;;; walk.
;;; Check everything that we can think of for consistency. When a
;;; definite inconsistency is detected, we BARF. Possible problems
;;; just cause us to BURP. Our argument is a list of components, but
-;;; we also look at the *FREE-VARIABLES*, *FREE-FUNCTIONS* and
+;;; we also look at the *FREE-VARIABLES*, *FREE-FUNS* and
;;; *CONSTANTS*.
;;;
;;; First we do a pre-pass which finds all the CBLOCKs and CLAMBDAs,
(declaim (ftype (function (list) (values)) check-ir1-consistency))
(defun check-ir1-consistency (components)
(clrhash *seen-blocks*)
- (clrhash *seen-functions*)
+ (clrhash *seen-funs*)
(dolist (c components)
(let* ((head (component-head c))
(tail (component-tail c)))
(unless (or (functional-p v)
(and (global-var-p v)
(eq (global-var-kind v) :global-function)))
- (barf "strange *FREE-FUNCTIONS* entry: ~S" v))
+ (barf "strange *FREE-FUNS* entry: ~S" v))
(dolist (n (leaf-refs v))
(check-node-reached n)))
- *free-functions*)
- (clrhash *seen-functions*)
+ *free-funs*)
+ (clrhash *seen-funs*)
(clrhash *seen-blocks*)
(values))
\f
(defun observe-functional (x)
(declare (type functional x))
- (when (gethash x *seen-functions*)
+ (when (gethash x *seen-funs*)
(barf "~S was seen more than once." x))
(unless (eq (functional-kind x) :deleted)
- (setf (gethash x *seen-functions*) t)))
+ (setf (gethash x *seen-funs*) t)))
;;; Check that the specified function has been seen.
(defun check-fun-reached (fun where)
(declare (type functional fun))
- (unless (gethash fun *seen-functions*)
+ (unless (gethash fun *seen-funs*)
(barf "unseen function ~S in ~S" fun where)))
;;; In a CLAMBDA, check that the associated nodes are in seen blocks.
(integer (continuation-block (num-cont thing)))
(functional (lambda-block (main-entry thing)))
(null (error "Bad thing: ~S." thing))
- (symbol (block-or-lose (gethash thing *free-functions*)))))
+ (symbol (block-or-lose (gethash thing *free-funs*)))))
;;; Print cN.
(defun print-continuation (cont)
(basic-combination
(let ((kind (basic-combination-kind node)))
(format t "~(~A ~A~) c~D"
- (if (function-info-p kind) "known" kind)
+ (if (fun-info-p kind) "known" kind)
(type-of node)
(cont-num (basic-combination-fun node)))
(dolist (arg (basic-combination-args node))
(munge-fun-refs (cddr override) evalp)))
overrides))
-(defparameter *arg-function-params*
+(defparameter *arg-fun-params*
'((:printer . (value stream dstate))
(:use-label . (value dstate))
(:prefilter . (value dstate))))
(wrapper-defs nil))
((null tail)
(values params (nreverse wrapper-defs)))
- (let ((fun-arg (assoc (car tail) *arg-function-params*)))
+ (let ((fun-arg (assoc (car tail) *arg-fun-params*)))
(when fun-arg
(let* ((fun-form (cadr tail))
(quoted-fun-form `',fun-form))
(valsrc-value thing)
thing))
\f
-(defstruct (cached-function (:conc-name cached-fun-)
- (:copier nil))
+(defstruct (cached-fun (:conc-name cached-fun-)
+ (:copier nil))
(funstate nil :type (or null funstate))
(constraint nil :type list)
(name nil :type (or null symbol)))
-(defun find-cached-function (cached-funs args constraint)
+(defun find-cached-fun (cached-funs args constraint)
(dolist (cached-fun cached-funs nil)
(let ((funstate (cached-fun-funstate cached-fun)))
(when (and (equal constraint (cached-fun-constraint cached-fun))
(funstate-compatible-p funstate args)))
(return cached-fun)))))
-(defmacro !with-cached-function ((name-var
- funstate-var
- cache
- cache-slot
- args
- &key
- constraint
- (stem (missing-arg)))
- &body defun-maker-forms)
+(defmacro !with-cached-fun ((name-var
+ funstate-var
+ cache
+ cache-slot
+ args
+ &key
+ constraint
+ (stem (missing-arg)))
+ &body defun-maker-forms)
(let ((cache-var (gensym))
(constraint-var (gensym)))
`(let* ((,constraint-var ,constraint)
- (,cache-var (find-cached-function (,cache-slot ,cache)
- ,args ,constraint-var)))
+ (,cache-var (find-cached-fun (,cache-slot ,cache)
+ ,args ,constraint-var)))
(cond (,cache-var
(values (cached-fun-name ,cache-var) nil))
(t
(let* ((,name-var (symbolicate "CACHED-FUN--" ,stem))
(,funstate-var (make-funstate ,args))
(,cache-var
- (make-cached-function :name ,name-var
- :funstate ,funstate-var
- :constraint ,constraint-var)))
+ (make-cached-fun :name ,name-var
+ :funstate ,funstate-var
+ :constraint ,constraint-var)))
(values ,name-var
`(progn
,(progn ,@defun-maker-forms)
(if (null printer-source)
(values nil nil)
(let ((printer-source (preprocess-printer printer-source args)))
- (!with-cached-function
+ (!with-cached-fun
(name funstate cache fun-cache-printers args
:constraint printer-source
:stem (concatenate 'string
(mapcar #'arg-name (remove-if-not #'arg-use-label args))))
(if (null labelled-fields)
(values nil nil)
- (!with-cached-function
+ (!with-cached-fun
(name funstate cache fun-cache-labellers args
:stem (concatenate 'string "LABELLER-" (string %name))
:constraint labelled-fields)
(remove-if-not #'arg-prefilter args))))
(if (null filtered-args)
(values nil nil)
- (!with-cached-function
+ (!with-cached-fun
(name funstate cache fun-cache-prefilters args
:stem (concatenate 'string
(string %name)
(dump-fop 'fop-sanctify-for-execution file)
(dump-pop file))
-;;; Dump a function-entry data structure corresponding to ENTRY to
+;;; Dump a function entry data structure corresponding to ENTRY to
;;; FILE. CODE-HANDLE is the table offset of the code object for the
;;; component.
(defun dump-one-entry (entry code-handle file)
(declaim (type lexenv *lexenv*))
;;; *FREE-VARIABLES* translates from the names of variables referenced
-;;; globally to the LEAF structures for them. *FREE-FUNCTIONS* is like
+;;; globally to the LEAF structures for them. *FREE-FUNS* is like
;;; *FREE-VARIABLES*, only it deals with function names.
(defvar *free-variables*)
-(defvar *free-functions*)
-(declaim (type hash-table *free-variables* *free-functions*))
+(defvar *free-funs*)
+(declaim (type hash-table *free-variables* *free-funs*))
;;; We use the same CONSTANT structure to represent all equal anonymous
;;; constants. This hashtable translates from constants to the LEAFs that
(sqrt (real 0.0))))
(destructuring-bind (name type) stuff
(let ((type (specifier-type type)))
- (setf (function-info-derive-type (function-info-or-lose name))
+ (setf (fun-info-derive-type (fun-info-or-lose name))
(lambda (call)
(declare (type combination call))
(when (csubtypep (continuation-type
(values (get-lisp-obj-address code) t)))))
(sb!vm:fixup-code-object code offset value kind))))
-;;; Stick a reference to the function Fun in Code-Object at index I. If the
-;;; function hasn't been compiled yet, make a note in the Patch-Table.
-(defun reference-core-function (code-obj i fun object)
+;;; Stick a reference to the function FUN in CODE-OBJECT at index I. If the
+;;; function hasn't been compiled yet, make a note in the patch table.
+(defun reference-core-fun (code-obj i fun object)
(declare (type core-object object) (type functional fun)
(type index i))
(let* ((info (leaf-info fun))
(defparameter validate-entry-type-code 3845)
(defparameter directory-entry-type-code 3841)
(defparameter new-directory-entry-type-code 3861)
-(defparameter initial-function-entry-type-code 3863)
+(defparameter initial-fun-entry-type-code 3863)
(defparameter end-entry-type-code 3840)
(declaim (ftype (function (sb!vm:word) sb!vm:word) write-long))
(output-gspace *dynamic*)
;; Write the initial function.
- (write-long initial-function-entry-type-code)
+ (write-long initial-fun-entry-type-code)
(write-long 3)
(let* ((cold-name (cold-intern '!cold-init))
(cold-fdefn (cold-fdefinition-object cold-name))
- (initial-function (read-wordindexed cold-fdefn
- sb!vm:fdefn-fun-slot)))
+ (initial-fun (read-wordindexed cold-fdefn
+ sb!vm:fdefn-fun-slot)))
(format t
- "~&/(DESCRIPTOR-BITS INITIAL-FUNCTION)=#X~X~%"
- (descriptor-bits initial-function))
- (write-long (descriptor-bits initial-function)))
+ "~&/(DESCRIPTOR-BITS INITIAL-FUN)=#X~X~%"
+ (descriptor-bits initial-fun))
+ (write-long (descriptor-bits initial-fun)))
;; Write the End entry.
(write-long end-entry-type-code)
(in-package "SB!C")
;;; Make a function entry, filling in slots from the ENTRY-INFO.
-(defun make-function-entry (entry code-obj object)
- (declare (type entry-info entry) (type core-object object))
- (let ((offset (label-position (entry-info-offset entry))))
+(defun make-fun-entry (entry-info code-obj object)
+ (declare (type entry-info entry-info) (type core-object object))
+ (let ((offset (label-position (entry-info-offset entry-info))))
(declare (type index offset))
(unless (zerop (logand offset sb!vm:lowtag-mask))
(error "Unaligned function object, offset = #X~X." offset))
- (let ((res (%primitive compute-function code-obj offset)))
+ (let ((res (%primitive compute-fun code-obj offset)))
(setf (%simple-fun-self res) res)
(setf (%simple-fun-next res) (%code-entry-points code-obj))
(setf (%code-entry-points code-obj) res)
- (setf (%simple-fun-name res) (entry-info-name entry))
- (setf (%simple-fun-arglist res) (entry-info-arguments entry))
- (setf (%simple-fun-type res) (entry-info-type entry))
+ (setf (%simple-fun-name res) (entry-info-name entry-info))
+ (setf (%simple-fun-arglist res) (entry-info-arguments entry-info))
+ (setf (%simple-fun-type res) (entry-info-type entry-info))
- (note-fun entry res object))))
+ (note-fun entry-info res object))))
;;; Dump a component to core. We pass in the assembler fixups, code
;;; vector and node info.
(do-core-fixups code-obj fixups)
(dolist (entry (ir2-component-entries 2comp))
- (make-function-entry entry code-obj object))
+ (make-fun-entry entry code-obj object))
(sb!vm:sanctify-for-execution code-obj)
(list
(ecase (car const)
(:entry
- (reference-core-function code-obj index
- (cdr const) object))
+ (reference-core-fun code-obj index (cdr const) object))
(:fdefinition
(setf (code-header-ref code-obj index)
(fdefinition-object (cdr const) t))))))))))
(defknown code-header-ref (t index) t (flushable))
(defknown code-header-set (t index t) t ())
-(defknown function-subtype (function) (unsigned-byte #.sb!vm:n-widetag-bits)
+(defknown fun-subtype (function) (unsigned-byte #.sb!vm:n-widetag-bits)
(flushable))
-(defknown ((setf function-subtype))
+(defknown ((setf fun-subtype))
((unsigned-byte #.sb!vm:n-widetag-bits) function)
(unsigned-byte #.sb!vm:n-widetag-bits)
())
(in-package "SB!C")
(defun %def-reffer (name offset lowtag)
- (let ((info (function-info-or-lose name)))
- (setf (function-info-ir2-convert info)
+ (let ((info (fun-info-or-lose name)))
+ (setf (fun-info-ir2-convert info)
(lambda (node block)
(ir2-convert-reffer node block name offset lowtag))))
name)
`(%def-reffer ',name ,offset ,lowtag))
(defun %def-setter (name offset lowtag)
- (let ((info (function-info-or-lose name)))
- (setf (function-info-ir2-convert info)
+ (let ((info (fun-info-or-lose name)))
+ (setf (fun-info-ir2-convert info)
(if (listp name)
(lambda (node block)
(ir2-convert-setfer node block name offset lowtag))
`(%def-setter ',name ,offset ,lowtag))
(defun %def-alloc (name words var-length header lowtag inits)
- (let ((info (function-info-or-lose name)))
- (setf (function-info-ir2-convert info)
+ (let ((info (fun-info-or-lose name)))
+ (setf (fun-info-ir2-convert info)
(if var-length
(lambda (node block)
(ir2-convert-variable-allocation node block name words header
:type :ir1-transform
:type-spec (or function null))
-;;; If a function is "known" to the compiler, then this is a
-;;; FUNCTION-INFO structure containing the info used to special-case
-;;; compilation.
+;;; If a function is "known" to the compiler, then this is a FUN-INFO
+;;; structure containing the info used to special-case compilation.
(define-info-type
:class :function
:type :info
- :type-spec (or function-info null)
+ :type-spec (or fun-info null)
:default nil)
(define-info-type
;; in EVAL-WHEN (:COMPILE) inside something like DEFSTRUCT, in which
;; case it's reasonable style. Either way, NAME is no longer a free
;; function.)
- (when (boundp '*free-functions*) ; when compiling
- (remhash name *free-functions*))
+ (when (boundp '*free-funs*) ; when compiling
+ (remhash name *free-funs*))
;; recording the ordinary case
(setf (info :function :kind name) :function)
- (note-if-setf-function-and-macro name)
+ (note-if-setf-fun-and-macro name)
(values))
;;; warning. Due to the weak semantics of the (SETF FUNCTION) name, we
;;; can't assume that they aren't just naming a function (SETF FOO)
;;; for the heck of it. NAME is already known to be well-formed.
-(defun note-if-setf-function-and-macro (name)
+(defun note-if-setf-fun-and-macro (name)
(when (consp name)
(when (or (info :setf :inverse name)
(info :setf :expander name))
: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))))
;;;
;;; 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)
+(def-ir1-translator %cleanup-fun ((name) start cont)
(let ((fun (lexenv-find name functions)))
(aver (lambda-p fun))
(setf (functional-kind fun) :cleanup)
`(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 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
+;;; 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)
`(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)))))))
(ecase (info :function :kind name)
((nil))
(:function
- (remhash name *free-functions*)
+ (remhash name *free-funs*)
(undefine-fun-name name)
(compiler-warn
"~S is being redefined as a macro when it was ~
(defun note-failed-optimization (node failures)
(declare (type combination node) (list failures))
(unless (or (node-deleted node)
- (not (function-info-p (combination-kind node))))
+ (not (fun-info-p (combination-kind node))))
(let ((*compiler-error-context* node))
(dolist (failure failures)
(let ((what (cdr failure))
((consp what)
(compiler-note "~@<unable to ~2I~_~A ~I~_because: ~2I~_~?~:>"
note (first what) (rest what)))
- ((valid-function-use node what
- :argument-test #'types-equal-or-intersect
- :result-test #'values-types-equal-or-intersect)
+ ((valid-fun-use node what
+ :argument-test #'types-equal-or-intersect
+ :result-test #'values-types-equal-or-intersect)
(collect ((messages))
(flet ((give-grief (string &rest stuff)
(messages string)
(messages stuff)))
- (valid-function-use node what
- :unwinnage-fun #'give-grief
- :lossage-fun #'give-grief))
+ (valid-fun-use node what
+ :unwinnage-fun #'give-grief
+ :lossage-fun #'give-grief))
(compiler-note "~@<unable to ~
~2I~_~A ~
~I~_due to type uncertainty: ~
;;; For each named function with an XEP, note the definition of that
;;; name, and add derived type information to the INFO environment. We
-;;; also delete the FUNCTIONAL from *FREE-FUNCTIONS* to eliminate the
+;;; also delete the FUNCTIONAL from *FREE-FUNS* to eliminate the
;;; possibility that new references might be converted to it.
(defun finalize-xep-definition (fun)
(let* ((leaf (functional-entry-fun fun))
(let ((source-name (leaf-source-name leaf)))
(let* ((where (info :function :where-from source-name))
(*compiler-error-context* (lambda-bind (main-entry leaf)))
- (global-def (gethash source-name *free-functions*))
+ (global-def (gethash source-name *free-funs*))
(global-p (defined-fun-p global-def)))
(note-name-defined source-name :function)
(when global-p
- (remhash source-name *free-functions*))
+ (remhash source-name *free-funs*))
(ecase where
(:assumed
(let ((approx-type (info :function :assumed-type source-name)))
(maphash (lambda (k v)
(note-assumed-types component k v))
- *free-functions*)
+ *free-funs*)
(values))
;;; optimized. We dispatch off of the type of each node with its
;;; reoptimize flag set:
-;;; -- With a combination, we call Propagate-Function-Change whenever
-;;; the function changes, and call IR1-Optimize-Combination if any
+;;; -- With a COMBINATION, we call PROPAGATE-FUN-CHANGE whenever
+;;; the function changes, and call IR1-OPTIMIZE-COMBINATION if any
;;; argument changes.
-;;; -- With an Exit, we derive the node's type from the Value's type.
-;;; We don't propagate Cont's assertion to the Value, since if we
-;;; did, this would move the checking of Cont's assertion to the
-;;; exit. This wouldn't work with Catch and UWP, where the Exit
+;;; -- With an EXIT, we derive the node's type from the VALUE's type.
+;;; We don't propagate CONT's assertion to the VALUE, since if we
+;;; did, this would move the checking of CONT's assertion to the
+;;; exit. This wouldn't work with CATCH and UWP, where the EXIT
;;; node is just a placeholder for the actual unknown exit.
;;;
;;; Note that we clear the node & block reoptimize flags *before*
(unlink-node node))
(combination
(let ((info (combination-kind node)))
- (when (function-info-p info)
- (let ((attr (function-info-attributes info)))
+ (when (fun-info-p info)
+ (let ((attr (fun-info-attributes info)))
(when (and (ir1-attributep attr flushable)
(not (ir1-attributep attr call)))
(flush-dest (combination-fun node))
(declaim (ftype (function (combination) (values)) ir1-optimize-combination))
(defun ir1-optimize-combination (node)
(when (continuation-reoptimize (basic-combination-fun node))
- (propagate-function-change node))
+ (propagate-fun-change node))
(let ((args (basic-combination-args node))
(kind (basic-combination-kind node)))
(case kind
(when arg
(setf (continuation-reoptimize arg) nil)))
- (let ((attr (function-info-attributes kind)))
+ (let ((attr (fun-info-attributes kind)))
(when (and (ir1-attributep attr foldable)
;; KLUDGE: The next test could be made more sensitive,
;; only suppressing constant-folding of functions with
(constant-fold-call node)
(return-from ir1-optimize-combination)))
- (let ((fun (function-info-derive-type kind)))
+ (let ((fun (fun-info-derive-type kind)))
(when fun
(let ((res (funcall fun node)))
(when res
(derive-node-type node res)
(maybe-terminate-block node nil)))))
- (let ((fun (function-info-optimizer kind)))
+ (let ((fun (fun-info-optimizer kind)))
(unless (and fun (funcall fun node))
- (dolist (x (function-info-transforms kind))
+ (dolist (x (fun-info-transforms kind))
#!+sb-show
(when *show-transforms-p*
(let* ((cont (basic-combination-fun node))
;;; -- If it is a known function, mark it as such by setting the KIND.
;;;
;;; We return the leaf referenced (NIL if not a leaf) and the
-;;; FUNCTION-INFO assigned.
+;;; FUN-INFO assigned.
;;;
;;; FIXME: The IR1-CONVERTING-NOT-OPTIMIZING-P argument is what the
;;; old CMU CL code called IR1-P, without explanation. My (WHN
(csubtypep type (specifier-type 'function))
(or val (not win))))
(recognize-known-call call ir1-converting-not-optimizing-p))
- ((valid-function-use call type
- :argument-test #'always-subtypep
- :result-test #'always-subtypep
- ;; KLUDGE: Common Lisp is such a dynamic
- ;; language that all we can do here in
- ;; general is issue a STYLE-WARNING. It
- ;; would be nice to issue a full WARNING
- ;; in the special case of of type
- ;; mismatches within a compilation unit
- ;; (as in section 3.2.2.3 of the spec)
- ;; but at least as of sbcl-0.6.11, we
- ;; don't keep track of whether the
- ;; mismatched data came from the same
- ;; compilation unit, so we can't do that.
- ;; -- WHN 2001-02-11
- ;;
- ;; FIXME: Actually, I think we could
- ;; issue a full WARNING if the call
- ;; violates a DECLAIM FTYPE.
- :lossage-fun #'compiler-style-warn
- :unwinnage-fun #'compiler-note)
+ ((valid-fun-use call type
+ :argument-test #'always-subtypep
+ :result-test #'always-subtypep
+ ;; KLUDGE: Common Lisp is such a dynamic
+ ;; language that all we can do here in
+ ;; general is issue a STYLE-WARNING. It
+ ;; would be nice to issue a full WARNING
+ ;; in the special case of of type
+ ;; mismatches within a compilation unit
+ ;; (as in section 3.2.2.3 of the spec)
+ ;; but at least as of sbcl-0.6.11, we
+ ;; don't keep track of whether the
+ ;; mismatched data came from the same
+ ;; compilation unit, so we can't do that.
+ ;; -- WHN 2001-02-11
+ ;;
+ ;; FIXME: Actually, I think we could
+ ;; issue a full WARNING if the call
+ ;; violates a DECLAIM FTYPE.
+ :lossage-fun #'compiler-style-warn
+ :unwinnage-fun #'compiler-note)
(assert-call-type call type)
(maybe-terminate-block call ir1-converting-not-optimizing-p)
(recognize-known-call call ir1-converting-not-optimizing-p))
;;; expansion, etc. If a call to a predicate in a non-conditional
;;; position or to a function with a source transform, then we
;;; reconvert the form to give IR1 another chance.
-(defun propagate-function-change (call)
+(defun propagate-fun-change (call)
(declare (type combination call))
(let ((*compiler-error-context* call)
(fun-cont (basic-combination-fun call)))
((not leaf))
((or (info :function :source-transform (leaf-source-name leaf))
(and info
- (ir1-attributep (function-info-attributes info)
+ (ir1-attributep (fun-info-attributes info)
predicate)
(let ((dest (continuation-dest (node-cont call))))
(and dest (not (if-p dest))))))
(eq when :native))))
t)
((or (not constrained)
- (valid-function-use node type :strict-result t))
+ (valid-fun-use node type :strict-result t))
(multiple-value-bind (severity args)
(catch 'give-up-ir1-transform
(transform-call node (funcall fun node))
(remhash node table)
nil))))
((and flame
- (valid-function-use node
- type
- :argument-test #'types-equal-or-intersect
- :result-test
- #'values-types-equal-or-intersect))
+ (valid-fun-use node
+ type
+ :argument-test #'types-equal-or-intersect
+ :result-test #'values-types-equal-or-intersect))
(record-optimization-failure node transform type)
t)
(t
(eq (continuation-fun-name (combination-fun use))
'list))
(change-ref-leaf (continuation-use (combination-fun node))
- (find-free-function 'values "in a strange place"))
+ (find-free-fun 'values "in a strange place"))
(setf (combination-kind node) :full)
(let ((args (combination-args use)))
(dolist (arg args)
;;; Return a GLOBAL-VAR structure usable for referencing the global
;;; function NAME.
-(defun find-free-really-function (name)
+(defun find-free-really-fun (name)
(unless (info :function :kind name)
(setf (info :function :kind name) :function)
(setf (info :function :where-from name) :assumed))
:for class
:slot slot)))
-;;; Has the *FREE-FUNCTIONS* entry FREE-FUNCTION become invalid?
+;;; Has the *FREE-FUNS* entry FREE-FUN become invalid?
;;;
;;; In CMU CL, the answer was implicitly always true, so this
;;; predicate didn't exist.
;;;
;;; This predicate was added to fix bug 138 in SBCL. In some obscure
-;;; circumstances, it was possible for a *FREE-FUNCTIONS* to contain a
+;;; circumstances, it was possible for a *FREE-FUNS* 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
;;; *CURRENT-COMPONENT*. At that point things got all confused, since
;;; IR1 conversion was sending code to a component which had already
;;; been compiled and would never be compiled again.
-(defun invalid-free-function-p (free-function)
- ;; There might be other reasons that *FREE-FUNCTION* entries could
+(defun invalid-free-fun-p (free-fun)
+ ;; There might be other reasons that *FREE-FUN* entries could
;; become invalid, but the only one we've been bitten by so far
;; (sbcl-0.pre7.118) is this one:
- (and (defined-fun-p free-function)
- (let ((functional (defined-fun-functional free-function)))
+ (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
;; confusion.
(eql (component-info (lambda-component functional)) :dead))))))
-;;; If NAME already has a valid entry in *FREE-FUNCTIONS*, then return
+;;; If NAME already has a valid entry in *FREE-FUNS*, then return
;;; the value. Otherwise, make a new GLOBAL-VAR using information from
-;;; the global environment and enter it in *FREE-FUNCTIONS*. If NAME
+;;; the global environment and enter it in *FREE-FUNS*. If NAME
;;; 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.
-(defun find-free-function (name context)
+(defun find-free-fun (name context)
(declare (string context))
(declare (values global-var))
- (or (let ((old-free-function (gethash name *free-functions*)))
- (and (not (invalid-free-function-p old-free-function))
- old-free-function))
+ (or (let ((old-free-fun (gethash name *free-funs*)))
+ (and (not (invalid-free-fun-p old-free-fun))
+ old-free-fun))
(ecase (info :function :kind name)
;; FIXME: The :MACRO and :SPECIAL-FORM cases could be merged.
(:macro
context))
((:function nil)
(check-fun-name name)
- (note-if-setf-function-and-macro name)
+ (note-if-setf-fun-and-macro name)
(let ((expansion (fun-name-inline-expansion name))
(inlinep (info :function :inlinep name)))
- (setf (gethash name *free-functions*)
+ (setf (gethash name *free-funs*)
(if (or expansion inlinep)
(make-defined-fun
:%source-name name
:inlinep inlinep
:where-from (info :function :where-from name)
:type (info :function :type name))
- (find-free-really-function 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-function))
-(defun find-lexically-apparent-function (name context)
+(declaim (ftype (function (t string) leaf) find-lexically-apparent-fun))
+(defun find-lexically-apparent-fun (name context)
(let ((var (lexenv-find name functions :test #'equal)))
(cond (var
(unless (leaf-p var)
(compiler-error "found macro name ~S ~A" name context))
var)
(t
- (find-free-function name context)))))
+ (find-free-fun name context)))))
;;; Return the LEAF node for a global variable reference to NAME. If
;;; NAME is already entered in *FREE-VARIABLES*, then we just return
((nil :function)
(ir1-convert-srctran start
cont
- (find-free-function fun
- "shouldn't happen! (no-cmacro)")
+ (find-free-fun fun "shouldn't happen! (no-cmacro)")
form))))
(defun muffle-warning-or-die ()
(declare (type continuation start cont) (list form) (type global-var var))
(let ((info (info :function :info (leaf-source-name var))))
(if (and info
- (ir1-attributep (function-info-attributes info) predicate)
+ (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))))
:unwinnage-fun #'compiler-note
:where "FTYPE declaration"))
(t
- (res (cons (find-lexically-apparent-function
+ (res (cons (find-lexically-apparent-fun
name "in a function type declaration")
type))))))
(if (res)
(if fvar
(setf (functional-inlinep fvar) sense)
(let ((found
- (find-lexically-apparent-function
+ (find-lexically-apparent-fun
name "in an inline or notinline declaration")))
(etypecase found
(functional
;;; substitute for the previous references.
(defun get-defined-fun (name)
(proclaim-as-fun-name name)
- (let ((found (find-free-function name "shouldn't happen! (defined-fun)")))
+ (let ((found (find-free-fun name "shouldn't happen! (defined-fun)")))
(note-name-defined name :function)
(cond ((not (defined-fun-p found))
(aver (not (info :function :inlinep name)))
:declared :defined)
:type (leaf-type found))))
(substitute-leaf res found)
- (setf (gethash name *free-functions*) res)))
- ;; If *FREE-FUNCTIONS* has a previously converted definition
+ (setf (gethash name *free-funs*) res)))
+ ;; If *FREE-FUNS* has a previously converted definition
;; for this name, then blow it away and try again.
((defined-fun-functional found)
- (remhash name *free-functions*)
+ (remhash name *free-funs*)
(get-defined-fun name))
(t found))))
:really-assert
(and for-real
(not (and info
- (ir1-attributep (function-info-attributes info)
+ (ir1-attributep (fun-info-attributes info)
explicit-check))))
:where (if for-real
"previous declaration"
(setf (defined-fun-inline-expansion var) nil))
(let* ((name (leaf-source-name var))
(fun (funcall converter lambda :source-name name))
- (function-info (info :function :info 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)
;; old references.
(unless (or (eq (defined-fun-inlinep var) :notinline)
(not *block-compile*)
- (and function-info
- (or (function-info-transforms function-info)
- (function-info-templates function-info)
- (function-info-ir2-convert function-info))))
+ (and fun-info
+ (or (fun-info-transforms fun-info)
+ (fun-info-templates fun-info)
+ (fun-info-ir2-convert fun-info))))
(substitute-leaf fun var)
;; If in a simple environment, then we can allow backward
;; references to this function from following top level forms.
(when (boundp '*lexenv*) ; when in the compiler
(when sb!xc:*compile-print*
(compiler-mumble "~&; recognizing DEFUN ~S~%" name))
- (remhash name *free-functions*)
+ (remhash name *free-funs*)
(setf defined-fun (get-defined-fun name)))
(become-defined-fun-name name)
;;; of arguments changes, the transform must be prepared to return a
;;; lambda with a new lambda-list with the correct number of
;;; arguments.
-(defun extract-function-args (cont fun num-args)
+(defun extract-fun-args (cont fun num-args)
#!+sb-doc
"If CONT is a call to FUN with NUM-ARGS args, change those arguments
to feed directly to the continuation-dest of CONT, which must be
(setf (combination-args outside)
(append before-args inside-args after-args))
(change-ref-leaf (continuation-use inside-fun)
- (find-free-function 'list "???"))
+ (find-free-fun 'list "???"))
(setf (combination-kind inside) :full)
(setf (node-derived-type inside) *wild-type*)
(flush-dest cont)
;;; -- Known to be a function, no check needed: return the
;;; continuation loc.
;;; -- Not known what it is.
-(defun function-continuation-tn (node block cont)
+(defun fun-continuation-tn (node block cont)
(declare (type continuation cont))
(let ((2cont (continuation-info cont)))
(if (eq (ir2-continuation-kind 2cont) :delayed)
(return-pc (ir2-physenv-return-pc env)))
(multiple-value-bind (fun-tn named)
- (function-continuation-tn node block (basic-combination-fun node))
+ (fun-continuation-tn node block (basic-combination-fun node))
(if named
(vop* tail-call-named node block
(fun-tn old-fp return-pc pass-refs)
(loc-refs (reference-tn-list locs t))
(nvals (length locs)))
(multiple-value-bind (fun-tn named)
- (function-continuation-tn node block (basic-combination-fun node))
+ (fun-continuation-tn node block (basic-combination-fun node))
(if named
(vop* call-named node block (fp fun-tn args) (loc-refs)
arg-locs nargs nvals)
(locs (ir2-continuation-locs (continuation-info cont)))
(loc-refs (reference-tn-list locs t)))
(multiple-value-bind (fun-tn named)
- (function-continuation-tn node block (basic-combination-fun node))
+ (fun-continuation-tn node block (basic-combination-fun node))
(if named
(vop* multiple-call-named node block (fp fun-tn args) (loc-refs)
arg-locs nargs)
(cont (node-cont node))
(2cont (continuation-info cont)))
(multiple-value-bind (fun named)
- (function-continuation-tn node block (basic-combination-fun node))
+ (fun-continuation-tn node block (basic-combination-fun node))
(aver (and (not named)
(eq (ir2-continuation-kind start-cont) :unknown)))
(cond
(if name
(emit-constant name)
(multiple-value-bind (tn named)
- (function-continuation-tn last 2block fun)
+ (fun-continuation-tn last 2block fun)
(aver (not named))
tn)))))))
((not (eq (ir2-block-next 2block) (block-info target)))
(:full
(ir2-convert-full-call node 2block))
(t
- (let ((fun (function-info-ir2-convert kind)))
+ (let ((fun (fun-info-ir2-convert kind)))
(cond (fun
(funcall fun node 2block))
((eq (basic-combination-info node) :full)
;; not be asserted when a definition is compiled.
explicit-check)
-(defstruct (function-info #-sb-xc-host (:pure t))
+(defstruct (fun-info #-sb-xc-host (:pure t))
;; Boolean attributes of this function.
(attributes (missing-arg) :type attributes)
;; A list of Transform structures describing transforms for this function.
;; compiler. If it returns NIL, then change the call to :full.
(byte-annotate nil :type (or function null)))
-(defprinter (function-info)
+(defprinter (fun-info)
(transforms :test transforms)
(derive-type :test derive-type)
(optimizer :test optimizer)
(defprinter (transform) type note important when)
-;;; Grab the FUNCTION-INFO and enter the function, replacing any old
+;;; Grab the FUN-INFO and enter the function, replacing any old
;;; one with the same type and note.
(declaim (ftype (function (t list function &optional (or string null)
(member t nil) (member :native :byte :both))
(defun %deftransform (name type fun &optional note important (when :native))
(let* ((ctype (specifier-type type))
(note (or note "optimize"))
- (info (function-info-or-lose name))
+ (info (fun-info-or-lose name))
(old (find-if (lambda (x)
(and (type= (transform-type x) ctype)
(string-equal (transform-note x) note)
(eq (transform-important x) important)
(eq (transform-when x) when)))
- (function-info-transforms info))))
+ (fun-info-transforms info))))
(if old
(setf (transform-function old) fun
(transform-note old) note)
(push (make-transform :type ctype :function fun :note note
:important important :when when)
- (function-info-transforms info)))
+ (fun-info-transforms info)))
name))
-;;; Make a FUNCTION-INFO structure with the specified type, attributes
+;;; Make a FUN-INFO structure with the specified type, attributes
;;; and optimizers.
(declaim (ftype (function (list list attributes &key
(:derive-type (or function null))
%defknown))
(defun %defknown (names type attributes &key derive-type optimizer)
(let ((ctype (specifier-type type))
- (info (make-function-info :attributes attributes
+ (info (make-fun-info :attributes attributes
:derive-type derive-type
:optimizer optimizer))
(target-env *info-environment*))
(dolist (name names)
- (let ((old-function-info (info :function :info name)))
- (when old-function-info
+ (let ((old-fun-info (info :function :info name)))
+ (when old-fun-info
;; This is handled as an error because it's generally a bad
;; thing to blow away all the old optimization stuff. It's
;; also a potential source of sneaky bugs:
;; However, it's continuable because it might be useful to do
;; it when testing new optimization stuff interactively.
(cerror "Go ahead, overwrite it."
- "~@<overwriting old FUNCTION-INFO ~2I~_~S ~I~_for ~S~:>"
- old-function-info name)))
+ "~@<overwriting old FUN-INFO ~2I~_~S ~I~_for ~S~:>"
+ old-fun-info name)))
(setf (info :function :type name target-env) ctype)
(setf (info :function :where-from name target-env) :declared)
(setf (info :function :kind name target-env) :function)
(setf (info :function :info name target-env) info)))
names)
-;;; Return the FUNCTION-INFO for NAME or die trying. Since this is
+;;; Return the FUN-INFO for NAME or die trying. Since this is
;;; used by callers who want to modify the info, and the info may be
;;; shared, we copy it. We don't have to copy the lists, since each
;;; function that has generators or transforms has already been
;;; through here.
-(declaim (ftype (function (t) function-info) function-info-or-lose))
-(defun function-info-or-lose (name)
+(declaim (ftype (function (t) fun-info) fun-info-or-lose))
+(defun fun-info-or-lose (name)
(let (;; FIXME: Do we need this rebinding here? It's a literal
;; translation of the old CMU CL rebinding to
;; (OR *BACKEND-INFO-ENVIRONMENT* *INFO-ENVIRONMENT*),
(*info-environment* *info-environment*))
(let ((old (info :function :info name)))
(unless old (error "~S is not a known function." name))
- (setf (info :function :info name) (copy-function-info old)))))
+ (setf (info :function :info name) (copy-fun-info old)))))
\f
;;;; generic type inference methods
;;; work. We change the CALL's CONT to be the continuation heading the
;;; BIND block, and also do REOPTIMIZE-CONTINUATION on the args and
;;; CONT so that LET-specific IR1 optimizations get a chance. We blow
-;;; away any entry for the function in *FREE-FUNCTIONS* so that nobody
+;;; away any entry for the function in *FREE-FUNS* so that nobody
;;; will create new references to it.
(defun let-convert (fun call)
(declare (type clambda fun) (type basic-combination call))
;;; Unlike for an argument, we only clear the type check flag when the
;;; LTN-POLICY is unsafe, since the check for a valid function
;;; object must be done before the call.
-(defun annotate-function-continuation (cont ltn-policy &optional (delay t))
+(defun annotate-fun-continuation (cont ltn-policy &optional (delay t))
(declare (type continuation cont) (type ltn-policy ltn-policy))
(unless (ltn-policy-safe-p ltn-policy)
(flush-type-check cont))
(defun ltn-default-call (call ltn-policy)
(declare (type combination call) (type ltn-policy ltn-policy))
(let ((kind (basic-combination-kind call)))
- (annotate-function-continuation (basic-combination-fun call) ltn-policy)
+ (annotate-fun-continuation (basic-combination-fun call) ltn-policy)
(cond
- ((and (function-info-p kind)
- (function-info-ir2-convert kind))
+ ((and (fun-info-p kind)
+ (fun-info-ir2-convert kind))
(setf (basic-combination-info call) :funny)
(setf (node-tail-p call) nil)
(dolist (arg (basic-combination-args call))
(setf (node-tail-p call) nil))
(t
(setf (basic-combination-info call) :full)
- (annotate-function-continuation (basic-combination-fun call)
- ltn-policy
- nil)
+ (annotate-fun-continuation (basic-combination-fun call)
+ ltn-policy
+ nil)
(dolist (arg (reverse args))
(annotate-unknown-values-continuation arg ltn-policy))
(flush-full-call-tail-transfer call))))
(declare (type combination call)
(type ltn-policy ltn-policy))
(let ((safe-p (ltn-policy-safe-p ltn-policy))
- (current (function-info-templates (basic-combination-kind call)))
+ (current (fun-info-templates (basic-combination-kind call)))
(fallback nil)
(rejected nil))
(loop
(or template
(template-or-lose 'call-named)))
*efficiency-note-cost-threshold*)))
- (dolist (try (function-info-templates (basic-combination-kind call)))
+ (dolist (try (fun-info-templates (basic-combination-kind call)))
(when (> (template-cost try) max-cost) (return)) ; FIXME: UNLESS'd be cleaner.
(let ((guard (template-guard try)))
(when (and (or (not guard) (funcall guard))
(ltn-policy-safe-p (template-ltn-policy try)))
(or verbose-p
(and (template-note try)
- (valid-function-use
+ (valid-fun-use
call (template-type try)
:argument-test #'types-equal-or-intersect
:result-test
(lose1 "etc.")
(return))
(let* ((type (template-type loser))
- (valid (valid-function-use call type))
- (strict-valid (valid-function-use call type
- :strict-result t)))
+ (valid (valid-fun-use call type))
+ (strict-valid (valid-fun-use call type
+ :strict-result t)))
(lose1 "unable to do ~A (cost ~W) because:"
(or (template-note loser) (template-name loser))
(template-cost loser))
((and valid strict-valid)
(strange-template-failure loser call ltn-policy #'lose1))
((not valid)
- (aver (not (valid-function-use call type
- :lossage-fun #'lose1
- :unwinnage-fun #'lose1))))
+ (aver (not (valid-fun-use call type
+ :lossage-fun #'lose1
+ :unwinnage-fun #'lose1))))
(t
(aver (ltn-policy-safe-p ltn-policy))
(lose1 "can't trust output type assertion under safe policy")))
(defun ltn-analyze-known-call (call ltn-policy)
(declare (type combination call)
(type ltn-policy ltn-policy))
- (let ((method (function-info-ltn-annotate (basic-combination-kind call)))
+ (let ((method (fun-info-ltn-annotate (basic-combination-kind call)))
(args (basic-combination-args call)))
(when method
(funcall method call ltn-policy)
(eq (continuation-fun-name (combination-fun call))
(leaf-source-name funleaf))
(let ((info (basic-combination-kind call)))
- (not (or (function-info-ir2-convert info)
- (ir1-attributep (function-info-attributes info)
+ (not (or (fun-info-ir2-convert info)
+ (ir1-attributep (fun-info-attributes info)
recursive))))))
(let ((*compiler-error-context* call))
(compiler-warn "~@<recursion in known function definition~2I ~
,(parse-deftransform lambda-list body n-args
`(return-from ,name nil))))
,@(when (consp what)
- `((setf (,(symbolicate "FUNCTION-INFO-" (second what))
- (function-info-or-lose ',(first what)))
+ `((setf (,(symbolicate "FUN-INFO-" (second what))
+ (fun-info-or-lose ',(first what)))
#',name)))))))
\f
;;;; IR groveling macros
;;; functions, etc. Also establish condition handlers.
(defmacro with-ir1-namespace (&body forms)
`(let ((*free-variables* (make-hash-table :test 'eq))
- (*free-functions* (make-hash-table :test 'equal))
+ (*free-funs* (make-hash-table :test 'equal))
(*constants* (make-hash-table :test 'equal))
(*source-paths* (make-hash-table :test 'eq)))
(handler-bind ((compiler-error #'compiler-error-handler)
;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp?
(declaim (special *constants* *free-variables* *component-being-compiled*
*code-vector* *next-location* *result-fixups*
- *free-functions* *source-paths*
- *seen-blocks* *seen-functions* *list-conflicts-table*
+ *free-funs* *source-paths*
+ *seen-blocks* *seen-funs* *list-conflicts-table*
*continuation-number* *continuation-numbers*
*number-continuations* *tn-id* *tn-ids* *id-tns*
*label-ids* *label-id* *id-labels*
(here-p (x)
(eq (node-component x) component)))
(blast *free-variables*)
- (blast *free-functions*)
+ (blast *free-funs*)
(blast *constants*))
(values))
(defun clear-stuff (&optional (debug-too t))
;; Clear global tables.
- (when (boundp '*free-functions*)
- (clrhash *free-functions*)
+ (when (boundp '*free-funs*)
+ (clrhash *free-funs*)
(clrhash *free-variables*)
(clrhash *constants*))
;; Clear debug counters and tables.
(clrhash *seen-blocks*)
- (clrhash *seen-functions*)
+ (clrhash *seen-funs*)
(clrhash *list-conflicts-table*)
(when debug-too
;;; set the Predicate attribute for each translated function when the
;;; VOP is conditional, causing IR1 conversion to ensure that a call
;;; to the translated is always used in a predicate position.
-(defun set-up-function-translation (parse n-template)
+(defun !set-up-fun-translation (parse n-template)
(declare (type vop-parse parse))
(mapcar (lambda (name)
- `(let ((info (function-info-or-lose ',name)))
- (setf (function-info-templates info)
- (adjoin-template ,n-template
- (function-info-templates info)))
+ `(let ((info (fun-info-or-lose ',name)))
+ (setf (fun-info-templates info)
+ (adjoin-template ,n-template (fun-info-templates info)))
,@(when (vop-parse-conditional-p parse)
- '((setf (function-info-attributes info)
+ '((setf (fun-info-attributes info)
(attributes-union
(ir1-attributes predicate)
- (function-info-attributes info)))))))
+ (fun-info-attributes info)))))))
(vop-parse-translate parse)))
;;; Return a form that can be evaluated to get the TEMPLATE operand type
(setf (gethash ',name *backend-template-names*) ,n-res)
(setf (template-type ,n-res)
(specifier-type (template-type-specifier ,n-res)))
- ,@(set-up-function-translation parse n-res))
+ ,@(!set-up-fun-translation parse n-res))
',name)))
\f
;;;; emission macros
;; the kind of function call being made. :LOCAL means that this is a
;; local call to a function in the same component, and that argument
;; syntax checking has been done, etc. Calls to known global
- ;; functions are represented by storing the FUNCTION-INFO for the
+ ;; functions are represented by storing the FUN-INFO for the
;; function in this slot. :FULL is a call to an (as yet) unknown
;; function. :ERROR is like :FULL, but means that we have discovered
;; that the call contains an error, and should not be reconsidered
;; for optimization.
- (kind :full :type (or (member :local :full :error) function-info))
+ (kind :full :type (or (member :local :full :error) fun-info))
;; some kind of information attached to this node by the back end
(info nil))
(eql (continuation-value offset) 0))
'sap)
(t
- (extract-function-args sap 'sap+ 2)
+ (extract-fun-args sap 'sap+ 2)
'(lambda (sap offset1 offset2)
(sap+ sap (+ offset1 offset2))))))
(macrolet ((def-frob (fun)
`(deftransform ,fun ((sap offset) * *)
- (extract-function-args sap 'sap+ 2)
+ (extract-fun-args sap 'sap+ 2)
`(lambda (sap offset1 offset2)
(,',fun sap (+ offset1 offset2))))))
(def-frob sap-ref-8)
;; if ITEM is not a NUMBER or is a FIXNUM, apply
;; transform, else give up on transform.
(cond (test
- (unless (continuation-function-is test '(eq))
+ (unless (continuation-fun-is test '(eq))
(give-up-ir1-transform)))
((types-equal-or-intersect (continuation-type item)
(specifier-type 'number))
\f
;;;; utilities
-;;; Return true if CONT's only use is a non-notinline reference to a
+;;; Return true if CONT's only use is a non-NOTINLINE reference to a
;;; global function with one of the specified NAMES.
-(defun continuation-function-is (cont names)
+(defun continuation-fun-is (cont names)
(declare (type continuation cont) (list names))
(let ((use (continuation-use cont)))
(and (ref-p use)
(t
(give-up-ir1-transform))))
+;;; FIXME: Why is this code commented out? (Why *was* it commented
+;;; out? We inherited this situation from cmucl-2.4.8, with no
+;;; explanation.) Should we just delete this code?
#|
;;; This is a frob whose job it is to make it easier to pass around
;;; the arguments to IR1 transforms. It bundles together the name of
(defun make-result-sequence-iterator (name type length)
(declare (symbol name) (type ctype type))
-;;; Defines each Name as a local macro that will call the value of the
-;;; Fun-Arg with the given arguments. If the argument isn't known to be a
+;;; Define each NAME as a local macro that will call the value of the
+;;; function arg with the given arguments. If the argument isn't known to be a
;;; function, give them an efficiency note and reference a coerced version.
-(defmacro coerce-functions (specs &body body)
+(defmacro coerce-funs (specs &body body)
#!+sb-doc
"COERCE-FUNCTIONS ({(Name Fun-Arg Default)}*) Form*"
(collect ((binds)
(abort-ir1-transform "Both ~S and ~S were supplied."
(arg-name ,test)
(arg-name ,test-not)))
- (coerce-functions ((,name (if not-p ,test-not ,test) eql))
+ (coerce-funs ((,name (if not-p ,test-not ,test) eql))
,@body)))
|#
\f
(declare (type sb!kernel:code-component code-component))
(sb!sys:sap-int (sb!kernel:code-instructions code-component)))
+;;; unused as of sbcl-0.pre7.129
+#|
;;; Return the first function in CODE-COMPONENT.
(defun code-first-function (code-component)
(declare (type sb!kernel:code-component code-component))
(sb!kernel:code-header-ref code-component
sb!vm:code-trace-table-offset-slot))
+|#
(defun segment-offs-to-code-offs (offset segment)
(sb!sys:without-gcing
(:vop-var vop)
(:generator 1
(align n-lowtag-bits)
- (trace-table-entry trace-table-function-prologue)
+ (trace-table-entry trace-table-fun-prologue)
(emit-label start-lab)
;; Skip space for the function header.
(inst simple-fun-header-word)
(let ((defaults (defaults)))
(when defaults
(assemble (*elsewhere*)
- (trace-table-entry trace-table-function-prologue)
+ (trace-table-entry trace-table-fun-prologue)
(emit-label default-stack-slots)
(dolist (default defaults)
(emit-label (car default))
(:ignore val-locs vals)
(:vop-var vop)
(:generator 6
- (trace-table-entry trace-table-function-epilogue)
+ (trace-table-entry trace-table-fun-epilogue)
;; Save the return-pc in a register 'cause the frame-pointer is
;; going away. Note this not in the usual stack location so we
;; can't use RET
(:ignore val-locs vals)
(:vop-var vop)
(:generator 6
- (trace-table-entry trace-table-function-epilogue)
+ (trace-table-entry trace-table-fun-epilogue)
#+nil (format t "*known-return: old-fp ~S, tn-kind ~S; ~S ~S~%"
old-fp (sb!c::tn-kind old-fp) (sb!c::tn-save-tn old-fp)
(sb!c::tn-kind (sb!c::tn-save-tn old-fp)))
#+nil (format t "*known-return: return-pc ~S, tn-kind ~S; ~S ~S~%"
- return-pc (sb!c::tn-kind return-pc) (sb!c::tn-save-tn return-pc)
+ return-pc (sb!c::tn-kind return-pc)
+ (sb!c::tn-save-tn return-pc)
(sb!c::tn-kind (sb!c::tn-save-tn return-pc)))
;; return-pc may be either in a register or on the stack.
(:temporary (:sc unsigned-reg) ret)
(:ignore value)
(:generator 6
- (trace-table-entry trace-table-function-epilogue)
+ (trace-table-entry trace-table-fun-epilogue)
(move ret return-pc)
;; Clear the control stack
(move ofp old-fp)
:from :eval) a2)
(:generator 6
- (trace-table-entry trace-table-function-epilogue)
+ (trace-table-entry trace-table-fun-epilogue)
;; Establish the values pointer and values count.
(move ebx ebp-tn)
(if (zerop nvals)
(:node-var node)
(:generator 13
- (trace-table-entry trace-table-function-epilogue)
+ (trace-table-entry trace-table-fun-epilogue)
;; Load the return-pc.
(move eax return-pc)
(unless (policy node (> space speed))
;;; CELL-REF and CELL-SET are used to define VOPs like CAR, where the
;;; offset to be read or written is a property of the VOP used.
;;; CELL-SETF is similar to CELL-SET, but delivers the new value as
-;;; the result. CELL-SETF-FUNCTION takes its arguments as if it were a
+;;; the result. CELL-SETF-FUN takes its arguments as if it were a
;;; SETF function (new value first, as apposed to a SETF macro, which
;;; takes the new value last).
(define-vop (cell-ref)
(:generator 4
(storew value object offset lowtag)
(move result value)))
-(define-vop (cell-setf-function)
+(define-vop (cell-setf-fun)
(:args (value :scs (descriptor-reg any-reg) :target result)
(object :scs (descriptor-reg)))
(:results (result :scs (descriptor-reg any-reg)))
(defenum (:prefix trace-table-)
normal
call-site
- function-prologue
- function-epilogue)
+ fun-prologue
+ fun-epilogue)
\f
;;;; static symbols
DONE
(inst movzx result al-tn)))
\f
-(define-vop (function-subtype)
- (:translate function-subtype)
+(define-vop (fun-subtype)
+ (:translate fun-subtype)
(:policy :fast-safe)
(:args (function :scs (descriptor-reg)))
(:temporary (:sc byte-reg :from (:eval 0) :to (:eval 1)) temp)
(load-type temp function (- fun-pointer-lowtag))
(inst movzx result temp)))
-(define-vop (set-function-subtype)
- (:translate (setf function-subtype))
+(define-vop (set-fun-subtype)
+ (:translate (setf fun-subtype))
(:policy :fast-safe)
(:args (type :scs (unsigned-reg) :target eax)
(function :scs (descriptor-reg)))
(inst lea sap (make-ea :byte :base code :index sap :scale 4
:disp (- other-pointer-lowtag)))))
-(define-vop (compute-function)
+(define-vop (compute-fun)
(:args (code :scs (descriptor-reg) :to (:result 0))
(offset :scs (signed-reg unsigned-reg) :to (:result 0)))
(:arg-types * positive-fixnum)
(when lambda-list-p
(proclaim (defgeneric-declaration fun-name lambda-list)))))
\f
-(defun get-generic-function-info (gf)
+(defun get-generic-fun-info (gf)
;; values nreq applyp metatypes nkeys arg-info
(multiple-value-bind (applyp metatypes arg-info)
(let* ((arg-info (if (early-gf-p gf)
(defun expand-effective-method-function (gf effective-method &optional env)
(declare (ignore env))
(multiple-value-bind (nreq applyp metatypes nkeys arg-info)
- (get-generic-function-info gf)
+ (get-generic-fun-info gf)
(declare (ignore nreq nkeys arg-info))
(let ((ll (make-fast-method-call-lambda-list metatypes applyp))
;; When there are no primary methods and a next-method call occurs
(defun make-effective-method-function-internal
(generic-function effective-method method-alist-p wrappers-p)
(multiple-value-bind (nreq applyp metatypes nkeys arg-info)
- (get-generic-function-info generic-function)
+ (get-generic-fun-info generic-function)
(declare (ignore nkeys arg-info))
(let* ((*rebound-effective-method-gensyms*
*global-effective-method-gensyms*)
(when (use-dispatch-dfun-p generic-function)
(return-from make-checking-dfun (make-dispatch-dfun generic-function))))
(multiple-value-bind (nreq applyp metatypes nkeys)
- (get-generic-function-info generic-function)
+ (get-generic-fun-info generic-function)
(declare (ignore nreq))
(if (every (lambda (mt) (eq mt t)) metatypes)
(let ((dfun-info (default-method-only-dfun-info)))
(defun use-default-method-only-dfun-p (generic-function)
(multiple-value-bind (nreq applyp metatypes nkeys)
- (get-generic-function-info generic-function)
+ (get-generic-fun-info generic-function)
(declare (ignore nreq applyp nkeys))
(every (lambda (mt) (eq mt t)) metatypes)))
(return-from make-caching-dfun
(make-dispatch-dfun generic-function))))
(multiple-value-bind (nreq applyp metatypes nkeys)
- (get-generic-function-info generic-function)
+ (get-generic-fun-info generic-function)
(declare (ignore nreq))
(let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
(dfun-info (caching-dfun-info cache)))
(defun insure-caching-dfun (gf)
(multiple-value-bind (nreq applyp metatypes nkeys)
- (get-generic-function-info gf)
+ (get-generic-fun-info gf)
(declare (ignore nreq nkeys))
(when (and metatypes
(not (null (car metatypes)))
(defun use-constant-value-dfun-p (gf &optional boolean-values-p)
(multiple-value-bind (nreq applyp metatypes nkeys)
- (get-generic-function-info gf)
+ (get-generic-fun-info gf)
(declare (ignore nreq metatypes nkeys))
(let* ((early-p (early-gf-p gf))
(methods (if early-p
(defun make-constant-value-dfun (generic-function &optional cache)
(multiple-value-bind (nreq applyp metatypes nkeys)
- (get-generic-function-info generic-function)
+ (get-generic-fun-info generic-function)
(declare (ignore nreq applyp))
(let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
(dfun-info (constant-value-dfun-info cache)))
;;; in the object argument.
(defun cache-miss-values (gf args state)
(multiple-value-bind (nreq applyp metatypes nkeys arg-info)
- (get-generic-function-info gf)
+ (get-generic-fun-info gf)
(declare (ignore nreq applyp nkeys))
(with-dfun-wrappers (args metatypes)
(dfun-wrappers invalid-wrapper-p wrappers classes types)
(defun types-from-arguments (generic-function arguments
&optional type-modifier)
(multiple-value-bind (nreq applyp metatypes nkeys arg-info)
- (get-generic-function-info generic-function)
+ (get-generic-fun-info generic-function)
(declare (ignore applyp metatypes nkeys))
(let ((types-rev nil))
(dotimes-fixnum (i nreq)
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.128"
+"0.pre7.129"
projects / sbcl.git / commitdiff