"SINGLE-STEP-BREAKPOINT-TRAP"
"SINGLE-VALUE-RETURN-BYTE-OFFSET" "SLOT-DOCS"
"SLOT-LENGTH" "SLOT-NAME" "SLOT-OFFSET" "SLOT-OPTIONS"
- "SLOT-REST-P" "*STATIC-FUNCTIONS*" "STATIC-FUNCTION-OFFSET"
+ "SLOT-REST-P" "*STATIC-FUNS*" "STATIC-FUN-OFFSET"
"STATIC-SYMBOL-OFFSET" "STATIC-SYMBOL-P"
"*STATIC-SPACE-FREE-POINTER*" "*STATIC-SYMBOLS*"
"STRUCTURE-USAGE"
(lisp-return lra lip :offset 2)
DO-STATIC-FUN
- (inst ldl lip (static-function-offset 'two-arg-+) null-tn)
+ (inst ldl lip (static-fun-offset 'two-arg-+) null-tn)
(inst li (fixnumize 2) nargs)
(inst move cfp-tn ocfp)
(inst move csp-tn cfp-tn)
(lisp-return lra lip :offset 2)
DO-STATIC-FUN
- (inst ldl lip (static-function-offset 'two-arg--) null-tn)
+ (inst ldl lip (static-fun-offset 'two-arg--) null-tn)
(inst li (fixnumize 2) nargs)
(inst move cfp-tn ocfp)
(inst move csp-tn cfp-tn)
(lisp-return lra lip :offset 2)
DO-STATIC-FUN
- (inst ldl lip (static-function-offset 'two-arg-*) null-tn)
+ (inst ldl lip (static-fun-offset 'two-arg-*) null-tn)
(inst li (fixnumize 2) nargs)
(inst move cfp-tn ocfp)
(inst move csp-tn cfp-tn)
(inst beq temp DO-COMPARE)
DO-STATIC-FN
- (inst ldl lip (static-function-offset ',static-fn) null-tn)
+ (inst ldl lip (static-fun-offset ',static-fn) null-tn)
(inst li (fixnumize 2) nargs)
(inst move cfp-tn ocfp)
(inst move csp-tn cfp-tn)
(lisp-return lra lip :offset 2)
DO-STATIC-FN
- (inst ldl lip (static-function-offset 'eql) null-tn)
+ (inst ldl lip (static-fun-offset 'eql) null-tn)
(inst li (fixnumize 2) nargs)
(inst move cfp-tn ocfp)
(inst move csp-tn cfp-tn)
(lisp-return lra lip :offset 2)
DO-STATIC-FN
- (inst ldl lip (static-function-offset 'two-arg-=) null-tn)
+ (inst ldl lip (static-fun-offset 'two-arg-=) null-tn)
(inst li (fixnumize 2) nargs)
(inst move cfp-tn ocfp)
(inst move csp-tn cfp-tn)
(lisp-return lra lip :offset 2)
DO-STATIC-FN
- (inst ldl lip (static-function-offset 'two-arg-=) null-tn)
+ (inst ldl lip (static-fun-offset 'two-arg-=) null-tn)
(inst li (fixnumize 2) nargs)
(inst move cfp-tn ocfp)
(inst move csp-tn cfp-tn)
(inst jmp
(make-ea :dword
:disp (+ nil-value
- (static-function-offset
+ (static-fun-offset
',(symbolicate "TWO-ARG-" fun)))))
DO-BODY
(inst push eax)
(inst mov ecx (fixnumize 1)) ; arg count
(inst jmp (make-ea :dword
- :disp (+ nil-value (static-function-offset '%negate))))
+ :disp (+ nil-value (static-fun-offset '%negate))))
FIXNUM
(move res x)
; should be named parallelly.
(inst jmp (make-ea :dword
:disp (+ nil-value
- (static-function-offset
- ',static-fn))))
+ (static-fun-offset ',static-fn))))
INLINE-FIXNUM-COMPARE
(inst cmp x y)
(inst push eax)
(inst mov ecx (fixnumize 2))
(inst jmp (make-ea :dword
- :disp (+ nil-value (static-function-offset 'eql))))
+ :disp (+ nil-value (static-fun-offset 'eql))))
RETURN-T
(load-symbol res t)
(inst push eax)
(inst mov ecx (fixnumize 2))
(inst jmp (make-ea :dword
- :disp (+ nil-value (static-function-offset 'two-arg-=))))
+ :disp (+ nil-value (static-fun-offset 'two-arg-=))))
RETURN-T
(load-symbol res t))
vars types))
(list ,@vals))))
(defun create-structure-constructor (dd cons-name arglist vars types values)
- (let* ((temp (gensym))
- (raw-index (dd-raw-index dd))
- (n-raw-data (when raw-index (gensym))))
+ (let* ((instance (gensym "INSTANCE"))
+ (raw-index (dd-raw-index dd)))
`(defun ,cons-name ,arglist
- (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
+ (declare ,@(mapcar (lambda (var type) `(type ,type ,var))
vars types))
- (let ((,temp (truly-the ,(dd-name dd)
- (%make-instance ,(dd-length dd))))
- ,@(when n-raw-data
- `((,n-raw-data
- (make-array ,(dd-raw-length dd)
- :element-type '(unsigned-byte 32))))))
- (setf (%instance-layout ,temp)
- (%delayed-get-compiler-layout ,(dd-name dd)))
- ,@(when n-raw-data
- `((setf (%instance-ref ,temp ,raw-index) ,n-raw-data)))
+ (let ((,instance (truly-the ,(dd-name dd)
+ (%make-instance-with-layout
+ (%delayed-get-compiler-layout ,(dd-name dd))))))
+ (declare (optimize (safety 0))) ; Suppress redundant slot type checks.
+ ,@(when raw-index
+ `((setf (%instance-ref ,instance ,raw-index)
+ (make-array ,(dd-raw-length dd)
+ :element-type '(unsigned-byte 32)))))
,@(mapcar (lambda (dsd value)
- ;; (Note that we can't in general use the ordinary
- ;; slot accessor function here because the slot
- ;; might be :READ-ONLY.)
- `(,(slot-setter-lambda-form dd dsd) ,value ,temp))
+ ;; (Note that we can't in general use the
+ ;; ordinary named slot setter function here
+ ;; because the slot might be :READ-ONLY, so we
+ ;; whip up new LAMBDA representations of slot
+ ;; setters for the occasion.)
+ `(,(slot-setter-lambda-form dd dsd) ,value ,instance))
(dd-slots dd)
values)
- ,temp))))
+ ,instance))))
;;; Create a default (non-BOA) keyword constructor.
(defun create-keyword-constructor (defstruct creator)
(if (funcallable-instance-p new-value)
(%funcallable-instance-lexenv new-value)
new-value)))
+
+;;; service function for structure constructors
+(defun %make-instance-with-layout (layout)
+ (let ((result (%make-instance (layout-length layout))))
+ (setf (%instance-layout result) layout)
+ result))
\f
;;;; target-only parts of the DEFSTRUCT top-level code
(dsd-raw-type (dsd-raw-type dsd)))
#+sb-xc (/show0 "in %NATIVE-SLOT-ACCESSOR-FUNS macroexpanded code")
;; Map over all the possible RAW-TYPEs, compiling
- ;; a different closure-function for each one, so
+ ;; a different closure function for each one, so
;; that once the COND over RAW-TYPEs happens (at
;; the time closure is allocated) there are no
;; more decisions to be made and things execute
\f
;;;; static functions
-(define-static-function two-arg-gcd (x y) :translate gcd)
-(define-static-function two-arg-lcm (x y) :translate lcm)
-
-(define-static-function two-arg-+ (x y) :translate +)
-(define-static-function two-arg-- (x y) :translate -)
-(define-static-function two-arg-* (x y) :translate *)
-(define-static-function two-arg-/ (x y) :translate /)
-
-(define-static-function two-arg-< (x y) :translate <)
-(define-static-function two-arg-<= (x y) :translate <=)
-(define-static-function two-arg-> (x y) :translate >)
-(define-static-function two-arg->= (x y) :translate >=)
-(define-static-function two-arg-= (x y) :translate =)
-(define-static-function two-arg-/= (x y) :translate /=)
-
-(define-static-function %negate (x) :translate %negate)
-
-(define-static-function two-arg-and (x y) :translate logand)
-(define-static-function two-arg-ior (x y) :translate logior)
-(define-static-function two-arg-xor (x y) :translate logxor)
+(define-static-fun two-arg-gcd (x y) :translate gcd)
+(define-static-fun two-arg-lcm (x y) :translate lcm)
+
+(define-static-fun two-arg-+ (x y) :translate +)
+(define-static-fun two-arg-- (x y) :translate -)
+(define-static-fun two-arg-* (x y) :translate *)
+(define-static-fun two-arg-/ (x y) :translate /)
+
+(define-static-fun two-arg-< (x y) :translate <)
+(define-static-fun two-arg-<= (x y) :translate <=)
+(define-static-fun two-arg-> (x y) :translate >)
+(define-static-fun two-arg->= (x y) :translate >=)
+(define-static-fun two-arg-= (x y) :translate =)
+(define-static-fun two-arg-/= (x y) :translate /=)
+
+(define-static-fun %negate (x) :translate %negate)
+
+(define-static-fun two-arg-and (x y) :translate logand)
+(define-static-fun two-arg-ior (x y) :translate logior)
+(define-static-fun two-arg-xor (x y) :translate logxor)
sb!unix::*interrupts-enabled*
sb!unix::*interrupt-pending*))
-(defparameter *static-functions*
+(defparameter *static-funs*
'(length
sb!kernel:two-arg-+
sb!kernel:two-arg--
(in-package "SB!VM")
-(define-vop (static-function-template)
+(define-vop (static-fun-template)
(:save-p t)
(:policy :safe)
(:variant-vars symbol)
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defun static-function-template-name (num-args num-results)
- (intern (format nil "~:@(~R-arg-~R-result-static-function~)"
+(defun static-fun-template-name (num-args num-results)
+ (intern (format nil "~:@(~R-arg-~R-result-static-fun~)"
num-args num-results)))
(defun moves (src dst)
(moves `(move ,(car src) ,(car dst))))
(moves)))
-(defun static-function-template-vop (num-args num-results)
+(defun static-fun-template-vop (num-args num-results)
(assert (and (<= num-args register-arg-count)
(<= num-results register-arg-count))
(num-args num-results)
(args `(,arg-name
:scs (any-reg descriptor-reg null zero)
:target ,(nth i (temp-names))))))
- `(define-vop (,(static-function-template-name num-args num-results)
- static-function-template)
+ `(define-vop (,(static-fun-template-name num-args num-results)
+ static-fun-template)
(:args ,@(args))
,@(temps)
(:results ,@(results))
(cur-nfp (current-nfp-tn vop)))
,@(moves (arg-names) (temp-names))
(inst li (fixnumize ,num-args) nargs)
- (inst ldl entry-point (static-function-offset symbol) null-tn)
+ (inst ldl entry-point (static-fun-offset symbol) null-tn)
(when cur-nfp
(store-stack-tn nfp-save cur-nfp))
(inst move cfp-tn ocfp)
(expand
(collect ((templates (list 'progn)))
(dotimes (i register-arg-count)
- (templates (static-function-template-vop i 1)))
+ (templates (static-fun-template-vop i 1)))
(templates)))
-(defmacro define-static-function (name args &key (results '(x)) translate
+(defmacro define-static-fun (name args &key (results '(x)) translate
policy cost arg-types result-types)
`(define-vop (,name
- ,(static-function-template-name (length args)
- (length results)))
+ ,(static-fun-template-name (length args)
+ (length results)))
(:variant ',name)
- (:note ,(format nil "static-function ~@(~S~)" name))
+ (:note ,(format nil "static-fun ~@(~S~)" name))
,@(when translate
`((:translate ,translate)))
,@(when policy
DONE
(move count result)))
-(define-static-function length (object) :translate length)
+(define-static-fun length (object) :translate length)
(defun initialize-static-fns ()
(let ((*cold-fdefn-gspace* *static*))
- (dolist (sym sb!vm:*static-functions*)
+ (dolist (sym sb!vm:*static-funs*)
(let* ((fdefn (cold-fdefinition-object (cold-intern sym)))
(offset (- (+ (- (descriptor-low fdefn)
sb!vm:other-pointer-lowtag)
(* sb!vm:fdefn-raw-addr-slot sb!vm:n-word-bytes))
(descriptor-low *nil-descriptor*)))
- (desired (sb!vm:static-function-offset sym)))
+ (desired (sb!vm:static-fun-offset sym)))
(unless (= offset desired)
;; FIXME: should be fatal
(warn "Offset from FDEFN ~S to ~S is ~D, not ~D."
(in-package "SB!VM")
\f
+;;; Make a fixnum out of NUM. (I.e. shift by two bits if it will fit.)
(defun fixnumize (num)
- #!+sb-doc
- "Make a fixnum out of NUM. (i.e. shift by two bits if it will fit.)"
(if (<= #x-20000000 num #x1fffffff)
(ash num 2)
(error "~D is too big for a fixnum." num)))
(or (null symbol)
(and (member symbol *static-symbols*) t)))
+;;; the byte offset of the static symbol SYMBOL
(defun static-symbol-offset (symbol)
- #!+sb-doc
- "the byte offset of the static symbol SYMBOL"
(if symbol
(let ((posn (position symbol *static-symbols*)))
(unless posn (error "~S is not a static symbol." symbol))
(- list-pointer-lowtag)))
0))
+;;; Given a byte offset, OFFSET, return the appropriate static symbol.
(defun offset-static-symbol (offset)
- #!+sb-doc
- "Given a byte offset, OFFSET, return the appropriate static symbol."
(if (zerop offset)
nil
(multiple-value-bind (n rem)
(error "The byte offset ~D is not valid." offset))
(elt *static-symbols* n))))
-(defun static-function-offset (name)
- #!+sb-doc
- "Return the (byte) offset from NIL to the start of the fdefn object
- for the static function NAME."
+;;; Return the (byte) offset from NIL to the start of the fdefn object
+;;; for the static function NAME.
+(defun static-fun-offset (name)
(let ((static-syms (length *static-symbols*))
- (static-function-index (position name *static-functions*)))
- (unless static-function-index
+ (static-fun-index (position name *static-funs*)))
+ (unless static-fun-index
(error "~S isn't a static function." name))
(+ (* static-syms (pad-data-block symbol-size))
(pad-data-block (1- symbol-size))
(- list-pointer-lowtag)
- (* static-function-index (pad-data-block fdefn-size))
+ (* static-fun-index (pad-data-block fdefn-size))
(* fdefn-raw-addr-slot n-word-bytes))))
;;; <padding to dual-word boundary>
;;; start of instructions
;;; ...
-;;; function-headers and lra's buried in here randomly
+;;; fun-headers and lra's buried in here randomly
;;; ...
;;; start of trace-table
;;; <padding to dual-word boundary>
(incf (dstate-next-offs dstate) lra-size))
nil)
-;;; Print the function-header (entry-point) pseudo-instruction at the
+;;; Print the fun-header (entry-point) pseudo-instruction at the
;;; current location in DSTATE to STREAM.
(defun fun-header-hook (stream dstate)
(declare (type (or null stream) stream)
\f
;;;; static functions
-(define-static-function two-arg-/ (x y) :translate /)
+(define-static-fun two-arg-/ (x y) :translate /)
-(define-static-function two-arg-gcd (x y) :translate gcd)
-(define-static-function two-arg-lcm (x y) :translate lcm)
+(define-static-fun two-arg-gcd (x y) :translate gcd)
+(define-static-fun two-arg-lcm (x y) :translate lcm)
-(define-static-function two-arg-and (x y) :translate logand)
-(define-static-function two-arg-ior (x y) :translate logior)
-(define-static-function two-arg-xor (x y) :translate logxor)
+(define-static-fun two-arg-and (x y) :translate logand)
+(define-static-fun two-arg-ior (x y) :translate logior)
+(define-static-fun two-arg-xor (x y) :translate logxor)
\f
;;; Support for the Mersenne Twister, MT19937, random number generator
;; the ordinary unbound marker for this.
sb!pcl::..slot-unbound..))
-(defparameter *static-functions*
+(defparameter *static-funs*
'(length
sb!kernel:two-arg-+
sb!kernel:two-arg--
(in-package "SB!VM")
-(define-vop (static-function-template)
+(define-vop (static-fun-template)
(:save-p t)
(:policy :safe)
(:variant-vars function)
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defun static-function-template-name (num-args num-results)
- (intern (format nil "~:@(~R-arg-~R-result-static-function~)"
+(defun static-fun-template-name (num-args num-results)
+ (intern (format nil "~:@(~R-arg-~R-result-static-fun~)"
num-args num-results)))
(defun moves (dst src)
(moves `(move ,(car dst) ,(car src))))
(moves)))
-(defun static-function-template-vop (num-args num-results)
+(defun static-fun-template-vop (num-args num-results)
(unless (and (<= num-args register-arg-count)
(<= num-results register-arg-count))
(error "either too many args (~D) or too many results (~D); max = ~D"
(args `(,arg-name
:scs (any-reg descriptor-reg)
:target ,(nth i (temp-names))))))
- `(define-vop (,(static-function-template-name num-args num-results)
- static-function-template)
+ `(define-vop (,(static-fun-template-name num-args num-results)
+ static-fun-template)
(:args ,@(args))
,@(temps)
(:results ,@(results))
`(inst mov ecx (fixnumize ,num-args)))
(note-this-location vop :call-site)
- ;; Static-function-offset gives the offset from the start of
- ;; the nil object to the static function fdefn and has the
- ;; low tag of 1 added. When the nil symbol value with its
- ;; low tag of 3 is added the resulting value points to the
- ;; raw address slot of the fdefn (at +4).
+ ;; Old CMU CL comment:
+ ;; STATIC-FUN-OFFSET gives the offset from the start of
+ ;; the NIL object to the static function FDEFN and has the
+ ;; low tag of 1 added. When the NIL symbol value with its
+ ;; low tag of 3 is added the resulting value points to the
+ ;; raw address slot of the fdefn (at +4).
+ ;; FIXME: Since the fork from CMU CL, we've swapped
+ ;; FUN-POINTER-LOWTAG and INSTANCE-POINTER-LOWTAG, so the
+ ;; text above is no longer right. Mysteriously, things still
+ ;; work. It would be good to explain why. (Is this code no
+ ;; longer executed? Does it not depend on the
+ ;; 1+3=4=fdefn_raw_address_offset relationship above?
+ ;; Is something else going on?)
(inst call (make-ea :dword
:disp (+ nil-value
- (static-function-offset function))))
+ (static-fun-offset function))))
,(collect ((bindings) (links))
(do ((temp (temp-names) (cdr temp))
(name 'values (gensym))
) ; EVAL-WHEN
(macrolet ((frob (num-args num-res)
- (static-function-template-vop (eval num-args) (eval num-res))))
+ (static-fun-template-vop (eval num-args) (eval num-res))))
(frob 0 1)
(frob 1 1)
(frob 2 1)
(frob 3 1))
-(defmacro define-static-function (name args &key (results '(x)) translate
- policy cost arg-types result-types)
+(defmacro define-static-fun (name args &key (results '(x)) translate
+ policy cost arg-types result-types)
`(define-vop (,name
- ,(static-function-template-name (length args)
- (length results)))
+ ,(static-fun-template-name (length args)
+ (length results)))
(:variant ',name)
- (:note ,(format nil "static-function ~@(~S~)" name))
+ (:note ,(format nil "static-fun ~@(~S~)" name))
,@(when translate
`((:translate ,translate)))
,@(when policy
(inst jmp :ne loop)
DONE))
-(define-static-function length (object) :translate length)
+(define-static-fun length (object) :translate length)
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.81"
+"0.pre7.82"
projects / sbcl.git / commitdiff