X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fobjdef.lisp;h=f0a666012a3a2936206a489e507490f644f30b7a;hb=6fb6e66f531dfb6140ec3e0cc8f84f6ecd1927ca;hp=ae2c7cd24df36a589d42c926bce40392e1a4b369;hpb=d147d512602d761a2dcdfded506dd1a8f9a140dc;p=sbcl.git diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index ae2c7cd..f0a6660 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -13,23 +13,23 @@ ;;;; the primitive objects themselves -(define-primitive-object (cons :lowtag list-pointer-type +(define-primitive-object (cons :lowtag list-pointer-lowtag :alloc-trans cons) (car :ref-trans car :set-trans sb!c::%rplaca :init :arg) (cdr :ref-trans cdr :set-trans sb!c::%rplacd :init :arg)) -(define-primitive-object (instance :lowtag instance-pointer-type +(define-primitive-object (instance :lowtag instance-pointer-lowtag :header instance-header-type :alloc-trans %make-instance) (slots :rest-p t)) -(define-primitive-object (bignum :lowtag other-pointer-type +(define-primitive-object (bignum :lowtag other-pointer-lowtag :header bignum-type :alloc-trans sb!bignum::%allocate-bignum) (digits :rest-p t :c-type #!-alpha "long" #!+alpha "u32")) (define-primitive-object (ratio :type ratio - :lowtag other-pointer-type + :lowtag other-pointer-lowtag :header ratio-type :alloc-trans %make-ratio) (numerator :type integer @@ -41,23 +41,23 @@ :ref-trans %denominator :init :arg)) -(define-primitive-object (single-float :lowtag other-pointer-type +(define-primitive-object (single-float :lowtag other-pointer-lowtag :header single-float-type) (value :c-type "float")) -(define-primitive-object (double-float :lowtag other-pointer-type +(define-primitive-object (double-float :lowtag other-pointer-lowtag :header double-float-type) (filler) (value :c-type "double" :length 2)) #!+long-float -(define-primitive-object (long-float :lowtag other-pointer-type +(define-primitive-object (long-float :lowtag other-pointer-lowtag :header long-float-type) #!+sparc (filler) (value :c-type "long double" :length #!+x86 3 #!+sparc 4)) (define-primitive-object (complex :type complex - :lowtag other-pointer-type + :lowtag other-pointer-lowtag :header complex-type :alloc-trans %make-complex) (real :type real @@ -69,7 +69,7 @@ :ref-trans %imagpart :init :arg)) -(define-primitive-object (array :lowtag other-pointer-type +(define-primitive-object (array :lowtag other-pointer-lowtag :header t) (fill-pointer :type index :ref-trans %array-fill-pointer @@ -104,14 +104,14 @@ (dimensions :rest-p t)) (define-primitive-object (vector :type vector - :lowtag other-pointer-type + :lowtag other-pointer-lowtag :header t) (length :ref-trans sb!c::vector-length :type index) (data :rest-p t :c-type #!-alpha "unsigned long" #!+alpha "u32")) (define-primitive-object (code :type code-component - :lowtag other-pointer-type + :lowtag other-pointer-lowtag :header t) (code-size :type index :ref-known (flushable movable) @@ -130,55 +130,87 @@ (constants :rest-p t)) (define-primitive-object (fdefn :type fdefn - :lowtag other-pointer-type + :lowtag other-pointer-lowtag :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) - #!-gengc (self :ref-trans %function-self :set-trans (setf %function-self)) - #!+gengc (entry-point :c-type "char *") +;;; 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-lowtag + :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 + ;; DEFKNOWN/DEFINE-VOP/DEFTRANSFORM stuff in + ;; compiler/x86/system.lisp to define and declare them by + ;; hand. I don't know why this is, but that's (basically) + ;; the way it was done in CMU CL, and it works. (It's not + ;; exactly the same way it was done in CMU CL in that CMU + ;; CL's allows duplicate DEFKNOWNs, blithely overwriting any + ;; previous data associated with the previous DEFKNOWN, and + ;; that property was used to mask the definitions here. In + ;; SBCL as of 0.6.12.64 that's not allowed -- too confusing! + ;; -- so we have to explicitly suppress the DEFKNOWNish + ;; stuff here in order to allow this old hack to work in the + ;; new world. -- WHN 2001-08-82 + ) (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 %function-type + :ref-trans %simple-fun-type :set-known (unsafe) - :set-trans (setf %function-type)) + :set-trans (setf %simple-fun-type)) (code :rest-p t :c-type "unsigned char")) -#!-gengc -(define-primitive-object (return-pc :lowtag other-pointer-type :header t) +(define-primitive-object (return-pc :lowtag other-pointer-lowtag :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-lowtag :header closure-header-type) - #!-gengc (function :init :arg :ref-trans %closure-function) - #!+gengc (entry-point :c-type "char *") + (fun :init :arg :ref-trans %closure-fun) (info :rest-p t)) (define-primitive-object (funcallable-instance - :lowtag function-pointer-type + :lowtag fun-pointer-lowtag :header funcallable-instance-header-type :alloc-trans %make-funcallable-instance) - #!-gengc - (function - :ref-known (flushable) :ref-trans %funcallable-instance-function - :set-known (unsafe) :set-trans (setf %funcallable-instance-function)) - #!+gengc (entry-point :c-type "char *") + #!-x86 + (fun + :ref-known (flushable) :ref-trans %funcallable-instance-fun + :set-known (unsafe) :set-trans (setf %funcallable-instance-fun)) + #!+x86 + (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-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 + ;; all information associated with the old DEFKNOWN, as before). + ;; It's definitely not very clean, with too many #!+ conditionals and + ;; too little documentation, but I have more urgent things to + ;; clean up right now, so I've just left it as a literal + ;; translation without trying to fix it. -- WHN 2001-08-02 + ) (lexenv :ref-known (flushable) :ref-trans %funcallable-instance-lexenv :set-known (unsafe) :set-trans (setf %funcallable-instance-lexenv)) (layout :init :arg @@ -186,7 +218,7 @@ :set-known (unsafe) :set-trans (setf %funcallable-instance-layout)) (info :rest-p t)) -(define-primitive-object (value-cell :lowtag other-pointer-type +(define-primitive-object (value-cell :lowtag other-pointer-lowtag :header value-cell-header-type :alloc-trans make-value-cell) (value :set-trans value-cell-set @@ -196,19 +228,19 @@ :init :arg)) #!+alpha -(define-primitive-object (sap :lowtag other-pointer-type +(define-primitive-object (sap :lowtag other-pointer-lowtag :header sap-type) (padding) (pointer :c-type "char *" :length 2)) #!-alpha -(define-primitive-object (sap :lowtag other-pointer-type +(define-primitive-object (sap :lowtag other-pointer-lowtag :header sap-type) (pointer :c-type "char *")) (define-primitive-object (weak-pointer :type weak-pointer - :lowtag other-pointer-type + :lowtag other-pointer-lowtag :header weak-pointer-type :alloc-trans make-weak-pointer) (value :ref-trans sb!c::%weak-pointer-value :ref-known (flushable) @@ -245,27 +277,15 @@ ;;;; symbols -#!+gengc -(defknown %make-symbol (index simple-string) symbol - (flushable movable)) - -#!+gengc -(defknown symbol-hash (symbol) index - (flushable movable)) - #!+x86 (defknown symbol-hash (symbol) (integer 0 #.*target-most-positive-fixnum*) (flushable movable)) -(define-primitive-object (symbol :lowtag other-pointer-type +(define-primitive-object (symbol :lowtag other-pointer-lowtag :header symbol-header-type - #!-x86 :alloc-trans - #!-(or gengc x86) make-symbol - #!+gengc %make-symbol) + #!-x86 :alloc-trans #!-x86 make-symbol) (value :set-trans %set-symbol-value :init :unbound) - #!-(or gengc x86) unused - #!+gengc (hash :init :arg) #!+x86 (hash) (plist :ref-trans symbol-plist :set-trans %set-symbol-plist @@ -276,13 +296,13 @@ :init :null)) (define-primitive-object (complex-single-float - :lowtag other-pointer-type + :lowtag other-pointer-lowtag :header complex-single-float-type) (real :c-type "float") (imag :c-type "float")) (define-primitive-object (complex-double-float - :lowtag other-pointer-type + :lowtag other-pointer-lowtag :header complex-double-float-type) (filler) (real :c-type "double" :length 2) @@ -290,7 +310,7 @@ #!+long-float (define-primitive-object (complex-long-float - :lowtag other-pointer-type + :lowtag other-pointer-lowtag :header complex-long-float-type) #!+sparc (filler) (real :c-type "long double" :length #!+x86 3 #!+sparc 4)