"CALL" "CALL-LOCAL" "CALL-NAMED" "CALL-OUT" "CALL-VARIABLE"
"CALLEE-NFP-TN" "CALLEE-RETURN-PC-TN"
"CASE-BODY" "CATCH-BLOCK" "CHECK-CONS"
- "CHECK-FIXNUM" "CHECK-FUNCTION" "CHECK-FUNCTION-OR-SYMBOL"
+ "CHECK-FIXNUM" "CHECK-FUNCTION"
"CHECK-SIGNED-BYTE-32" "CHECK-SYMBOL" "CHECK-UNSIGNED-BYTE-32"
"CLOSURE-INIT" "CLOSURE-REF"
"CODE-CONSTANT-REF" "CODE-CONSTANT-SET"
"FIXUP-P" "MAKE-FIXUP"
"DEF-ALLOC"
"VAR-ALLOC"
- "SAFE-FDEFN-FUNCTION"
+ "SAFE-FDEFN-FUN"
"NOTE-FIXUP"
"DEF-REFFER"
"EMIT-NOP"
"VOP-BLOCK"
"*ASSEMBLY-OPTIMIZE*"
"LARGE-ALLOC"
- "%SET-FUNCTION-SELF"
+ "%SET-SIMPLE-FUN-SELF"
"VM-SUPPORT-ROUTINES-IMMEDIATE-CONSTANT-SC"
"VM-SUPPORT-ROUTINES-LOCATION-PRINT-NAME"
"VM-SUPPORT-ROUTINES-PRIMITIVE-TYPE-OF"
"%ARRAY-FILL-POINTER-P"
"%ASIN" "%ASINH"
"%ATAN" "%ATAN2" "%ATANH"
- "%CALLER-FRAME-AND-PC" "%CHECK-BOUND" "%CLOSURE-FUNCTION"
+ "%CALLER-FRAME-AND-PC" "%CHECK-BOUND" "%CLOSURE-FUN"
"%CLOSURE-INDEX-REF" "%COS" "%COS-QUICK"
"%COSH" "%DEPOSIT-FIELD"
"%DOUBLE-FLOAT" "%DPB" "%EXP" "%EXPM1"
"%RAW-REF-SINGLE" "%RAW-SET-COMPLEX-DOUBLE"
"%RAW-SET-COMPLEX-LONG" "%RAW-SET-COMPLEX-SINGLE"
"%RAW-SET-DOUBLE" "%RAW-SET-LONG" "%RAW-SET-SINGLE"
- "%SCALB" "%SCALBN" "%SET-FUNCALLABLE-INSTANCE-FUNCTION"
+ "%SCALB" "%SCALBN" "%SET-FUNCALLABLE-INSTANCE-FUN"
"%SET-FUNCALLABLE-INSTANCE-INFO" "%SET-RAW-BITS"
"%SET-SAP-REF-16" "%SET-SAP-REF-32" "%SET-SAP-REF-64"
"%SET-SAP-REF-8" "%SET-SAP-REF-DOUBLE" "%SET-SAP-REF-LONG"
"FLOAT-EXPONENT" "FLOAT-FORMAT-DIGITS" "FLOAT-FORMAT-NAME"
"FLOAT-FORMAT-MAX" "FLOATING-POINT-EXCEPTION"
"FORM" "*FREE-INTERRUPT-CONTEXT-INDEX*" "FUNCALLABLE-INSTANCE-P"
- "FUNCTION-CODE-HEADER" "FUNCTION-DOC"
- "FUN-TYPE"
- "FUN-TYPE-ALLOWP"
+ "FUN-CODE-HEADER" "FUNCTION-DOC"
+ "FUN-TYPE" "FUN-TYPE-ALLOWP"
"FUN-TYPE-KEYP" "FUN-TYPE-KEYWORDS"
"FUN-TYPE-NARGS" "FUN-TYPE-OPTIONAL"
"FUN-TYPE-P"
"FUN-TYPE-REQUIRED" "FUN-TYPE-REST"
"FUN-TYPE-RETURNS" "FUN-TYPE-WILD-ARGS"
- "FUNCTION-WORD-OFFSET" "GET-CLOSURE-LENGTH"
+ "FUN-WORD-OFFSET" "GET-CLOSURE-LENGTH"
"GET-HEADER-DATA"
"GET-LISP-OBJ-ADDRESS" "GET-LOWTAG"
"GET-TYPE"
"WRONG-NUMBER-OF-INDICES-ERROR"
"FDEFN" "MAKE-FDEFN" "FDEFN-P"
- "FDEFN-NAME" "FDEFN-FUNCTION"
+ "FDEFN-NAME" "FDEFN-FUN"
"FDEFN-MAKUNBOUND" "%COERCE-NAME-TO-FUNCTION"
"%COERCE-CALLABLE-TO-FUNCTION"
"FUNCTION-SUBTYPE" "*MAXIMUM-ERROR-DEPTH*"
"%IMAGPART" "DSD-ACCESSOR-NAME"
"%CODE-DEBUG-INFO" "DSD-%NAME"
"LAYOUT-CLASS" "LAYOUT-INVALID"
- "%FUNCTION-NAME" "DSD-TYPE" "%INSTANCEP"
- "DEFSTRUCT-SLOT-DESCRIPTION" "%FUNCTION-ARGLIST"
- "%FUNCTION-NEXT" "LAYOUT-CLOS-HASH-LENGTH" "DD-PREDICATE-NAME"
+ "%SIMPLE-FUN-NAME" "DSD-TYPE" "%INSTANCEP"
+ "DEFSTRUCT-SLOT-DESCRIPTION" "%SIMPLE-FUN-ARGLIST"
+ "%SIMPLE-FUN-NEXT" "LAYOUT-CLOS-HASH-LENGTH" "DD-PREDICATE-NAME"
"CLASS-PROPER-NAME" "%NOTE-TYPE-DEFINED" "LAYOUT-INFO"
"%SET-INSTANCE-LAYOUT" "DD-DEFAULT-CONSTRUCTOR"
- "LAYOUT-OF" "%FUNCTION-SELF" "%REALPART"
+ "LAYOUT-OF" "%SIMPLE-FUN-SELF" "%REALPART"
"STRUCTURE-CLASS-P" "DSD-INDEX"
"%INSTANCE-LAYOUT" "LAYOUT-CLOS-HASH"
- "%FUN-TYPE" "PROCLAIM-AS-FUNCTION-NAME"
+ "%SIMPLE-FUN-TYPE" "PROCLAIM-AS-FUNCTION-NAME"
"BECOME-DEFINED-FUNCTION-NAME"
"%NUMERATOR" "CLASS-TYPEP"
"STRUCTURE-CLASS-PRINT-FUNCTION" "DSD-READ-ONLY"
"CLASS-CELL-NAME" "BUILT-IN-CLASS-DIRECT-SUPERCLASSES"
"RANDOM-LAYOUT-CLOS-HASH"
"CLASS-PCL-CLASS" "FUNCALLABLE-STRUCTURE"
- "FUNCALLABLE-INSTANCE-FUNCTION"
+ "FUNCALLABLE-INSTANCE-FUN"
"%FUNCALLABLE-INSTANCE-LAYOUT"
"BASIC-STRUCTURE-CLASS"
"CLASS-CELL-CLASS"
"FUNCALLABLE-INSTANCE" "RANDOM-FIXNUM-MAX"
"MAKE-RANDOM-PCL-CLASS" "INSTANCE-LAMBDA"
"%FUNCALLABLE-INSTANCE-LEXENV" "%MAKE-SYMBOL"
- "%FUNCALLABLE-INSTANCE-FUNCTION" "SYMBOL-HASH"
+ "%FUNCALLABLE-INSTANCE-FUN" "SYMBOL-HASH"
"MAKE-UNDEFINED-CLASS" "CLASS-DIRECT-SUPERCLASSES" "MAKE-LAYOUT"
"REDEFINE-LAYOUT-WARNING" "SLOT-CLASS"
"REMOVE-DEPENDENT"
"REMOVE-DIRECT-METHOD"
"REMOVE-DIRECT-SUBCLASS"
- "SET-FUNCALLABLE-INSTANCE-FUNCTION"
+ "SET-FUNCALLABLE-INSTANCE-FUN"
"SLOT-BOUNDP-USING-CLASS"
"SLOT-DEFINITION-ALLOCATION"
"SLOT-DEFINITION-INITARGS"
"CATCH-BLOCK-ENTRY-PC-SLOT" "CATCH-BLOCK-PREVIOUS-CATCH-SLOT"
"CATCH-BLOCK-SC-NUMBER" "CATCH-BLOCK-SIZE" "CATCH-BLOCK-SIZE-SLOT"
"CATCH-BLOCK-TAG-SLOT" "CERROR-TRAP"
- "CLOSURE-FUNCTION-HEADER-TYPE" "CLOSURE-FUNCTION-SLOT"
+ "CLOSURE-FUN-HEADER-TYPE" "CLOSURE-FUN-SLOT"
"CLOSURE-HEADER-TYPE" "CLOSURE-INFO-OFFSET"
"CODE-CODE-SIZE-SLOT" "CODE-CONSTANTS-OFFSET"
"CODE-DEBUG-INFO-SLOT" "CODE-ENTRY-POINTS-SLOT" "CODE-HEADER-TYPE"
"DOUBLE-STACK-SC-NUMBER"
"ERROR-TRAP" "EVEN-FIXNUM-TYPE"
"EXPORTED-STATIC-SYMBOLS" "EXTERN-ALIEN-NAME"
- "FDEFN-FUNCTION-SLOT" "FDEFN-NAME-SLOT" "FDEFN-RAW-ADDR-SLOT"
+ "FDEFN-FUN-SLOT" "FDEFN-NAME-SLOT" "FDEFN-RAW-ADDR-SLOT"
"FDEFN-SIZE" "FDEFN-TYPE" "FIND-HOLES" "FIXNUMIZE"
"FIXUP-CODE-OBJECT" "FLOAT-DENORMAL-TRAP-BIT"
"FLOAT-DIVIDE-BY-ZERO-TRAP-BIT"
"FORWARDING-POINTER-TYPE"
"FP-CONSTANT-SC-NUMBER"
"FP-DOUBLE-ZERO-SC-NUMBER" "FP-SINGLE-ZERO-SC-NUMBER"
- "FUNCALLABLE-INSTANCE-FUNCTION-SLOT"
+ "FUNCALLABLE-INSTANCE-FUN-SLOT"
"FUNCALLABLE-INSTANCE-HEADER-TYPE"
"FUNCALLABLE-INSTANCE-INFO-OFFSET"
- "FUNCTION-ARGLIST-SLOT" "FUNCTION-CODE-OFFSET"
+ "SIMPLE-FUN-ARGLIST-SLOT" "SIMPLE-FUN-CODE-OFFSET"
"FUN-END-BREAKPOINT-TRAP"
- "FUNCTION-HEADER-CODE-OFFSET"
- "FUNCTION-HEADER-NEXT-SLOT" "FUNCTION-HEADER-SELF-SLOT"
- "FUNCTION-HEADER-TYPE" "FUNCTION-HEADER-TYPE-SLOT"
- "FUNCTION-NAME-SLOT" "FUNCTION-NEXT-SLOT" "FUNCTION-POINTER-TYPE"
- "FUNCTION-SELF-SLOT" "FUNCTION-TYPE-SLOT"
+ "SIMPLE-FUN-HEADER-CODE-OFFSET"
+ "SIMPLE-FUN-HEADER-NEXT-SLOT"
+ "SIMPLE-FUN-HEADER-SELF-SLOT"
+ "SIMPLE-FUN-HEADER-TYPE"
+ "SIMPLE-FUN-HEADER-TYPE-SLOT"
+ "SIMPLE-FUN-NAME-SLOT"
+ "SIMPLE-FUN-NEXT-SLOT"
+ "FUN-POINTER-TYPE"
+ "SIMPLE-FUN-SELF-SLOT"
+ "SIMPLE-FUN-TYPE-SLOT"
"FUNCALLABLE-INSTANCE-LAYOUT-SLOT"
"FUNCALLABLE-INSTANCE-LEXENV-SLOT"
"GENESIS" "HALT-TRAP" "IGNORE-ME-SC-NUMBER"
"SLOT-REST-P" "*STATIC-FUNCTIONS*" "STATIC-FUNCTION-OFFSET"
"STATIC-SYMBOL-OFFSET" "STATIC-SYMBOL-P"
"*STATIC-SPACE-FREE-POINTER*" "*STATIC-SYMBOLS*"
- "STRUCTURE-USAGE" "SYMBOL-FUNCTION-SLOT"
+ "STRUCTURE-USAGE"
"SYMBOL-HASH-SLOT" "SYMBOL-HEADER-TYPE" "SYMBOL-NAME-SLOT"
"SYMBOL-PACKAGE-SLOT" "SYMBOL-PLIST-SLOT"
- "SYMBOL-RAW-FUNCTION-ADDR-SLOT" "SYMBOL-SETF-FUNCTION-SLOT"
"SYMBOL-SIZE" "SYMBOL-UNUSED-SLOT" "SYMBOL-VALUE-SLOT"
"BINDING-STACK-START" "BINDING-STACK-END"
"CONTROL-STACK-START" "CONTROL-STACK-END"
DONE
;; We are done. Do the jump.
(progn
- (loadw temp lexenv closure-function-slot function-pointer-type)
+ (loadw temp lexenv closure-fun-slot fun-pointer-type)
(lisp-jump temp lip)))
\f
;; And jump into the function.
(inst jmp
(make-ea :byte :base eax
- :disp (- (* closure-function-slot word-bytes)
- function-pointer-type)))
+ :disp (- (* closure-fun-slot word-bytes)
+ fun-pointer-type)))
;; All the arguments fit in registers, so load them.
REGISTER-ARGS
;; And away we go.
(inst jmp (make-ea :byte :base eax
- :disp (- (* closure-function-slot word-bytes)
- function-pointer-type))))
+ :disp (- (* closure-fun-slot word-bytes)
+ fun-pointer-type))))
\f
(define-assembly-routine (throw
(:return-style :none))
(function
:codes (#.sb!vm:closure-header-type
- #.sb!vm:function-header-type)
+ #.sb!vm:simple-fun-header-type)
:state :read-only)
(funcallable-instance
:inherits (function)
;; * SC-offset of primary location, if it has one
;; * SC-offset of save location, if it has one
(variables nil :type (or simple-vector null))
- ;; A vector of the packed binary representation of the COMPILED-DEBUG-BLOCKs
- ;; in this function, in the order that the blocks were emitted. The first
- ;; block is the start of the function. This slot may be NIL to save space.
+ ;; a vector of the packed binary representation of the
+ ;; COMPILED-DEBUG-BLOCKs in this function, in the order that the
+ ;; blocks were emitted. The first block is the start of the
+ ;; function. This slot may be NIL to save space.
;;
;; FIXME: The "packed binary representation" description in the comment
;; above is the same as the description of the old representation of
(defstruct (bogus-debug-fun
(:include debug-fun)
(:constructor make-bogus-debug-fun
- (%name &aux (%lambda-list nil) (%debug-vars nil)
- (blocks nil) (%function nil)))
+ (%name &aux
+ (%lambda-list nil)
+ (%debug-vars nil)
+ (blocks nil)
+ (%function nil)))
(:copier nil))
%name)
(defun current-fp () (current-fp))
(defun stack-ref (s n) (stack-ref s n))
(defun %set-stack-ref (s n value) (%set-stack-ref s n value))
-(defun function-code-header (fun) (function-code-header fun))
+(defun fun-code-header (fun) (fun-code-header fun))
(defun lra-code-header (lra) (lra-code-header lra))
(defun make-lisp-obj (value) (make-lisp-obj value))
(defun get-lisp-obj-address (thing) (get-lisp-obj-address thing))
-(defun function-word-offset (fun) (function-word-offset fun))
+(defun fun-word-offset (fun) (fun-word-offset fun))
#!-sb-fluid (declaim (inline cstack-pointer-valid-p))
(defun cstack-pointer-valid-p (x)
(declare (type (unsigned-byte 32) bits))
(let ((object (make-lisp-obj bits)))
(if (functionp object)
- (or (function-code-header object)
+ (or (fun-code-header object)
:undefined-function)
(let ((lowtag (get-lowtag object)))
(if (= lowtag sb!vm:other-pointer-type)
(sb!c::compiled-debug-fun-start-pc
(compiled-debug-fun-compiler-debug-fun debug-fun))))
(do ((entry (%code-entry-points component)
- (%function-next entry)))
+ (%simple-fun-next entry)))
((null entry) nil)
(when (= start-pc
(sb!c::compiled-debug-fun-start-pc
(declare (type function fun))
(ecase (get-type fun)
(#.sb!vm:closure-header-type
- (fun-debug-fun (%closure-function fun)))
+ (fun-debug-fun (%closure-fun fun)))
(#.sb!vm:funcallable-instance-header-type
- (fun-debug-fun (funcallable-instance-function fun)))
- ((#.sb!vm:function-header-type #.sb!vm:closure-function-header-type)
- (let* ((name (%function-name fun))
- (component (function-code-header fun))
+ (fun-debug-fun (funcallable-instance-fun fun)))
+ ((#.sb!vm:simple-fun-header-type
+ #.sb!vm:closure-fun-header-type)
+ (let* ((name (%simple-fun-name fun))
+ (component (fun-code-header fun))
(res (find-if
(lambda (x)
(and (sb!c::compiled-debug-fun-p x)
;; works for all named functions anyway.
;; -- WHN 20000120
(debug-fun-from-pc component
- (* (- (function-word-offset fun)
+ (* (- (fun-word-offset fun)
(get-header-data component))
sb!vm:word-bytes)))))))
;;; the guts.
(defun %describe-function-compiled (x s kind name)
(declare (type stream s))
- ;; FIXME: The lowercaseness of %FUNCTION-ARGLIST results, and the
+ ;; FIXME: The lowercaseness of %SIMPLE-FUN-ARGLIST results, and the
;; non-sentenceness of the "Arguments" label, makes awkward output.
;; Better would be "Its arguments are: ~S" (with uppercase argument
;; names) when arguments are known, and otherwise "There is no
;; information available about its arguments." or "It has no
- ;; arguments." (And why is %FUNCTION-ARGLIST a string instead of a
+ ;; arguments." (And why is %SIMPLE-FUN-ARGLIST a string instead of a
;; list of symbols anyway?)
- (let ((args (%function-arglist x)))
+ (let ((args (%simple-fun-arglist x)))
(format s "~@:_~@(~@[~A ~]arguments:~@:_~)" kind)
(cond ((not args)
(format s " There is no argument information available."))
(pprint-logical-block (s nil)
(pprint-indent :current 2)
(write-string args s)))))
- (let ((name (or name (%function-name x))))
+ (let ((name (or name (%simple-fun-name x))))
(%describe-doc name s 'function kind)
(unless (eq kind :macro)
- (%describe-function-name name s (%fun-type x))))
- (%describe-compiled-from (sb-kernel:function-code-header x) s))
+ (%describe-function-name name s (%simple-fun-type x))))
+ (%describe-compiled-from (sb-kernel:fun-code-header x) s))
;;; Describe a function with the specified kind and name. The latter
;;; arguments provide some information about where the function came
((nil) (format s "~S is a function." x)))
(case (get-type x)
(#.sb-vm:closure-header-type
- (%describe-function-compiled (%closure-function x) s kind name)
+ (%describe-function-compiled (%closure-fun x) s kind name)
(format s "~@:_Its closure environment is:")
(pprint-logical-block (s nil)
(pprint-indent :current 8)
(dotimes (i (- (get-closure-length x) (1- sb-vm:closure-info-offset)))
(format s "~@:_~S: ~S" i (%closure-index-ref x i)))))
- ((#.sb-vm:function-header-type #.sb-vm:closure-function-header-type)
+ ((#.sb-vm:simple-fun-header-type #.sb-vm:closure-fun-header-type)
(%describe-function-compiled x s kind name))
(#.sb-vm:funcallable-instance-header-type
(typecase x
;;; Return the DYNCOUNT-INFO for FUNCTION.
(defun find-info-for (function)
(declare (type function function))
- (let* ((function (%primitive closure-function function))
- (component (sb!di::function-code-header function)))
+ (let* ((function (%primitive closure-fun function))
+ (component (sb!di::fun-code-header function)))
(do ((end (get-header-data component))
(i sb!vm:code-constants-offset (1+ i)))
((= end i))
might have been enclosed in some non-null lexical environment, and
NAME is some name (for debugging only) or NIL if there is no name."
(declare (type function fun))
- (let* ((fun (%function-self fun))
- (name (%function-name fun))
- (code (sb!di::function-code-header fun))
+ (let* ((fun (%simple-fun-self fun))
+ (name (%simple-fun-name fun))
+ (code (sb!di::fun-code-header fun))
(info (sb!kernel:%code-debug-info code)))
(if info
(let ((source (first (sb!c::compiled-debug-info-source info))))
(declare (type fdefn fdefn))
(fdefn-name fdefn))
-(defun fdefn-function (fdefn)
+(defun fdefn-fun (fdefn)
(declare (type fdefn fdefn)
(values (or function null)))
- (fdefn-function fdefn))
+ (fdefn-fun fdefn))
-(defun (setf fdefn-function) (fun fdefn)
+(defun (setf fdefn-fun) (fun fdefn)
(declare (type function fun)
(type fdefn fdefn)
(values function))
- (setf (fdefn-function fdefn) fun))
+ (setf (fdefn-fun fdefn) fun))
(defun fdefn-makunbound (fdefn)
(declare (type fdefn fdefn))
;;; 5. Require that the function calling convention be stereotyped
;;; along the lines of
;;; mov %ebx, local_immediate_3 ; Point to symbol.
-;;; mov %eax, symbol_function_offset(%eax) ; Point to function.
-;;; call *function_code_pointer(%eax) ; Go.
+;;; mov %eax, symbol_fun_offset(%eax) ; Point to function.
+;;; call *function_code_pointer(%eax) ; Go.
;;; That way, it's guaranteed that on entry to a function, %EBX points
;;; back to the symbol which was used to indirect into the function,
;;; so the undefined function handler can base its complaint on that.
"Return the definition for name, including any encapsulations. Settable
with SETF."
(let ((fdefn (fdefinition-object name nil)))
- (or (and fdefn (fdefn-function fdefn))
+ (or (and fdefn (fdefn-fun fdefn))
(error 'undefined-function :name name))))
(defun %coerce-callable-to-function (callable)
(%coerce-name-to-function name))
(defun (setf raw-definition) (function name)
(let ((fdefn (fdefinition-object name t)))
- (setf (fdefn-function fdefn) function)))
+ (setf (fdefn-fun fdefn) function)))
;;; FIXME: There seems to be no good reason to have both
;;; %COERCE-NAME-TO-FUNCTION and RAW-DEFINITION names for the same
;;; encapsulations of the same name.
(defun encapsulate (name type body)
(let ((fdefn (fdefinition-object name nil)))
- (unless (and fdefn (fdefn-function fdefn))
+ (unless (and fdefn (fdefn-fun fdefn))
(error 'undefined-function :name name))
;; We must bind and close over INFO. Consider the case where we
;; encapsulate (the second) an encapsulated (the first)
;; clobber the appropriate INFO structure to allow
;; basic-definition to be bound to the next definition instead of
;; an encapsulation that no longer exists.
- (let ((info (make-encapsulation-info type (fdefn-function fdefn))))
- (setf (fdefn-function fdefn)
+ (let ((info (make-encapsulation-info type (fdefn-fun fdefn))))
+ (setf (fdefn-fun fdefn)
(lambda (&rest argument-list)
(declare (special argument-list))
(let ((basic-definition (encapsulation-info-definition info)))
#!+sb-doc
"Removes NAME's most recent encapsulation of the specified TYPE."
(let* ((fdefn (fdefinition-object name nil))
- (encap-info (encapsulation-info (fdefn-function fdefn))))
+ (encap-info (encapsulation-info (fdefn-fun fdefn))))
(declare (type (or encapsulation-info null) encap-info))
(cond ((not encap-info)
;; It disappeared on us, so don't worry about it.
)
((eq (encapsulation-info-type encap-info) type)
;; It's the first one, so change the fdefn object.
- (setf (fdefn-function fdefn)
+ (setf (fdefn-fun fdefn)
(encapsulation-info-definition encap-info)))
(t
;; It must be an interior one, so find it.
;;; Does NAME have an encapsulation of the given TYPE?
(defun encapsulated-p (name type)
(let ((fdefn (fdefinition-object name nil)))
- (do ((encap-info (encapsulation-info (fdefn-function fdefn))
+ (do ((encap-info (encapsulation-info (fdefn-fun fdefn))
(encapsulation-info
(encapsulation-info-definition encap-info))))
((null encap-info) nil)
(dolist (f *setf-fdefinition-hook*)
(funcall f name new-value)))
- (let ((encap-info (encapsulation-info (fdefn-function fdefn))))
+ (let ((encap-info (encapsulation-info (fdefn-fun fdefn))))
(cond (encap-info
(loop
(let ((more-info
(setf (encapsulation-info-definition encap-info)
new-value))))))
(t
- (setf (fdefn-function fdefn) new-value))))))
+ (setf (fdefn-fun fdefn) new-value))))))
\f
;;;; FBOUNDP and FMAKUNBOUND
#!+sb-doc
"Return true if name has a global function definition."
(let ((fdefn (fdefinition-object name nil)))
- (and fdefn (fdefn-function fdefn) t)))
+ (and fdefn (fdefn-fun fdefn) t)))
(defun fmakunbound (name)
#!+sb-doc
(error "internal error: unaligned function object, offset = #X~X"
offset))
(let ((fun (%primitive sb!c:compute-function code-object offset)))
- (setf (%function-self fun) fun)
- (setf (%function-next fun) (%code-entry-points code-object))
+ (setf (%simple-fun-self fun) fun)
+ (setf (%simple-fun-next fun) (%code-entry-points code-object))
(setf (%code-entry-points code-object) fun)
- (setf (%function-name fun) name)
- (setf (%function-arglist fun) arglist)
- (setf (%fun-type fun) type)
+ (setf (%simple-fun-name fun) name)
+ (setf (%simple-fun-arglist fun) arglist)
+ (setf (%simple-fun-type fun) type)
;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL.
#+nil (when *load-print*
(load-fresh-line)
(defmethod inspected-parts ((object function))
(let* ((type (sb-kernel:get-type object))
(object (if (= type sb-vm:closure-header-type)
- (sb-kernel:%closure-function object)
+ (sb-kernel:%closure-fun object)
object)))
(values (format nil "FUNCTION ~S.~@[~%Argument List: ~A~]." object
- (sb-kernel:%function-arglist object)
+ (sb-kernel:%simple-fun-arglist object)
;; Defined-from stuff used to be here. Someone took
;; it out. FIXME: We should make it easy to get
;; to DESCRIBE from the inspector.
(setf (function-subtype function) type))
;;; Extract the arglist from the function header FUNC.
-(defun %function-arglist (func)
- (%function-arglist func))
+(defun %simple-fun-arglist (func)
+ (%simple-fun-arglist func))
;;; Extract the name from the function header FUNC.
-(defun %function-name (func)
- (%function-name func))
+(defun %simple-fun-name (func)
+ (%simple-fun-name func))
;;; Extract the type from the function header FUNC.
-(defun %fun-type (func)
- (%fun-type func))
+(defun %simple-fun-type (func)
+ (%simple-fun-type func))
+
+(defun %simple-fun-next (simple-fun)
+ (%simple-fun-next simple-fun))
+
+(defun %simple-fun-self (simple-fun)
+ (%simple-fun-self simple-fun))
;;; Extract the function from CLOSURE.
-(defun %closure-function (closure)
- (%closure-function closure))
+(defun %closure-fun (closure)
+ (%closure-fun closure))
;;; Return the length of VECTOR. There is no reason to use this in
;;; ordinary code, 'cause length (the vector foo)) is the same.
(t (values (fdefinition x) t)))
(case (sb-kernel:get-type res)
(#.sb-vm:closure-header-type
- (values (sb-kernel:%closure-function res)
+ (values (sb-kernel:%closure-fun res)
named-p
:compiled-closure))
(#.sb-vm:funcallable-instance-header-type
;; pulled out in a function somewhere.
(name (case (function-subtype object)
(#.sb!vm:closure-header-type "CLOSURE")
- (#.sb!vm:function-header-type (%function-name object))
+ (#.sb!vm:simple-fun-header-type (%simple-fun-name object))
(t 'no-name-available)))
(identified-by-name-p (and (symbolp name)
(fboundp name)
(write-string "unknown pointer object, type=" stream)
(let ((*print-base* 16) (*print-radix* t))
(output-integer type stream))))))
- ((#.sb!vm:function-pointer-type
+ ((#.sb!vm:fun-pointer-type
#.sb!vm:instance-pointer-type
#.sb!vm:list-pointer-type)
(write-string "unknown pointer object, type=" stream))
(setq current (sap+ current size))))
((eql header-type closure-header-type)
(let* ((obj (make-lisp-obj (logior (sap-int current)
- function-pointer-type)))
+ fun-pointer-type)))
(size (round-to-dualword
(* (the fixnum (1+ (get-closure-length obj)))
word-bytes))))
(def-frob %code-code-size)
(def-frob %code-debug-info)
(def-frob %code-entry-points)
- (def-frob %funcallable-instance-function)
+ (def-frob %funcallable-instance-fun)
(def-frob %funcallable-instance-layout)
(def-frob %funcallable-instance-lexenv)
- (def-frob %function-next)
- (def-frob %function-self)
- (def-frob %set-funcallable-instance-function (fin new-val)))
+ (def-frob %set-funcallable-instance-fun (fin new-val)))
(defun %set-funcallable-instance-info (fin i new-value)
(%set-funcallable-instance-info fin i new-value))
-(defun funcallable-instance-function (fin)
+(defun funcallable-instance-fun (fin)
(%funcallable-instance-lexenv fin))
;;; The heart of the magic of funcallable instances ("FINs"). The
;;; think of another example offhand. -- WHN 2001-10-06)
;;;
;;; The only loss is that if someone accesses the
-;;; FUNCALLABLE-INSTANCE-FUNCTION, then won't get a FIN back. This
-;;; probably doesn't matter, since PCL only sets the FIN function. And
-;;; the only reason that interpreted functions are FINs instead of
-;;; bare closures is for debuggability.
-(defun (setf funcallable-instance-function) (new-value fin)
- (setf (%funcallable-instance-function fin)
- (%closure-function new-value))
+;;; FUNCALLABLE-INSTANCE-FUN, then won't get a FIN back. This probably
+;;; doesn't matter, since PCL only sets the FIN function. And the only
+;;; reason that interpreted functions are FINs instead of bare
+;;; closures is for debuggability.
+(defun (setf funcallable-instance-fun) (new-value fin)
+ (setf (%funcallable-instance-fun fin)
+ (%closure-fun new-value))
(setf (%funcallable-instance-lexenv fin)
(if (funcallable-instance-p new-value)
(%funcallable-instance-lexenv new-value)
(let ((name
(case (get-type x)
(#.sb!vm:closure-header-type
- (%function-name (%closure-function x)))
- ((#.sb!vm:function-header-type #.sb!vm:closure-function-header-type)
- (%function-name x))
+ (%simple-fun-name (%closure-fun x)))
+ ((#.sb!vm:simple-fun-header-type #.sb!vm:closure-fun-header-type)
+ (%simple-fun-name x))
(#.sb!vm:funcallable-instance-header-type
- (%function-name
- (funcallable-instance-function x))))))
+ (%simple-fun-name
+ (funcallable-instance-fun x))))))
(when (and name (typep name '(or symbol cons)))
(values (info :function :documentation name)))))
;;; Pull the type specifier out of a function object.
(defun extract-fun-type (fun)
- (specifier-type (%fun-type (%closure-function fun))))
+ (specifier-type (%simple-fun-type (%closure-fun fun))))
\f
;;;; miscellaneous interfaces
(eval-when (:compile-toplevel :load-toplevel :execute)
;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here
;; will have to be tweaked to match. -- WHN 19991021
- (defparameter *type-class-function-slots*
+ (defparameter *type-class-fun-slots*
'((:simple-subtypep . type-class-simple-subtypep)
(:complex-subtypep-arg1 . type-class-complex-subtypep-arg1)
(:complex-subtypep-arg2 . type-class-complex-subtypep-arg2)
(declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
(defun copy-type-class-coldly (x)
;; KLUDGE: If the slots of TYPE-CLASS ever change in a way not
- ;; reflected in *TYPE-CLASS-FUNCTION-SLOTS*, the slots here will
+ ;; reflected in *TYPE-CLASS-FUN-SLOTS*, the slots here will
;; have to be hand-tweaked to match. -- WHN 2001-03-19
(make-type-class :name (type-class-name x)
- . #.(mapcan (lambda (type-class-function-slot)
+ . #.(mapcan (lambda (type-class-fun-slot)
(destructuring-bind (keyword . slot-accessor)
- type-class-function-slot
+ type-class-fun-slot
`(,keyword (,slot-accessor x))))
- *type-class-function-slots*)))
+ *type-class-fun-slots*)))
-(defun class-function-slot-or-lose (name)
- (or (cdr (assoc name *type-class-function-slots*))
+(defun class-fun-slot-or-lose (name)
+ (or (cdr (assoc name *type-class-fun-slots*))
(error "~S is not a defined type class method." name)))
;;; FIXME: This seems to be called at runtime by cold init code.
;;; Make sure that it's not being called at runtime anywhere but
,@body)
(!cold-init-forms
,@(mapcar (lambda (method)
- `(setf (,(class-function-slot-or-lose method)
+ `(setf (,(class-fun-slot-or-lose method)
(type-class-or-lose ',class))
#',name))
(cons method more-methods)))
(complex-arg1 :foo complex-arg1-p))
(declare (type keyword simple complex-arg1 complex-arg2))
`(multiple-value-bind (result-a result-b valid-p)
- (%invoke-type-method ',(class-function-slot-or-lose simple)
- ',(class-function-slot-or-lose
+ (%invoke-type-method ',(class-fun-slot-or-lose simple)
+ ',(class-fun-slot-or-lose
(if complex-arg1-p
complex-arg1
complex-arg2))
- ',(class-function-slot-or-lose complex-arg2)
+ ',(class-fun-slot-or-lose complex-arg2)
,complex-arg1-p
,type1
,type2)
(:generator 37
(with-fixed-allocation (result temp fdefn-type fdefn-size)
(storew name result fdefn-name-slot other-pointer-type)
- (storew null-tn result fdefn-function-slot other-pointer-type)
+ (storew null-tn result fdefn-fun-slot other-pointer-type)
(inst li (make-fixup "undefined_tramp" :foreign) temp)
(storew temp result fdefn-raw-addr-slot other-pointer-type))))
(let ((size (+ length closure-info-offset)))
(inst li (logior (ash (1- size) type-bits) closure-header-type) temp)
(pseudo-atomic (:extra (pad-data-block size))
- (inst bis alloc-tn function-pointer-type result)
- (storew temp result 0 function-pointer-type))
- (storew function result closure-function-slot function-pointer-type))))
+ (inst bis alloc-tn fun-pointer-type result)
+ (storew temp result 0 fun-pointer-type))
+ (storew function result closure-fun-slot fun-pointer-type))))
;;; The compiler likes to be able to directly make value cells.
;;;
(trace-table-entry trace-table-function-prologue)
(emit-label start-lab)
;; Allocate function header.
- (inst function-header-word)
- (dotimes (i (1- function-code-offset))
+ (inst simple-fun-header-word)
+ (dotimes (i (1- simple-fun-code-offset))
(inst lword 0))
;; The start of the actual code.
;; Compute CODE from the address of this entry point.
(do-next-filler)))
#!-gengc
(inst ldl function
- (- (ash closure-function-slot word-shift)
- function-pointer-type) lexenv)
+ (- (ash closure-fun-slot word-shift)
+ fun-pointer-type) lexenv)
#!-gengc
(do-next-filler)
#!-gengc
(inst addq function
- (- (ash function-code-offset word-shift)
- function-pointer-type) entry-point)
+ (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-type) entry-point)
#!+gengc
(inst ldl entry-point
(- (ash closure-entry-point-slot word-shift)
- function-pointer-type) lexenv)
+ fun-pointer-type) lexenv)
#!+gengc
(do-next-filler)))
(loop
\f
-;;;; FDEFINITION (fdefn) objects
+;;;; fdefinition (FDEFN) objects
-(define-vop (fdefn-function cell-ref)
- (:variant fdefn-function-slot other-pointer-type))
+(define-vop (fdefn-fun cell-ref)
+ (:variant fdefn-fun-slot other-pointer-type))
-(define-vop (safe-fdefn-function)
+(define-vop (safe-fdefn-fun)
(:args (object :scs (descriptor-reg) :target obj-temp))
(:results (value :scs (descriptor-reg any-reg)))
(:vop-var vop)
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 10
(move object obj-temp)
- (loadw value obj-temp fdefn-function-slot other-pointer-type)
+ (loadw value obj-temp fdefn-fun-slot other-pointer-type)
(let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
(inst cmpeq value null-tn temp)
(inst bne temp err-lab))))
-(define-vop (set-fdefn-function)
+(define-vop (set-fdefn-fun)
(:policy :fast-safe)
- (:translate (setf fdefn-function))
+ (:translate (setf fdefn-fun))
(:args (function :scs (descriptor-reg) :target result)
(fdefn :scs (descriptor-reg)))
(:temporary (:scs (interior-reg)) lip)
(:results (result :scs (descriptor-reg)))
(:generator 38
(let ((normal-fn (gen-label)))
- (load-type type function (- function-pointer-type))
- (inst xor type function-header-type type)
+ (load-type type function (- fun-pointer-type))
+ (inst xor type simple-fun-header-type type)
(inst addq function
- (- (ash function-code-offset word-shift) function-pointer-type)
+ (- (ash simple-fun-code-offset word-shift) fun-pointer-type)
lip)
(inst beq type normal-fn)
(inst li (make-fixup "closure_tramp" :foreign) lip)
(emit-label normal-fn)
(storew lip fdefn fdefn-raw-addr-slot other-pointer-type)
- (storew function fdefn fdefn-function-slot other-pointer-type)
+ (storew function fdefn fdefn-fun-slot other-pointer-type)
(move function result))))
(:temporary (:scs (non-descriptor-reg)) temp)
(:results (result :scs (descriptor-reg)))
(:generator 38
- (storew null-tn fdefn fdefn-function-slot other-pointer-type)
+ (storew null-tn fdefn fdefn-fun-slot other-pointer-type)
(inst li (make-fixup "undefined_tramp" :foreign) temp)
(move fdefn result)
(storew temp fdefn fdefn-raw-addr-slot other-pointer-type)))
;;;; closure indexing
(define-full-reffer closure-index-ref *
- closure-info-offset function-pointer-type
+ closure-info-offset fun-pointer-type
(descriptor-reg any-reg) * %closure-index-ref)
(define-full-setter set-funcallable-instance-info *
- funcallable-instance-info-offset function-pointer-type
+ funcallable-instance-info-offset fun-pointer-type
(descriptor-reg any-reg null zero) * %set-funcallable-instance-info)
(define-full-reffer funcallable-instance-info *
- funcallable-instance-info-offset function-pointer-type
+ funcallable-instance-info-offset fun-pointer-type
(descriptor-reg any-reg) * %funcallable-instance-info)
(define-vop (funcallable-instance-lexenv cell-ref)
- (:variant funcallable-instance-lexenv-slot function-pointer-type))
+ (:variant funcallable-instance-lexenv-slot fun-pointer-type))
(define-vop (closure-ref slot-ref)
- (:variant closure-info-offset function-pointer-type))
+ (:variant closure-info-offset fun-pointer-type))
(define-vop (closure-init slot-set)
- (:variant closure-info-offset function-pointer-type))
+ (:variant closure-info-offset fun-pointer-type))
\f
;;;; value cell hackery
(:variant sb!vm:other-pointer-type))
(define-vop (code-from-function code-from-mumble)
- (:translate function-code-header)
- (:variant sb!vm:function-pointer-type))
+ (:translate fun-code-header)
+ (:variant sb!vm:fun-pointer-type))
(define-vop (make-lisp-obj)
(:policy :fast-safe)
(:generator 1
(move thing result)))
-(define-vop (function-word-offset)
+(define-vop (fun-word-offset)
(:policy :fast-safe)
- (:translate function-word-offset)
+ (:translate fun-word-offset)
(:args (fun :scs (descriptor-reg)))
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 5
- (loadw res fun 0 function-pointer-type)
+ (loadw res fun 0 fun-pointer-type)
(inst srl res sb!vm:type-bits res)))
(defknown make-number-stack-pointer ((unsigned-byte 32)) system-area-pointer
(ash (+ posn (component-header-length))
(- type-bits word-shift)))))))
-(define-instruction function-header-word (segment)
+(define-instruction simple-fun-header-word (segment)
(:cost 0)
(:emitter
- (emit-header-data segment function-header-type)))
+ (emit-header-data segment simple-fun-header-type)))
(define-instruction lra-header-word (segment)
(:cost 0)
(defmacro lisp-jump (function lip)
"Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
`(progn
- (inst lda ,lip (- (ash sb!vm:function-code-offset sb!vm:word-shift)
- sb!vm:function-pointer-type)
+ (inst lda ,lip (- (ash sb!vm:simple-fun-code-offset sb!vm:word-shift)
+ sb!vm:fun-pointer-type)
,function)
(move ,function code-tn)
(inst jsr zero-tn ,lip 1)))
(inst and object lowtag-mask result)
(inst cmpeq result other-pointer-type ndescr)
(inst bne ndescr other-ptr)
- (inst cmpeq result function-pointer-type ndescr)
+ (inst cmpeq result fun-pointer-type ndescr)
(inst bne ndescr function-ptr)
;; Pick off structure and list pointers.
(inst br zero-tn done)
FUNCTION-PTR
- (load-type result object (- function-pointer-type))
+ (load-type result object (- fun-pointer-type))
(inst br zero-tn done)
OTHER-PTR
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
- (load-type result function (- function-pointer-type))))
+ (load-type result function (- fun-pointer-type))))
(define-vop (set-function-subtype)
(:translate (setf function-subtype))
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
- (inst ldl temp (- function-pointer-type) function)
+ (inst ldl temp (- fun-pointer-type) function)
(inst and temp #xff temp)
(inst bis type temp temp)
- (inst stl temp (- function-pointer-type) function)
+ (inst stl temp (- fun-pointer-type) function)
(move type result)))
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
- (loadw res x 0 function-pointer-type)
+ (loadw res x 0 fun-pointer-type)
(inst srl res type-bits res)))
(define-vop (set-header-data)
(inst srl ndescr type-bits ndescr)
(inst sll ndescr word-shift ndescr)
(inst addq ndescr offset ndescr)
- (inst subq ndescr (- other-pointer-type function-pointer-type) ndescr)
+ (inst subq ndescr (- other-pointer-type fun-pointer-type) ndescr)
(inst addq code ndescr func)))
\f
;;;; other random VOPs.
(defparameter *immediate-types*
(list unbound-marker-type base-char-type))
-(defparameter *function-header-types*
+(defparameter *fun-header-types*
(list funcallable-instance-header-type
- function-header-type
- closure-function-header-type
+ simple-fun-header-type
+ closure-fun-header-type
closure-header-type))
(defun canonicalize-headers (headers)
(extended (remove lowtag-limit type-codes :test #'>))
(immediates (intersection extended *immediate-types* :test #'eql))
(headers (set-difference extended *immediate-types* :test #'eql))
- (function-p (if (intersection headers *function-header-types*)
- (if (subsetp headers *function-header-types*)
+ (function-p (if (intersection headers *fun-header-types*)
+ (if (subsetp headers *fun-header-types*)
t
(error "Can't test for mix of function subtypes ~
and normal header types."))
(defun %test-headers (value temp target not-p function-p headers
&optional (drop-through (gen-label)))
- (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
+ (let ((lowtag (if function-p fun-pointer-type other-pointer-type)))
(multiple-value-bind
(when-true when-false)
;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when
even-fixnum-type odd-fixnum-type)
(def-type-vops functionp check-function function
- object-not-function-error function-pointer-type)
+ object-not-function-error fun-pointer-type)
(def-type-vops listp check-list list object-not-list-error
list-pointer-type)
simple-array-type complex-string-type complex-bit-vector-type
complex-vector-type complex-array-type)
-(def-type-vops nil check-function-or-symbol nil
- object-not-function-or-symbol-error
- function-pointer-type symbol-header-type)
-
(def-type-vops stringp check-string nil object-not-string-error
simple-string-type complex-string-type)
;; defined in the first DEFENUM. -- AL 20000216
(defenum (:suffix -type)
even-fixnum
- ;; Note: CMU CL, and SBCL < 0.pre7.39, had FUNCTION-POINTER-TYPE
- ;; here. We swapped FUNCTION-POINTER-TYPE and
+ ;; Note: CMU CL, and SBCL < 0.pre7.39, had FUN-POINTER-TYPE
+ ;; here. We swapped FUN-POINTER-TYPE and
;; INSTANCE-POINTER-TYPE in sbcl-0.pre7.39 in order to help with a
;; low-level pun in the function call sequence on the PPC port.
;; For more information, see the PPC port code. -- WHN 2001-10-03
other-immediate-0
list-pointer
odd-fixnum
- function-pointer
+ fun-pointer
other-immediate-1
other-pointer))
complex-array
code-header
- function-header
+ simple-fun-header
closure-header
funcallable-instance-header
- closure-function-header
+ closure-fun-header
return-pc-header
value-cell-header
(let ((lowtag (descriptor-lowtag des))
(high (descriptor-high des))
(low (descriptor-low des)))
- (if (or (eql lowtag sb!vm:function-pointer-type)
+ (if (or (eql lowtag sb!vm:fun-pointer-type)
(eql lowtag sb!vm:instance-pointer-type)
(eql lowtag sb!vm:list-pointer-type)
(eql lowtag sb!vm:other-pointer-type))
(1- sb!vm:fdefn-size) sb!vm:fdefn-type))
(write-wordindexed fdefn sb!vm:fdefn-name-slot cold-name)
(unless leave-fn-raw
- (write-wordindexed fdefn sb!vm:fdefn-function-slot
+ (write-wordindexed fdefn sb!vm:fdefn-fun-slot
*nil-descriptor*)
(write-wordindexed fdefn
sb!vm:fdefn-raw-addr-slot
(declare (type descriptor cold-name))
(let ((fdefn (cold-fdefinition-object cold-name t))
(type (logand (descriptor-low (read-memory defn)) sb!vm:type-mask)))
- (write-wordindexed fdefn sb!vm:fdefn-function-slot defn)
+ (write-wordindexed fdefn sb!vm:fdefn-fun-slot defn)
(write-wordindexed fdefn
sb!vm:fdefn-raw-addr-slot
(ecase type
- (#.sb!vm:function-header-type
+ (#.sb!vm:simple-fun-header-type
#!+sparc
defn
#!-sparc
(make-random-descriptor
(+ (logandc2 (descriptor-bits defn)
sb!vm:lowtag-mask)
- (ash sb!vm:function-code-offset
+ (ash sb!vm:simple-fun-code-offset
sb!vm:word-shift))))
(#.sb!vm:closure-header-type
(make-random-descriptor
(offset (calc-offset code-object (read-arg 4)))
(fn (descriptor-beyond code-object
offset
- sb!vm:function-pointer-type))
+ sb!vm:fun-pointer-type))
(next (read-wordindexed code-object sb!vm:code-entry-points-slot)))
(unless (zerop (logand offset sb!vm:lowtag-mask))
;; FIXME: This should probably become a fatal error.
(warn "unaligned function entry: ~S at #X~X" name offset))
(write-wordindexed code-object sb!vm:code-entry-points-slot fn)
(write-memory fn
- (make-other-immediate-descriptor (ash offset
- (- sb!vm:word-shift))
- sb!vm:function-header-type))
+ (make-other-immediate-descriptor
+ (ash offset (- sb!vm:word-shift))
+ sb!vm:simple-fun-header-type))
(write-wordindexed fn
- sb!vm:function-self-slot
+ sb!vm:simple-fun-self-slot
;; KLUDGE: Wiring decisions like this in at
;; this level ("if it's an x86") instead of a
;; higher level of abstraction ("if it has such
;; -- WHN 19990907
(make-random-descriptor
(+ (descriptor-bits fn)
- (- (ash sb!vm:function-code-offset sb!vm:word-shift)
+ (- (ash sb!vm:simple-fun-code-offset
+ sb!vm:word-shift)
;; FIXME: We should mask out the type
;; bits, not assume we know what they
;; are and subtract them out this way.
- sb!vm:function-pointer-type))))
- (write-wordindexed fn sb!vm:function-next-slot next)
- (write-wordindexed fn sb!vm:function-name-slot name)
- (write-wordindexed fn sb!vm:function-arglist-slot arglist)
- (write-wordindexed fn sb!vm:function-type-slot type)
+ sb!vm:fun-pointer-type))))
+ (write-wordindexed fn sb!vm:simple-fun-next-slot next)
+ (write-wordindexed fn sb!vm:simple-fun-name-slot name)
+ (write-wordindexed fn sb!vm:simple-fun-arglist-slot arglist)
+ (write-wordindexed fn sb!vm:simple-fun-type-slot type)
fn))
(define-cold-fop (fop-foreign-fixup)
(undefs nil))
(maphash #'(lambda (name fdefn)
(let ((fun (read-wordindexed fdefn
- sb!vm:fdefn-function-slot)))
+ sb!vm:fdefn-fun-slot)))
(if (= (descriptor-bits fun)
(descriptor-bits *nil-descriptor*))
(push name undefs)
(let* ((cold-name (cold-intern '!cold-init))
(cold-fdefn (cold-fdefinition-object cold-name))
(initial-function (read-wordindexed cold-fdefn
- sb!vm:fdefn-function-slot)))
+ sb!vm:fdefn-fun-slot)))
(format t
"~&/(DESCRIPTOR-BITS INITIAL-FUNCTION)=#X~X~%"
(descriptor-bits initial-function))
:lowtag other-pointer-type
:header fdefn-type)
(name :ref-trans fdefn-name)
- (function :type (or function null) :ref-trans fdefn-function)
+ (fun :type (or function null) :ref-trans fdefn-fun)
(raw-addr :c-type #!-alpha "char *" #!+alpha "u32"))
-(define-primitive-object (function :type function
- :lowtag function-pointer-type
- :header function-header-type)
- #!-x86 (self :ref-trans %function-self
- :set-trans (setf %function-self))
+;;; a simple function (as opposed to hairier things like closures
+;;; which are also subtypes of Common Lisp's FUNCTION type)
+(define-primitive-object (simple-fun :type function
+ :lowtag fun-pointer-type
+ :header simple-fun-header-type)
+ #!-x86 (self :ref-trans %simple-fun-self
+ :set-trans (setf %simple-fun-self))
#!+x86 (self
;; KLUDGE: There's no :SET-KNOWN, :SET-TRANS, :REF-KNOWN, or
;; :REF-TRANS here in this case. Instead, there's separate
)
(next :type (or function null)
:ref-known (flushable)
- :ref-trans %function-next
+ :ref-trans %simple-fun-next
:set-known (unsafe)
- :set-trans (setf %function-next))
+ :set-trans (setf %simple-fun-next))
(name :ref-known (flushable)
- :ref-trans %function-name
+ :ref-trans %simple-fun-name
:set-known (unsafe)
- :set-trans (setf %function-name))
+ :set-trans (setf %simple-fun-name))
(arglist :ref-known (flushable)
- :ref-trans %function-arglist
+ :ref-trans %simple-fun-arglist
:set-known (unsafe)
- :set-trans (setf %function-arglist))
+ :set-trans (setf %simple-fun-arglist))
(type :ref-known (flushable)
- :ref-trans %fun-type
+ :ref-trans %simple-fun-type
:set-known (unsafe)
- :set-trans (setf %fun-type))
+ :set-trans (setf %simple-fun-type))
(code :rest-p t :c-type "unsigned char"))
(define-primitive-object (return-pc :lowtag other-pointer-type :header t)
(return-point :c-type "unsigned char" :rest-p t))
-(define-primitive-object (closure :lowtag function-pointer-type
+(define-primitive-object (closure :lowtag fun-pointer-type
:header closure-header-type)
- (function :init :arg :ref-trans %closure-function)
+ (fun :init :arg :ref-trans %closure-fun)
(info :rest-p t))
(define-primitive-object (funcallable-instance
- :lowtag function-pointer-type
+ :lowtag fun-pointer-type
:header funcallable-instance-header-type
:alloc-trans %make-funcallable-instance)
#!-x86
- (function
- :ref-known (flushable) :ref-trans %funcallable-instance-function
- :set-known (unsafe) :set-trans (setf %funcallable-instance-function))
+ (fun
+ :ref-known (flushable) :ref-trans %funcallable-instance-fun
+ :set-known (unsafe) :set-trans (setf %funcallable-instance-fun))
#!+x86
- (function
- :ref-known (flushable) :ref-trans %funcallable-instance-function
+ (fun
+ :ref-known (flushable) :ref-trans %funcallable-instance-fun
;; KLUDGE: There's no :SET-KNOWN or :SET-TRANS in this case.
;; Instead, later in compiler/x86/system.lisp there's a separate
- ;; DEFKNOWN for (SETF %FUNCALLABLE-INSTANCE-FUNCTION), and a weird
- ;; unexplained DEFTRANSFORM from (SETF %FUNCTION-INSTANCE-FUNCTION)
- ;; into (SETF %FUNCTION-SELF). The #!+X86 wrapped around this case
+ ;; DEFKNOWN for (SETF %FUNCALLABLE-INSTANCE-FUN), and a weird
+ ;; unexplained DEFTRANSFORM from (SETF %SIMPLE-FUN-INSTANCE-FUN)
+ ;; into (SETF %SIMPLE-FUN-SELF). The #!+X86 wrapped around this case
;; is a literal translation of the old CMU CL implementation into
;; the new world of sbcl-0.6.12.63, where multiple DEFKNOWNs for
;; the same operator cause an error (instead of silently deleting
(unless (zerop (logand offset sb!vm:lowtag-mask))
(error "Unaligned function object, offset = #X~X." offset))
(let ((res (%primitive compute-function code-obj offset)))
- (setf (%function-self res) res)
- (setf (%function-next res) (%code-entry-points code-obj))
+ (setf (%simple-fun-self res) res)
+ (setf (%simple-fun-next res) (%code-entry-points code-obj))
(setf (%code-entry-points code-obj) res)
- (setf (%function-name res) (entry-info-name entry))
- (setf (%function-arglist res) (entry-info-arguments entry))
- (setf (%fun-type res) (entry-info-type entry))
+ (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))
(note-function entry res object))))
(defknown stack-ref (system-area-pointer index) t (flushable))
(defknown %set-stack-ref (system-area-pointer index t) t (unsafe))
(defknown lra-code-header (t) t (movable flushable))
-(defknown function-code-header (t) t (movable flushable))
+(defknown fun-code-header (t) t (movable flushable))
(defknown make-lisp-obj ((unsigned-byte 32)) t (movable flushable))
(defknown get-lisp-obj-address (t) (unsigned-byte 32) (movable flushable))
-(defknown function-word-offset (function) index (movable flushable))
+(defknown fun-word-offset (function) index (movable flushable))
\f
;;;; 32-bit logical operations
(defknown make-fdefn (t) fdefn (flushable movable))
(defknown fdefn-p (t) boolean (movable foldable flushable))
(defknown fdefn-name (fdefn) t (foldable flushable))
-(defknown fdefn-function (fdefn) (or function null) (flushable))
-(defknown (setf fdefn-function) (function fdefn) t (unsafe))
+(defknown fdefn-fun (fdefn) (or function null) (flushable))
+(defknown (setf fdefn-fun) (function fdefn) t (unsafe))
(defknown fdefn-makunbound (fdefn) t ())
-(defknown %function-self (function) function
+(defknown %simple-fun-self (function) function
(flushable))
-(defknown (setf %function-self) (function function) function
+(defknown (setf %simple-fun-self) (function function) function
(unsafe))
-(defknown %closure-function (function) function
+(defknown %closure-fun (function) function
(flushable))
(defknown %closure-index-ref (function index) t
(incf offset length)))
(unless variable-length
(let ((size (symbolicate name "-SIZE")))
- (constants `(defconstant ,size ,offset
- ,(format nil
- "Number of slots used by each ~S~
- ~@[~* including the header~]."
- name header)))
+ (constants `(defconstant ,size ,offset))
(exports size)))
(when alloc-trans
(forms `(def-alloc ,alloc-trans ,offset ,variable-length ,header
\f
;;;; hacking function names
-;;; This is like LAMBDA, except the result is tweaked so that
-;;; %FUNCTION-NAME can extract a name. (Also possibly the name could
-;;; also be used at compile time to emit more-informative name-based
-;;; compiler diagnostic messages as well.)
+;;; This is like LAMBDA, except the result is tweaked so that FUN-NAME
+;;; can extract a name. (Also possibly the name could also be used at
+;;; compile time to emit more-informative name-based compiler
+;;; diagnostic messages as well.)
(defmacro-mundanely named-lambda (name args &body body)
;; FIXME: For now, in this stub version, we just discard the name. A
(:global-function
(let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
(if unsafe
- (vop fdefn-function node block fdefn-tn res)
- (vop safe-fdefn-function node block fdefn-tn res))))))))
+ (vop fdefn-fun node block fdefn-tn res)
+ (vop safe-fdefn-fun node block fdefn-tn res))))))))
(move-continuation-result node block locs cont))
(values))
(defun fun-self (fun)
(declare (type compiled-function fun))
- (sb!kernel:%function-self fun))
+ (sb!kernel:%simple-fun-self fun))
(defun fun-code (fun)
(declare (type compiled-function fun))
- (sb!kernel:function-code-header (fun-self fun)))
+ (sb!kernel:fun-code-header (fun-self fun)))
(defun fun-next (fun)
(declare (type compiled-function fun))
- (sb!kernel:%function-next fun))
+ (sb!kernel:%simple-fun-next fun))
(defun fun-address (function)
(declare (type compiled-function function))
- (- (sb!kernel:get-lisp-obj-address function) sb!vm:function-pointer-type))
+ (- (sb!kernel:get-lisp-obj-address function) sb!vm:fun-pointer-type))
;;; the offset of FUNCTION from the start of its code-component's
;;; instruction area
(segment-offs-to-code-offs (dstate-cur-offs dstate) seg)))
(name
(sb!kernel:code-header-ref code
- (+ woffs sb!vm:function-name-slot)))
+ (+ woffs
+ sb!vm:simple-fun-name-slot)))
(args
(sb!kernel:code-header-ref code
- (+ woffs sb!vm:function-arglist-slot)))
+ (+ woffs
+ sb!vm:simple-fun-arglist-slot)))
(type
(sb!kernel:code-header-ref code
- (+ woffs sb!vm:function-type-slot))))
+ (+ woffs
+ sb!vm:simple-fun-type-slot))))
(format stream ".~A ~S~:A" 'entry name args)
(note (lambda (stream)
(format stream "~:S" type)) ; use format to print NIL as ()
dstate)))
(incf (dstate-next-offs dstate)
- (words-to-bytes sb!vm:function-code-offset)))
+ (words-to-bytes sb!vm:simple-fun-code-offset)))
\f
(defun alignment-hook (chunk stream dstate)
(declare (type dchunk chunk)
(defun print-fun-headers (function)
(declare (type compiled-function function))
(let* ((self (fun-self function))
- (code (sb!kernel:function-code-header self)))
+ (code (sb!kernel:fun-code-header self)))
(format t "Code-header ~S: size: ~S, trace-table-offset: ~S~%"
code
(sb!kernel:code-header-ref code
fun
fun-offset
(sb!kernel:code-header-ref
- code (+ fun-offset sb!vm:function-name-slot))
+ code (+ fun-offset sb!vm:simple-fun-name-slot))
(sb!kernel:code-header-ref
- code (+ fun-offset sb!vm:function-arglist-slot))
+ code (+ fun-offset sb!vm:simple-fun-arglist-slot))
(sb!kernel:code-header-ref
- code (+ fun-offset sb!vm:function-type-slot)))))))
+ code (+ fun-offset sb!vm:simple-fun-type-slot)))))))
\f
;;; getting at the source code...
(declare (type compiled-function function))
(let* ((code (fun-code function))
(fun-map (code-fun-map code))
- (fname (sb!kernel:%function-name function))
+ (fname (sb!kernel:%simple-fun-name function))
(sfcache (make-source-form-cache)))
(let ((first-block-seen-p nil)
(nil-block-seen-p nil)
(:generator 37
(with-fixed-allocation (result fdefn-type fdefn-size node)
(storew name result fdefn-name-slot other-pointer-type)
- (storew nil-value result fdefn-function-slot other-pointer-type)
+ (storew nil-value result fdefn-fun-slot other-pointer-type)
(storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
result fdefn-raw-addr-slot other-pointer-type))))
(let ((size (+ length closure-info-offset)))
(allocation result (pad-data-block size) node)
(inst lea result
- (make-ea :byte :base result :disp function-pointer-type))
+ (make-ea :byte :base result :disp fun-pointer-type))
(storew (logior (ash (1- size) type-bits) closure-header-type)
- result 0 function-pointer-type))
- (loadw temp function closure-function-slot function-pointer-type)
- (storew temp result closure-function-slot function-pointer-type))))
+ result 0 fun-pointer-type))
+ (loadw temp function closure-fun-slot fun-pointer-type)
+ (storew temp result closure-fun-slot fun-pointer-type))))
;;; The compiler likes to be able to directly make value cells.
(define-vop (make-value-cell)
(trace-table-entry trace-table-function-prologue)
(emit-label start-lab)
;; Skip space for the function header.
- (inst function-header-word)
- (dotimes (i (1- sb!vm:function-code-offset))
+ (inst simple-fun-header-word)
+ (dotimes (i (1- sb!vm:simple-fun-code-offset))
(inst dword 0))
;; The start of the actual code.
:disp ,(if named
'(- (* fdefn-raw-addr-slot word-bytes)
other-pointer-type)
- '(- (* closure-function-slot word-bytes)
- function-pointer-type))))
+ '(- (* closure-fun-slot word-bytes)
+ fun-pointer-type))))
,@(ecase return
(:fixed
'((default-unknown-values vop values nvals)))
(:results (res :scs (any-reg)))
(:result-types positive-fixnum)
(:generator 2
- ;; The symbol-hash slot of NIL holds NIL because it is also the cdr slot,
- ;; so we have to strip off the two low bits to make sure it is a fixnum.
+ ;; The symbol-hash slot of NIL holds NIL because it is also the
+ ;; cdr slot, so we have to strip off the two low bits to make sure
+ ;; it is a fixnum.
;;
;; FIXME: Is this still true? It seems to me from my reading of
;; the DEFINE-PRIMITIVE-OBJECT in objdef.lisp that the symbol-hash
(loadw res symbol symbol-hash-slot other-pointer-type)
(inst and res (lognot #b11))))
\f
-;;;; fdefinition (fdefn) objects
+;;;; fdefinition (FDEFN) objects
-(define-vop (fdefn-function cell-ref) ; /pfw - alpha
- (:variant fdefn-function-slot other-pointer-type))
+(define-vop (fdefn-fun cell-ref) ; /pfw - alpha
+ (:variant fdefn-fun-slot other-pointer-type))
-(define-vop (safe-fdefn-function)
+(define-vop (safe-fdefn-fun)
(:args (object :scs (descriptor-reg) :to (:result 1)))
(:results (value :scs (descriptor-reg any-reg)))
(:vop-var vop)
(:save-p :compute-only)
(:generator 10
- (loadw value object fdefn-function-slot other-pointer-type)
+ (loadw value object fdefn-fun-slot other-pointer-type)
(inst cmp value nil-value)
;; FIXME: UNDEFINED-SYMBOL-ERROR seems to actually be for symbols with no
;; function value, not, as the name might suggest, symbols with no ordinary
(let ((err-lab (generate-error-code vop undefined-symbol-error object)))
(inst jmp :e err-lab))))
-(define-vop (set-fdefn-function)
+(define-vop (set-fdefn-fun)
(:policy :fast-safe)
- (:translate (setf fdefn-function))
+ (:translate (setf fdefn-fun))
(:args (function :scs (descriptor-reg) :target result)
(fdefn :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) raw)
(:temporary (:sc byte-reg) type)
(:results (result :scs (descriptor-reg)))
(:generator 38
- (load-type type function (- function-pointer-type))
+ (load-type type function (- fun-pointer-type))
(inst lea raw
(make-ea :byte :base function
- :disp (- (* function-code-offset word-bytes)
- function-pointer-type)))
- (inst cmp type function-header-type)
+ :disp (- (* simple-fun-code-offset word-bytes)
+ fun-pointer-type)))
+ (inst cmp type simple-fun-header-type)
(inst jmp :e normal-fn)
(inst lea raw (make-fixup (extern-alien-name "closure_tramp") :foreign))
NORMAL-FN
- (storew function fdefn fdefn-function-slot other-pointer-type)
+ (storew function fdefn fdefn-fun-slot other-pointer-type)
(storew raw fdefn fdefn-raw-addr-slot other-pointer-type)
(move result function)))
(:args (fdefn :scs (descriptor-reg) :target result))
(:results (result :scs (descriptor-reg)))
(:generator 38
- (storew nil-value fdefn fdefn-function-slot other-pointer-type)
+ (storew nil-value fdefn fdefn-fun-slot other-pointer-type)
(storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
fdefn fdefn-raw-addr-slot other-pointer-type)
(move result fdefn)))
;;;; closure indexing
(define-full-reffer closure-index-ref *
- closure-info-offset function-pointer-type
+ closure-info-offset fun-pointer-type
(any-reg descriptor-reg) * %closure-index-ref)
(define-full-setter set-funcallable-instance-info *
- funcallable-instance-info-offset function-pointer-type
+ funcallable-instance-info-offset fun-pointer-type
(any-reg descriptor-reg) * %set-funcallable-instance-info)
(define-full-reffer funcallable-instance-info *
- funcallable-instance-info-offset function-pointer-type
+ funcallable-instance-info-offset fun-pointer-type
(descriptor-reg any-reg) * %funcallable-instance-info)
(define-vop (funcallable-instance-lexenv cell-ref)
- (:variant funcallable-instance-lexenv-slot function-pointer-type))
+ (:variant funcallable-instance-lexenv-slot fun-pointer-type))
(define-vop (closure-ref slot-ref)
- (:variant closure-info-offset function-pointer-type))
+ (:variant closure-info-offset fun-pointer-type))
(define-vop (closure-init slot-set)
- (:variant closure-info-offset function-pointer-type))
+ (:variant closure-info-offset fun-pointer-type))
\f
;;;; value cell hackery
(:variant other-pointer-type))
(define-vop (code-from-function code-from-mumble)
- (:translate sb!di::function-code-header)
- (:variant function-pointer-type))
+ (:translate sb!di::fun-code-header)
+ (:variant fun-pointer-type))
(define-vop (make-lisp-obj)
(:policy :fast-safe)
(move result thing)))
-(define-vop (function-word-offset)
+(define-vop (fun-word-offset)
(:policy :fast-safe)
- (:translate sb!di::function-word-offset)
+ (:translate sb!di::fun-word-offset)
(:args (fun :scs (descriptor-reg)))
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 5
- (loadw res fun 0 function-pointer-type)
+ (loadw res fun 0 fun-pointer-type)
(inst shr res type-bits)))
(- type-bits
word-shift)))))))
-(define-instruction function-header-word (segment)
+(define-instruction simple-fun-header-word (segment)
(:emitter
- (emit-header-data segment function-header-type)))
+ (emit-header-data segment simple-fun-header-type)))
(define-instruction lra-header-word (segment)
(:emitter
(inst and al-tn lowtag-mask)
(inst cmp al-tn other-pointer-type)
(inst jmp :e other-ptr)
- (inst cmp al-tn function-pointer-type)
+ (inst cmp al-tn fun-pointer-type)
(inst jmp :e function-ptr)
- ;; pick off structures and list pointers
+ ;; Pick off structures and list pointers.
(inst test al-tn 1)
(inst jmp :ne done)
- ;; pick off fixnums
+ ;; Pick off fixnums.
(inst and al-tn 3)
(inst jmp :e done)
(inst jmp done)
FUNCTION-PTR
- (load-type al-tn object (- sb!vm:function-pointer-type))
+ (load-type al-tn object (- sb!vm:fun-pointer-type))
(inst jmp done)
OTHER-PTR
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
- (load-type temp function (- sb!vm:function-pointer-type))
+ (load-type temp function (- sb!vm:fun-pointer-type))
(inst movzx result temp)))
(define-vop (set-function-subtype)
(:generator 6
(move eax type)
(inst mov
- (make-ea :byte :base function :disp (- function-pointer-type))
+ (make-ea :byte :base function :disp (- fun-pointer-type))
al-tn)
(move result eax)))
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
- (loadw res x 0 function-pointer-type)
+ (loadw res x 0 fun-pointer-type)
(inst shr res type-bits)))
(define-vop (set-header-data)
(inst shr func type-bits)
(inst lea func
(make-ea :byte :base offset :index func :scale 4
- :disp (- function-pointer-type other-pointer-type)))
+ :disp (- fun-pointer-type other-pointer-type)))
(inst add func code)))
-(define-vop (%function-self)
+(define-vop (%simple-fun-self)
(:policy :fast-safe)
- (:translate %function-self)
+ (:translate %simple-fun-self)
(:args (function :scs (descriptor-reg)))
(:results (result :scs (descriptor-reg)))
(:generator 3
- (loadw result function function-self-slot function-pointer-type)
+ (loadw result function simple-fun-self-slot fun-pointer-type)
(inst lea result
(make-ea :byte :base result
- :disp (- function-pointer-type
- (* function-code-offset word-bytes))))))
+ :disp (- fun-pointer-type
+ (* simple-fun-code-offset word-bytes))))))
;;; The closure function slot is a pointer to raw code on X86 instead
;;; of a pointer to the code function object itself. This VOP is used
;;; to reference the function object given the closure object.
-(def-source-transform %closure-function (closure)
- `(%function-self ,closure))
+(def-source-transform %closure-fun (closure)
+ `(%simple-fun-self ,closure))
-(def-source-transform %funcallable-instance-function (fin)
- `(%function-self ,fin))
+(def-source-transform %funcallable-instance-fun (fin)
+ `(%simple-fun-self ,fin))
-(define-vop (%set-function-self)
+(define-vop (%set-fun-self)
(:policy :fast-safe)
- (:translate (setf %function-self))
+ (:translate (setf %simple-fun-self))
(:args (new-self :scs (descriptor-reg) :target result :to :result)
(function :scs (descriptor-reg) :to :result))
(:temporary (:sc any-reg :from (:argument 0) :to :result) temp)
(:generator 3
(inst lea temp
(make-ea :byte :base new-self
- :disp (- (ash function-code-offset word-shift)
- function-pointer-type)))
- (storew temp function function-self-slot function-pointer-type)
+ :disp (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-type)))
+ (storew temp function simple-fun-self-slot fun-pointer-type)
(move result new-self)))
;;; KLUDGE: This seems to be some kind of weird override of the way
;;; accessor. It's inherited from CMU CL, and it works, and naively
;;; deleting it seemed to cause problems, but it's not obvious why
;;; it's done this way. Any ideas? -- WHN 2001-08-02
-(defknown ((setf %funcallable-instance-function)) (function function) function
+(defknown ((setf %funcallable-instance-fun)) (function function) function
(unsafe))
;;; CMU CL comment:
;;; We would have really liked to use a source-transform for this, but
;;; they don't work with SETF functions.
;;; FIXME: Can't we just use DEFSETF or something?
-(deftransform (setf %funcallable-instance-function) ((value fin))
- '(setf (%function-self fin) value))
+(deftransform (setf %funcallable-instance-fun) ((value fin))
+ '(setf (%simple-fun-self fin) value))
\f
;;;; other miscellaneous VOPs
(defparameter *immediate-types*
(list unbound-marker-type base-char-type))
-(defparameter *function-header-types*
+(defparameter *fun-header-types*
(list funcallable-instance-header-type
- function-header-type
- closure-function-header-type
+ simple-fun-header-type
+ closure-fun-header-type
closure-header-type))
(defun canonicalize-headers (headers)
(extended (remove lowtag-limit type-codes :test #'>))
(immediates (intersection extended *immediate-types* :test #'eql))
(headers (set-difference extended *immediate-types* :test #'eql))
- (function-p (if (intersection headers *function-header-types*)
- (if (subsetp headers *function-header-types*)
+ (function-p (if (intersection headers *fun-header-types*)
+ (if (subsetp headers *fun-header-types*)
t
(error "can't test for mix of function subtypes ~
and normal header types"))
(defun %test-headers (value target not-p function-p headers
&optional (drop-through (gen-label)) al-loaded)
- (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
+ (let ((lowtag (if function-p fun-pointer-type other-pointer-type)))
(multiple-value-bind (equal less-or-equal when-true when-false)
;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
#+nil
(defun %test-headers (value target not-p function-p headers
&optional (drop-through (gen-label)) al-loaded)
- (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
+ (let ((lowtag (if function-p fun-pointer-type other-pointer-type)))
(multiple-value-bind (equal less-or-equal when-true when-false)
;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
even-fixnum-type odd-fixnum-type)
(def-type-vops functionp check-function function
- object-not-function-error function-pointer-type)
+ object-not-function-error fun-pointer-type)
(def-type-vops listp check-list list object-not-list-error
list-pointer-type)
simple-array-type complex-string-type complex-bit-vector-type
complex-vector-type complex-array-type)
-(def-type-vops nil check-function-or-symbol nil
- object-not-function-or-symbol-error
- function-pointer-type symbol-header-type)
-
(def-type-vops stringp check-string nil object-not-string-error
simple-string-type complex-string-type)
(defun make-early-gf (spec &optional lambda-list lambda-list-p function)
(let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
- (set-funcallable-instance-function
+ (set-funcallable-instance-fun
fin
(or function
(if (eq spec 'print-object)
(defun allocate-funcallable-instance (wrapper &optional
(slots-init nil slots-init-p))
(let ((fin (allocate-funcallable-instance-1)))
- (set-funcallable-instance-function
+ (set-funcallable-instance-fun
fin
#'(sb-kernel:instance-lambda (&rest args)
(declare (ignore args))
:reader constructor-code-generators)) ;could use.
(:metaclass funcallable-standard-class))
-;;; Because the value in the code-type slot should always correspond to the
-;;; funcallable-instance-function of the constructor, this function should
-;;; always be used to set the both at the same time.
+;;; Because the value in the code-type slot should always correspond
+;;; to the FUNCALLABLE-INSTANCE-FUN of the constructor, this function
+;;; should always be used to set them both at the same time.
(defun set-constructor-code (constructor code type)
- (set-funcallable-instance-function constructor code)
+ (set-funcallable-instance-fun constructor code)
(set-function-name constructor (constructor-name constructor))
(setf (constructor-code-type constructor) type))
(doplist (key val) (constructor-code-generators constructor)
(gather1 key)))))
-;;; I am not in a hairy enough mood to make this implementation be metacircular
-;;; enough that it can support a defconstructor for constructor objects.
+;;; I am not in a hairy enough mood to make this implementation be
+;;; metacircular enough that it can support a defconstructor for
+;;; constructor objects.
(defun make-constructor (class name supplied-initarg-names code-generators)
(make-instance 'constructor
:class class
name class)
())))
-;;; This is called to actually load a defconstructor constructor. It must
-;;; install the lazy installer in the function cell of the constructor name,
-;;; and also add this constructor to the list of constructors the class has.
+;;; This is called to actually load a defconstructor constructor. It
+;;; must install the lazy installer in the function cell of the
+;;; constructor name, and also add this constructor to the list of
+;;; constructors the class has.
(defmethod load-constructor-internal
((class slot-class) name initargs generators)
(let ((constructor (make-constructor class name initargs generators))
(apply constructor args)))
'lazy)))
-;;; The interface to keeping the constructors updated.
+;;; the interface to keeping the constructors updated
;;;
-;;; add-method and remove-method (for standard-generic-function and -method),
-;;; promise to call maybe-update-constructors on the generic function and
-;;; the method.
+;;; add-method and remove-method (for standard-generic-function and
+;;; -method), promise to call maybe-update-constructors on the generic
+;;; function and the method.
;;;
-;;; The class update code promises to call update-constructors whenever the
-;;; class is changed. That is, whenever the supers, slots or options change.
-;;; If user defined classes of constructor needs to be updated in more than
-;;; these circumstances, they should use the dependent updating mechanism to
-;;; make sure update-constructors is called.
+;;; The class update code promises to call update-constructors
+;;; whenever the class is changed. That is, whenever the supers, slots
+;;; or options change. If user defined classes of constructor needs to
+;;; be updated in more than these circumstances, they should use the
+;;; dependent updating mechanism to make sure update-constructors is
+;;; called.
;;;
-;;; Bootstrapping concerns force the definitions of maybe-update-constructors
-;;; and update-constructors to be in the file std-class. For clarity, they
-;;; also appear below. Be sure to keep the definition here and there in sync.
+;;; Bootstrapping concerns force the definitions of
+;;; maybe-update-constructors and update-constructors to be in the
+;;; file std-class. For clarity, they also appear below. Be sure to
+;;; keep the definition here and there in sync.
;(defvar *initialization-generic-functions*
; (list #'make-instance
; #'default-initargs
(let ((dfun (if early-p
(or dfun (make-initial-dfun generic-function))
(compute-discriminating-function generic-function))))
- (set-funcallable-instance-function generic-function dfun)
+ (set-funcallable-instance-fun generic-function dfun)
(set-function-name generic-function gf-name)
(when (and ocache (not (eq ocache cache))) (free-cache ocache))
dfun)))
;;; portable to other implementations of Common Lisp, all the
;;; funcallable instance wrapper logic here can go away in favor
;;; of direct calls to native SBCL funcallable instance operations.
-(defun set-funcallable-instance-function (fin new-value)
+(defun set-funcallable-instance-fun (fin new-value)
(declare (type function new-value))
(aver (funcallable-instance-p fin))
- (setf (sb-kernel:funcallable-instance-function fin) new-value))
+ (setf (sb-kernel:funcallable-instance-fun fin) new-value))
(defmacro fsc-instance-p (fin)
`(funcallable-instance-p ,fin))
(defmacro fsc-instance-class (fin)
;; it loses some info of potential hacking value. So,
;; lets not do this...
#+nil
- (let ((header (sb-kernel:%closure-function fcn)))
- (setf (sb-kernel:%function-name header) new-name))
+ (let ((header (sb-kernel:%closure-fun fcn)))
+ (setf (sb-kernel:%simple-fun-name header) new-name))
;; XXX Maybe add better scheme here someday.
fcn)))
;;; argument <gf1>, and returns a result <df1>, that result must not be
;;; passed to apply or funcall directly. Rather, <df1> must be stored as
;;; the funcallable instance function of the same generic function <gf1>
-;;; (using set-funcallable-instance-function). Then the generic function
+;;; (using set-funcallable-instance-fun). Then the generic function
;;; can be passed to funcall or apply.
;;;
;;; An important exception is that methods on this generic function are
;;; #'(lambda (arg)
;;; (cond (<some condition>
;;; <store some info in the generic function>
-;;; (set-funcallable-instance-function
+;;; (set-funcallable-instance-fun
;;; gf
;;; (compute-discriminating-function gf))
;;; (funcall gf arg))
;;; (defmethod compute-discriminating-function ((gf my-generic-function))
;;; #'(lambda (arg)
;;; (cond (<some condition>
-;;; (set-funcallable-instance-function
+;;; (set-funcallable-instance-fun
;;; gf
;;; #'(lambda (a) ..))
;;; (funcall gf arg))
lda reg_LRA,call_into_lisp_LRA_page+type_OtherPointer
/* Indirect the closure */
- ldl reg_CODE,CLOSURE_FUNCTION_OFFSET(reg_LEXENV)
- addl reg_CODE,6*4-type_FunctionPointer,reg_LIP
+ ldl reg_CODE, CLOSURE_FUN_OFFSET(reg_LEXENV)
+ addl reg_CODE,6*4-type_FunPointer, reg_LIP
/* And into lisp we go. */
jsr reg_ZERO,(reg_LIP)
.ent closure_tramp_offset
closure_tramp = /* ### */ 0x150 + call_into_lisp_LRA_page
closure_tramp_offset:
- ldl reg_LEXENV, FDEFN_FUNCTION_OFFSET(reg_FDEFN)
- ldl reg_L0, CLOSURE_FUNCTION_OFFSET(reg_LEXENV)
- addl reg_L0, FUNCTION_CODE_OFFSET, reg_LIP
+ ldl reg_LEXENV, FDEFN_FUN_OFFSET(reg_FDEFN)
+ ldl reg_L0, CLOSURE_FUN_OFFSET(reg_LEXENV)
+ addl reg_L0, FUN_CODE_OFFSET, reg_LIP
jmp reg_ZERO,(reg_LIP)
.end closure_tramp
case type_CodeHeader:
break;
case type_ReturnPcHeader:
- case type_FunctionHeader:
- case type_ClosureFunctionHeader:
+ case type_SimpleFunHeader:
+ case type_ClosureFunHeader:
len = HEADER_LENGTH(header);
if (len == 0)
headerp = NULL;
info->interrupted = 1;
if (LowtagOf(*os_context_register_addr(context, reg_CODE))
- == type_FunctionPointer) {
+ == type_FunPointer) {
/* We tried to call a function, but crapped out before $CODE could
* be fixed up. Probably an undefined function. */
info->frame =
function = ((struct code *)info.code)->entry_points;
#endif
while (function != NIL) {
- struct function *header;
+ struct simple_fun *header;
lispobj name;
- header = (struct function *) native_pointer(function);
+ header = (struct simple_fun *) native_pointer(function);
name = header->name;
if (LowtagOf(name) == type_OtherPointer) {
printf("Don't know about instances yet!\n");
nwords = 1;
break;
- case type_FunctionPointer:
+ case type_FunPointer:
nwords = 1;
break;
case type_OtherPointer:
\f
/* code and code-related objects */
-#define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
+/* FIXME: (1) Shouldn't this be defined in sbcl.h? (2) Shouldn't it
+ * be in the same units as FDEFN_RAW_ADDR_OFFSET? (This is measured
+ * in words, that's measured in bytes. Gotta love CMU CL..) */
+#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunPointer)
-static lispobj trans_function_header(lispobj object);
+static lispobj trans_fun_header(lispobj object);
static lispobj trans_boxed(lispobj object);
static int
-scav_function_pointer(lispobj *where, lispobj object)
+scav_fun_pointer(lispobj *where, lispobj object)
{
lispobj *first_pointer;
lispobj copy;
type = TypeOf(first);
switch (type) {
- case type_FunctionHeader:
- case type_ClosureFunctionHeader:
- copy = trans_function_header(object);
+ case type_SimpleFunHeader:
+ case type_ClosureFunHeader:
+ copy = trans_fun_header(object);
break;
default:
copy = trans_boxed(object);
prev_pointer = &new_code->entry_points;
while (fheaderl != NIL) {
- struct function *fheaderp, *nfheaderp;
+ struct simple_fun *fheaderp, *nfheaderp;
lispobj nfheaderl;
- fheaderp = (struct function *) native_pointer(fheaderl);
- gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
+ fheaderp = (struct simple_fun *) native_pointer(fheaderl);
+ gc_assert(TypeOf(fheaderp->header) == type_SimpleFunHeader);
/* calcuate the new function pointer and the new */
/* function header */
nfheaderl = fheaderl + displacement;
- nfheaderp = (struct function *) native_pointer(nfheaderl);
+ nfheaderp = (struct simple_fun *) native_pointer(nfheaderl);
/* set forwarding pointer */
#ifdef DEBUG_CODE_GC
struct code *code;
int nheader_words, ncode_words, nwords;
lispobj fheaderl;
- struct function *fheaderp;
+ struct simple_fun *fheaderp;
code = (struct code *) where;
ncode_words = fixnum_value(code->code_size);
/* code data block */
fheaderl = code->entry_points;
while (fheaderl != NIL) {
- fheaderp = (struct function *) native_pointer(fheaderl);
- gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
+ fheaderp = (struct simple_fun *) native_pointer(fheaderl);
+ gc_assert(TypeOf(fheaderp->header) == type_SimpleFunHeader);
#if defined(DEBUG_CODE_GC)
printf("Scavenging boxed section of entry point located at 0x%08x.\n",
static lispobj
trans_return_pc_header(lispobj object)
{
- struct function *return_pc;
+ struct simple_fun *return_pc;
unsigned long offset;
struct code *code, *ncode;
lispobj ret;
- return_pc = (struct function *) native_pointer(object);
+ return_pc = (struct simple_fun *) native_pointer(object);
offset = HeaderValue(return_pc->header) * 4 ;
/* Transport the whole code object */
lispobj fun;
closure = (struct closure *)where;
- fun = closure->function - RAW_ADDR_OFFSET;
+ fun = closure->fun - FUN_RAW_ADDR_OFFSET;
scavenge(&fun, 1);
return 2;
#endif
static int
-scav_function_header(lispobj *where, lispobj object)
+scav_fun_header(lispobj *where, lispobj object)
{
fprintf(stderr, "GC lossage. Should not be scavenging a ");
fprintf(stderr, "Function Header.\n");
}
static lispobj
-trans_function_header(lispobj object)
+trans_fun_header(lispobj object)
{
- struct function *fheader;
+ struct simple_fun *fheader;
unsigned long offset;
struct code *code, *ncode;
- fheader = (struct function *) native_pointer(object);
+ fheader = (struct simple_fun *) native_pointer(object);
offset = HeaderValue(fheader->header) * 4;
/* Transport the whole code object */
code = (struct code *) ((unsigned long) fheader - offset);
ncode = trans_code(code);
- return ((lispobj) LOW_WORD(ncode) + offset) | type_FunctionPointer;
+ return ((lispobj) LOW_WORD(ncode) + offset) | type_FunPointer;
}
fdefn = (struct fdefn *)where;
- if ((char *)(fdefn->function + RAW_ADDR_OFFSET)
+ if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET)
== (char *)((unsigned long)(fdefn->raw_addr))) {
scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
- fdefn->raw_addr = (u32) ((char *) LOW_WORD(fdefn->function)) + RAW_ADDR_OFFSET;
+ fdefn->raw_addr =
+ (u32) ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
return sizeof(struct fdefn) / sizeof(lispobj);
}
else
for (i = 0; i < 32; i++) {
scavtab[type_EvenFixnum|(i<<3)] = scav_immediate;
- scavtab[type_FunctionPointer|(i<<3)] = scav_function_pointer;
+ scavtab[type_FunPointer|(i<<3)] = scav_fun_pointer;
/* OtherImmediate0 */
scavtab[type_ListPointer|(i<<3)] = scav_list_pointer;
scavtab[type_OddFixnum|(i<<3)] = scav_immediate;
scavtab[type_ComplexVector] = scav_boxed;
scavtab[type_ComplexArray] = scav_boxed;
scavtab[type_CodeHeader] = scav_code_header;
- scavtab[type_FunctionHeader] = scav_function_header;
- scavtab[type_ClosureFunctionHeader] = scav_function_header;
+ scavtab[type_SimpleFunHeader] = scav_fun_header;
+ scavtab[type_ClosureFunHeader] = scav_fun_header;
scavtab[type_ReturnPcHeader] = scav_return_pc_header;
#ifdef __i386__
scavtab[type_ClosureHeader] = scav_closure_header;
transother[type_ComplexVector] = trans_boxed;
transother[type_ComplexArray] = trans_boxed;
transother[type_CodeHeader] = trans_code_header;
- transother[type_FunctionHeader] = trans_function_header;
- transother[type_ClosureFunctionHeader] = trans_function_header;
+ transother[type_SimpleFunHeader] = trans_fun_header;
+ transother[type_ClosureFunHeader] = trans_fun_header;
transother[type_ReturnPcHeader] = trans_return_pc_header;
transother[type_ClosureHeader] = trans_boxed;
transother[type_FuncallableInstanceHeader] = trans_boxed;
for (i = 0; i < 32; i++) {
sizetab[type_EvenFixnum|(i<<3)] = size_immediate;
- sizetab[type_FunctionPointer|(i<<3)] = size_pointer;
+ sizetab[type_FunPointer|(i<<3)] = size_pointer;
/* OtherImmediate0 */
sizetab[type_ListPointer|(i<<3)] = size_pointer;
sizetab[type_OddFixnum|(i<<3)] = size_immediate;
sizetab[type_CodeHeader] = size_code_header;
#if 0
/* Shouldn't see these so just lose if it happens */
- sizetab[type_FunctionHeader] = size_function_header;
- sizetab[type_ClosureFunctionHeader] = size_function_header;
+ sizetab[type_SimpleFunHeader] = size_function_header;
+ sizetab[type_ClosureFunHeader] = size_function_header;
sizetab[type_ReturnPcHeader] = size_return_pc_header;
#endif
sizetab[type_ClosureHeader] = size_boxed;
* code and code-related objects
*/
-#define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
+/* FIXME: (1) Shouldn't this be defined in sbcl.h? (2) Shouldn't it
+ * be in the same units as FDEFN_RAW_ADDR_OFFSET? (This is measured
+ * in words, that's measured in bytes. Gotta love CMU CL..) */
+#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunPointer)
-static lispobj trans_function_header(lispobj object);
+static lispobj trans_fun_header(lispobj object);
static lispobj trans_boxed(lispobj object);
static int
-scav_function_pointer(lispobj *where, lispobj object)
+scav_fun_pointer(lispobj *where, lispobj object)
{
lispobj *first_pointer;
lispobj copy;
* header, a closure function header, or to a closure header. */
switch (TypeOf(*first_pointer)) {
- case type_FunctionHeader:
- case type_ClosureFunctionHeader:
- copy = trans_function_header(object);
+ case type_SimpleFunHeader:
+ case type_ClosureFunHeader:
+ copy = trans_fun_header(object);
break;
default:
copy = trans_boxed(object);
prev_pointer = &new_code->entry_points;
while (fheaderl != NIL) {
- struct function *fheaderp, *nfheaderp;
+ struct simple_fun *fheaderp, *nfheaderp;
lispobj nfheaderl;
- fheaderp = (struct function *) native_pointer(fheaderl);
- gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
+ fheaderp = (struct simple_fun *) native_pointer(fheaderl);
+ gc_assert(TypeOf(fheaderp->header) == type_SimpleFunHeader);
/* Calculate the new function pointer and the new */
/* function header. */
nfheaderl = fheaderl + displacement;
- nfheaderp = (struct function *) native_pointer(nfheaderl);
+ nfheaderp = (struct simple_fun *) native_pointer(nfheaderl);
/* Set forwarding pointer. */
((lispobj *)fheaderp)[0] = 0x01;
((lispobj *)fheaderp)[1] = nfheaderl;
/* Fix self pointer. */
- nfheaderp->self = nfheaderl + RAW_ADDR_OFFSET;
+ nfheaderp->self = nfheaderl + FUN_RAW_ADDR_OFFSET;
*prev_pointer = nfheaderl;
struct code *code;
int n_header_words, n_code_words, n_words;
lispobj entry_point; /* tagged pointer to entry point */
- struct function *function_ptr; /* untagged pointer to entry point */
+ struct simple_fun *function_ptr; /* untagged pointer to entry point */
code = (struct code *) where;
n_code_words = fixnum_value(code->code_size);
gc_assert(is_lisp_pointer(entry_point));
- function_ptr = (struct function *) native_pointer(entry_point);
- gc_assert(TypeOf(function_ptr->header) == type_FunctionHeader);
+ function_ptr = (struct simple_fun *) native_pointer(entry_point);
+ gc_assert(TypeOf(function_ptr->header) == type_SimpleFunHeader);
scavenge(&function_ptr->name, 1);
scavenge(&function_ptr->arglist, 1);
static lispobj
trans_return_pc_header(lispobj object)
{
- struct function *return_pc;
+ struct simple_fun *return_pc;
unsigned long offset;
struct code *code, *ncode;
SHOW("/trans_return_pc_header: Will this work?");
- return_pc = (struct function *) native_pointer(object);
+ return_pc = (struct simple_fun *) native_pointer(object);
offset = HeaderValue(return_pc->header) * 4;
/* Transport the whole code object. */
lispobj fun;
closure = (struct closure *)where;
- fun = closure->function - RAW_ADDR_OFFSET;
+ fun = closure->fun - FUN_RAW_ADDR_OFFSET;
scavenge(&fun, 1);
/* The function may have moved so update the raw address. But
* don't write unnecessarily. */
- if (closure->function != fun + RAW_ADDR_OFFSET)
- closure->function = fun + RAW_ADDR_OFFSET;
+ if (closure->fun != fun + FUN_RAW_ADDR_OFFSET)
+ closure->fun = fun + FUN_RAW_ADDR_OFFSET;
return 2;
}
#endif
static int
-scav_function_header(lispobj *where, lispobj object)
+scav_fun_header(lispobj *where, lispobj object)
{
lose("attempted to scavenge a function header where=0x%08x object=0x%08x",
(unsigned long) where,
}
static lispobj
-trans_function_header(lispobj object)
+trans_fun_header(lispobj object)
{
- struct function *fheader;
+ struct simple_fun *fheader;
unsigned long offset;
struct code *code, *ncode;
- fheader = (struct function *) native_pointer(object);
+ fheader = (struct simple_fun *) native_pointer(object);
offset = HeaderValue(fheader->header) * 4;
/* Transport the whole code object. */
code = (struct code *) ((unsigned long) fheader - offset);
ncode = trans_code(code);
- return ((lispobj) ncode + offset) | type_FunctionPointer;
+ return ((lispobj) ncode + offset) | type_FunPointer;
}
\f
/*
fdefn = (struct fdefn *)where;
/* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
- fdefn->function, fdefn->raw_addr)); */
+ fdefn->fun, fdefn->raw_addr)); */
- if ((char *)(fdefn->function + RAW_ADDR_OFFSET) == fdefn->raw_addr) {
+ if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET) == fdefn->raw_addr) {
scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
/* Don't write unnecessarily. */
- if (fdefn->raw_addr != (char *)(fdefn->function + RAW_ADDR_OFFSET))
- fdefn->raw_addr = (char *)(fdefn->function + RAW_ADDR_OFFSET);
+ if (fdefn->raw_addr != (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET))
+ fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
return sizeof(struct fdefn) / sizeof(lispobj);
} else {
* possible value of the high 5 bits). */
for (i = 0; i < 32; i++) { /* FIXME: bare constant length, ick! */
scavtab[type_EvenFixnum|(i<<3)] = scav_immediate;
- scavtab[type_FunctionPointer|(i<<3)] = scav_function_pointer;
+ scavtab[type_FunPointer|(i<<3)] = scav_fun_pointer;
/* OtherImmediate0 */
scavtab[type_ListPointer|(i<<3)] = scav_list_pointer;
scavtab[type_OddFixnum|(i<<3)] = scav_immediate;
scavtab[type_ComplexVector] = scav_boxed;
scavtab[type_ComplexArray] = scav_boxed;
scavtab[type_CodeHeader] = scav_code_header;
- /*scavtab[type_FunctionHeader] = scav_function_header;*/
- /*scavtab[type_ClosureFunctionHeader] = scav_function_header;*/
+ /*scavtab[type_SimpleFunHeader] = scav_fun_header;*/
+ /*scavtab[type_ClosureFunHeader] = scav_fun_header;*/
/*scavtab[type_ReturnPcHeader] = scav_return_pc_header;*/
#ifdef __i386__
scavtab[type_ClosureHeader] = scav_closure_header;
transother[type_ComplexVector] = trans_boxed;
transother[type_ComplexArray] = trans_boxed;
transother[type_CodeHeader] = trans_code_header;
- transother[type_FunctionHeader] = trans_function_header;
- transother[type_ClosureFunctionHeader] = trans_function_header;
+ transother[type_SimpleFunHeader] = trans_fun_header;
+ transother[type_ClosureFunHeader] = trans_fun_header;
transother[type_ReturnPcHeader] = trans_return_pc_header;
transother[type_ClosureHeader] = trans_boxed;
transother[type_FuncallableInstanceHeader] = trans_boxed;
sizetab[i] = size_lose;
for (i = 0; i < 32; i++) {
sizetab[type_EvenFixnum|(i<<3)] = size_immediate;
- sizetab[type_FunctionPointer|(i<<3)] = size_pointer;
+ sizetab[type_FunPointer|(i<<3)] = size_pointer;
/* OtherImmediate0 */
sizetab[type_ListPointer|(i<<3)] = size_pointer;
sizetab[type_OddFixnum|(i<<3)] = size_immediate;
sizetab[type_CodeHeader] = size_code_header;
#if 0
/* We shouldn't see these, so just lose if it happens. */
- sizetab[type_FunctionHeader] = size_function_header;
- sizetab[type_ClosureFunctionHeader] = size_function_header;
+ sizetab[type_SimpleFunHeader] = size_function_header;
+ sizetab[type_ClosureFunHeader] = size_function_header;
sizetab[type_ReturnPcHeader] = size_return_pc_header;
#endif
sizetab[type_ClosureHeader] = size_boxed;
* and returning true from this function when *pointer is
* a reference to that result. */
switch (LowtagOf((lispobj)pointer)) {
- case type_FunctionPointer:
+ case type_FunPointer:
/* Start_addr should be the enclosing code object, or a closure
* header. */
switch (TypeOf(*start_addr)) {
case type_ClosureHeader:
case type_FuncallableInstanceHeader:
if ((unsigned)pointer !=
- ((unsigned)start_addr+type_FunctionPointer)) {
+ ((unsigned)start_addr+type_FunPointer)) {
if (gencgc_verbose)
FSHOW((stderr,
"/Wf2: %x %x %x\n",
struct code *code;
int nheader_words, ncode_words, nwords;
lispobj fheaderl;
- struct function *fheaderp;
+ struct simple_fun *fheaderp;
code = (struct code *) start;
* the code data block. */
fheaderl = code->entry_points;
while (fheaderl != NIL) {
- fheaderp = (struct function *) native_pointer(fheaderl);
- gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
+ fheaderp =
+ (struct simple_fun *) native_pointer(fheaderl);
+ gc_assert(TypeOf(fheaderp->header) == type_SimpleFunHeader);
verify_space(&fheaderp->name, 1);
verify_space(&fheaderp->arglist, 1);
verify_space(&fheaderp->type, 1);
/* There is a small window during call where the callee's
* frame isn't built yet. */
if (LowtagOf(*os_context_register_addr(context, reg_CODE))
- == type_FunctionPointer) {
+ == type_FunPointer) {
/* We have called, but not built the new frame, so
* build it for them. */
current_control_frame_pointer[0] =
* support decides to pass on it. */
lose("no handler for signal %d in interrupt_handle_now(..)", signal);
- } else if (LowtagOf(handler.lisp) == type_FunctionPointer) {
+ } else if (LowtagOf(handler.lisp) == type_FunPointer) {
/* Allocate the SAPs while the interrupts are still disabled.
* (FIXME: Why? This is the way it was done in CMU CL, and it
obj = *end;
addr = end;
end += 2;
- if (TypeOf(obj) == type_FunctionHeader)
- print((long)addr | type_FunctionPointer);
- else if (LowtagOf(obj) == type_OtherImmediate0 || LowtagOf(obj) == type_OtherImmediate1)
+ if (TypeOf(obj) == type_SimpleFunHeader) {
+ print((long)addr | type_FunPointer);
+ } else if (LowtagOf(obj) == type_OtherImmediate0 ||
+ LowtagOf(obj) == type_OtherImmediate1) {
print((lispobj)addr | type_OtherPointer);
- else
+ } else {
print((lispobj)addr);
- if (count == -1)
+ } if (count == -1) {
return;
+ }
}
}
case type_Fdefn:
fdefn:
- function = FDEFN(thing)->function;
+ function = FDEFN(thing)->fun;
if (function == NIL) {
printf("Fdefn 0x%08lx is undefined.\n", (long unsigned)thing);
return;
return;
}
}
- else if (LowtagOf(thing) != type_FunctionPointer) {
+ else if (LowtagOf(thing) != type_FunPointer) {
printf("0x%08lx is not a function pointer, symbol, or fdefn object.\n",
(long unsigned)thing);
return;
print_slots(code_slots, count-1, ptr);
break;
- case type_FunctionHeader:
- case type_ClosureFunctionHeader:
+ case type_SimpleFunHeader:
+ case type_ClosureFunHeader:
print_slots(fn_slots, 5, ptr);
break;
if (var != NULL && var_clock(var) == cur_clock)
dont_descend = 1;
- if (var == NULL && (obj & type_FunctionPointer & type_ListPointer & type_InstancePointer & type_OtherPointer) != 0)
+ if (var == NULL &&
+ /* FIXME: What does this "x & y & z & .." expression mean? */
+ (obj & type_FunPointer & type_ListPointer & type_InstancePointer & type_OtherPointer) != 0)
var = define_var(NULL, obj, 0);
if (var != NULL)
#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
#define NWORDS(x,y) (CEILING((x),(y)) / (y))
+/* FIXME: (1) Shouldn't this be defined in sbcl.h? (2) Shouldn't it
+ * be in the same units as FDEFN_RAW_ADDR_OFFSET? (This is measured
+ * in words, that's measured in bytes. Gotta love CMU CL..) */
#ifdef sparc
-#define RAW_ADDR_OFFSET 0
+#define FUN_RAW_ADDR_OFFSET 0
#else
-#define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
+#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunPointer)
#endif
\f
static boolean
/* Check that the object pointed to is consistent with the pointer
* low tag. */
switch (LowtagOf((lispobj)pointer)) {
- case type_FunctionPointer:
+ case type_FunPointer:
/* Start_addr should be the enclosing code object, or a closure
* header. */
switch (TypeOf(*start_addr)) {
break;
case type_ClosureHeader:
case type_FuncallableInstanceHeader:
- if ((int)pointer != ((int)start_addr+type_FunctionPointer)) {
+ if ((int)pointer != ((int)start_addr+type_FunPointer)) {
if (pointer_filter_verbose) {
fprintf(stderr,"*Wf2: %x %x %x\n", (unsigned int) pointer,
(unsigned int) start_addr, *start_addr);
/* Scavenge the function. */
fdefn = (struct fdefn *)new;
- oldfn = fdefn->function;
- pscav(&fdefn->function, 1, 0);
- if ((char *)oldfn + RAW_ADDR_OFFSET == fdefn->raw_addr)
- fdefn->raw_addr = (char *)fdefn->function + RAW_ADDR_OFFSET;
+ oldfn = fdefn->fun;
+ pscav(&fdefn->fun, 1, 0);
+ if ((char *)oldfn + FUN_RAW_ADDR_OFFSET == fdefn->raw_addr)
+ fdefn->raw_addr = (char *)fdefn->fun + FUN_RAW_ADDR_OFFSET;
return result;
}
/* Put in forwarding pointers for all the functions. */
for (func = code->entry_points;
func != NIL;
- func = ((struct function *)native_pointer(func))->next) {
+ func = ((struct simple_fun *)native_pointer(func))->next) {
- gc_assert(LowtagOf(func) == type_FunctionPointer);
+ gc_assert(LowtagOf(func) == type_FunPointer);
*(lispobj *)native_pointer(func) = result + (func - thing);
}
pscav(&new->entry_points, 1, 1);
for (func = new->entry_points;
func != NIL;
- func = ((struct function *)native_pointer(func))->next) {
- gc_assert(LowtagOf(func) == type_FunctionPointer);
+ func = ((struct simple_fun *)native_pointer(func))->next) {
+ gc_assert(LowtagOf(func) == type_FunPointer);
gc_assert(!dynamic_pointer_p(func));
#ifdef __i386__
- /* Temporarly convert the self pointer to a real function
- pointer. */
- ((struct function *)native_pointer(func))->self -= RAW_ADDR_OFFSET;
+ /* Temporarly convert the self pointer to a real function pointer. */
+ ((struct simple_fun *)native_pointer(func))->self
+ -= FUN_RAW_ADDR_OFFSET;
#endif
- pscav(&((struct function *)native_pointer(func))->self, 2, 1);
+ pscav(&((struct simple_fun *)native_pointer(func))->self, 2, 1);
#ifdef __i386__
- ((struct function *)native_pointer(func))->self += RAW_ADDR_OFFSET;
+ ((struct simple_fun *)native_pointer(func))->self
+ += FUN_RAW_ADDR_OFFSET;
#endif
- pscav_later(&((struct function *)native_pointer(func))->name, 3);
+ pscav_later(&((struct simple_fun *)native_pointer(func))->name, 3);
}
return result;
{
int nwords;
lispobj code, *new, *old, result;
- struct function *function;
+ struct simple_fun *function;
/* Thing can either be a function header, a closure function
* header, a closure, or a funcallable-instance. If it's a closure
* Otherwise we have to do something strange, 'cause it is buried
* inside a code object. */
- if (TypeOf(header) == type_FunctionHeader ||
- TypeOf(header) == type_ClosureFunctionHeader) {
+ if (TypeOf(header) == type_SimpleFunHeader ||
+ TypeOf(header) == type_ClosureFunHeader) {
/* We can only end up here if the code object has not been
* scavenged, because if it had been scavenged, forwarding pointers
* would have been left behind for all the entry points. */
- function = (struct function *)native_pointer(thing);
+ function = (struct simple_fun *)native_pointer(thing);
code =
(native_pointer(thing) -
(HeaderValue(function->header)*sizeof(lispobj))) |
{
boolean fix_func;
- fix_func = ((char *)(fdefn->function+RAW_ADDR_OFFSET) == fdefn->raw_addr);
+ fix_func = ((char *)(fdefn->fun+FUN_RAW_ADDR_OFFSET) == fdefn->raw_addr);
pscav(&fdefn->name, 1, 1);
- pscav(&fdefn->function, 1, 0);
+ pscav(&fdefn->fun, 1, 0);
if (fix_func)
- fdefn->raw_addr = (char *)(fdefn->function + RAW_ADDR_OFFSET);
+ fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
return sizeof(struct fdefn) / sizeof(lispobj);
}
pscav(&code->entry_points, 1, 1);
for (func = code->entry_points;
func != NIL;
- func = ((struct function *)native_pointer(func))->next) {
- gc_assert(LowtagOf(func) == type_FunctionPointer);
+ func = ((struct simple_fun *)native_pointer(func))->next) {
+ gc_assert(LowtagOf(func) == type_FunPointer);
gc_assert(!dynamic_pointer_p(func));
#ifdef __i386__
/* Temporarly convert the self pointer to a real function
* pointer. */
- ((struct function *)native_pointer(func))->self -= RAW_ADDR_OFFSET;
+ ((struct simple_fun *)native_pointer(func))->self
+ -= FUN_RAW_ADDR_OFFSET;
#endif
- pscav(&((struct function *)native_pointer(func))->self, 2, 1);
+ pscav(&((struct simple_fun *)native_pointer(func))->self, 2, 1);
#ifdef __i386__
- ((struct function *)native_pointer(func))->self += RAW_ADDR_OFFSET;
+ ((struct simple_fun *)native_pointer(func))->self
+ += FUN_RAW_ADDR_OFFSET;
#endif
- pscav_later(&((struct function *)native_pointer(func))->name, 3);
+ pscav_later(&((struct simple_fun *)native_pointer(func))->name, 3);
}
return CEILING(nwords,2);
else {
/* Nope, copy the object. */
switch (LowtagOf(thing)) {
- case type_FunctionPointer:
+ case type_FunPointer:
thing = ptrans_func(thing, header);
break;
#endif
break;
- case type_FunctionHeader:
- case type_ClosureFunctionHeader:
+ case type_SimpleFunHeader:
+ case type_ClosureFunHeader:
case type_ReturnPcHeader:
/* We should never hit any of these, 'cause they occur
* buried in the middle of code objects. */
/* The function self pointer needs special care on the
* x86 because it is the real entry point. */
{
- lispobj fun = ((struct closure *)addr)->function
- - RAW_ADDR_OFFSET;
+ lispobj fun = ((struct closure *)addr)->fun
+ - FUN_RAW_ADDR_OFFSET;
pscav(&fun, 1, constant);
- ((struct closure *)addr)->function = fun + RAW_ADDR_OFFSET;
+ ((struct closure *)addr)->fun = fun + FUN_RAW_ADDR_OFFSET;
}
count = 2;
break;
/* This only works for static symbols. */
/* FIXME: should be called StaticSymbolFunction, right? */
#define SymbolFunction(sym) \
- (((struct fdefn *)(SymbolValue(sym)-type_OtherPointer))->function)
+ (((struct fdefn *)(SymbolValue(sym)-type_OtherPointer))->fun)
/* KLUDGE: As far as I can tell there's no ANSI C way of saying
* "this function never returns". This is the way that you do it
mov %ebx,%ebp # Switch to new frame.
/* Indirect the closure. */
- call *CLOSURE_FUNCTION_OFFSET(%eax)
+ call *CLOSURE_FUN_OFFSET(%eax)
/* Multi-value return; blow off any extra values. */
mov %ebx, %esp
.global GNAME(closure_tramp)
.type GNAME(closure_tramp),@function
GNAME(closure_tramp):
- movl FDEFN_FUNCTION_OFFSET(%eax),%eax
+ movl FDEFN_FUN_OFFSET(%eax),%eax
/* FIXME: The '*' after "jmp" in the next line is from PVE's
* patch posted to the CMU CL mailing list Oct 6, 1999. It looks
* reasonable, and it certainly seems as though if CMU CL needs it,
* SBCL needs it too, but I haven't actually verified that it's
* right. It would be good to find a way to force the flow of
* control through here to test it. */
- jmp *CLOSURE_FUNCTION_OFFSET(%eax)
+ jmp *CLOSURE_FUN_OFFSET(%eax)
.size GNAME(closure_tramp), .-GNAME(closure_tramp)
/*
(defvar *public-package-names*
'("SB-ALIEN" "SB-C-CALL" "SB-DEBUG" "SB-EXT" "SB-GRAY" "SB-MP"
"SB-PROFILE" "SB-PCL" "COMMON-LISP"))
-(defun has-arglist-info-p (function)
- (declare (type function function))
+(defun has-arglist-info-p (fun)
+ (declare (type function fun))
;; The Lisp-level type FUNCTION can conceal a multitude of sins..
- (case (sb-kernel:get-type function)
- ((#.sb-vm:function-header-type #.sb-vm:closure-function-header-type)
- (sb-kernel:%function-arglist function))
+ (case (sb-kernel:get-type fun)
+ ((#.sb-vm:simple-fun-header-type #.sb-vm:closure-fun-header-type)
+ (sb-kernel:%simple-fun-arglist fun))
(#.sb-vm:closure-header-type (has-arglist-info-p
- (sb-kernel:%closure-function
- function)))
+ (sb-kernel:%closure-fun fun)))
;; In code/describe.lisp, ll. 227 (%describe-function), we use a scheme
;; like above, and it seems to work. -- MNA 2001-06-12
;;
;; (There might be other cases with arglist info also.
- ;; FUNCTION-HEADER-TYPE and CLOSURE-HEADER-TYPE just
+ ;; SIMPLE-FUN-HEADER-TYPE and CLOSURE-HEADER-TYPE just
;; happen to be the two case that I had my nose rubbed in when
- ;; debugging a GC problem caused by applying %FUNCTION-ARGLIST to
+ ;; debugging a GC problem caused by applying %SIMPLE-FUN-ARGLIST to
;; a closure. -- WHN 2001-06-05)
(t nil)))
(defun check-ext-symbols-arglist (package)
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.54"
+"0.pre7.55"
projects / sbcl.git / commitdiff