Skip to content
Snippets Groups Projects
Commit eecb8c53 authored by wlott's avatar wlott
Browse files

Initial revision

parent 851571b9
No related branches found
No related tags found
No related merge requests found
;;; -*- Package: VM; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public
;;; domain. If you want to use this code or any part of CMU Common
;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/objdef.lisp,v 1.1 1990/11/03 03:15:57 wlott Exp $
;;;
;;; This file contains the machine independent aspects of the object
;;; representation.
;;;
;;; Written by William Lott.
;;;
(in-package "VM")
(export '(lowtag-bits lowtag-mask lowtag-limit type-bits type-mask
primitive-object primitive-object-p primitive-object-name
primitive-object-header primitive-object-lowtag
primitive-object-options primitive-object-slots
primitive-object-size primitive-object-variable-length
slot-name slot-docs slot-rest-p slot-offset slot-length
slot-options define-for-each-primitive-object))
;;;; Type based constants:
(eval-when (compile eval load)
(defconstant lowtag-bits 3
"Number of bits at the low end of a pointer used for type information.")
(defconstant lowtag-mask (1- (ash 1 lowtag-bits))
"Mask to extract the low tag bits from a pointer.")
(defconstant lowtag-limit (ash 1 lowtag-bits)
"Exclusive upper bound on the value of the low tag bits from a
pointer.")
(defconstant type-bits 8
"Number of bits used in the header word of a data block for typeing.")
(defconstant type-mask (1- (ash 1 type-bits))
"Mask to extract the type from a header word.")
); eval-when
(defparameter target-most-positive-fixnum (1- (ash 1 29))
"most-positive-fixnum in the target architecture.")
(defparameter target-most-negative-fixnum (ash -1 29)
"most-negative-fixnum in the target architecture.")
;;; The main types. These types are represented by the low three bits of the
;;; pointer or immeditate object.
;;;
(defenum (:suffix -type)
even-fixnum
function-pointer
other-immediate-0
list-pointer
odd-fixnum
structure-pointer
other-immediate-1
other-pointer)
;;; The heap types. Each of these types is in the header of objects in
;;; the heap.
;;;
(defenum (:suffix -type
:start (+ (ash 1 lowtag-bits) other-immediate-0-type)
:step (ash 1 (1- lowtag-bits)))
bignum
ratio
single-float
double-float
complex
simple-array
simple-string
simple-bit-vector
simple-vector
simple-array-unsigned-byte-2
simple-array-unsigned-byte-4
simple-array-unsigned-byte-8
simple-array-unsigned-byte-16
simple-array-unsigned-byte-32
simple-array-single-float
simple-array-double-float
complex-string
complex-bit-vector
complex-vector
complex-array
code-header
function-header
closure-header
funcallable-instance-header
unused-function-header-1
unused-function-header-2
unused-function-header-3
closure-function-header
return-pc-header
value-cell-header
symbol-header
base-character
sap
unbound-marker
weak-pointer
structure-header)
;;; The different vector subtypes.
;;;
(defenum (:prefix vector- :suffix -subtype)
normal
unused
valid-hashing
must-rehash)
;;;; Primitive data objects definition noise.
(eval-when (compile load eval)
(defstruct (slot
(:constructor %make-slot
(name docs rest-p length options)))
(name nil :type symbol)
(docs nil :type (or null simple-string))
(rest-p nil :type (member t nil))
(offset 0 :type fixnum)
(length 1 :type fixnum)
(options nil :type list))
(defun make-slot (name &rest options
&key docs rest-p (length (if rest-p 0 1))
&allow-other-keys)
(remf options :docs)
(remf options :rest-p)
(remf options :length)
(%make-slot name docs rest-p length options))
(defstruct (primitive-object
)
(name nil :type symbol)
(header nil :type symbol)
(lowtag nil :type symbol)
(options nil :type list)
(slots nil :type list)
(size 0 :type fixnum)
(variable-length nil :type (member t nil)))
(defvar *primitive-objects* nil)
); eval-when (compile load eval)
(defmacro define-primitive-object ((name &rest options
&key header lowtag
&allow-other-keys)
&rest slots)
(setf options (copy-list options))
(remf options :header)
(remf options :lowtag)
(let ((prim-obj
(make-primitive-object :name name
:header header
:lowtag lowtag
:options options
:slots (mapcar #'(lambda (slot)
(if (atom slot)
(make-slot slot)
(apply #'make-slot
slot)))
slots))))
(collect ((forms) (exports))
(let ((offset (if (primitive-object-header prim-obj) 1 0))
(variable-length nil))
(dolist (slot (primitive-object-slots prim-obj))
(when variable-length
(error "~S is anything after a :rest-p t slot." slot))
(let* ((rest-p (slot-rest-p slot))
(offset-sym
(intern (concatenate 'simple-string
(string name)
"-"
(string (slot-name slot))
(if rest-p "-OFFSET" "-SLOT")))))
(forms `(defconstant ,offset-sym ,offset
,@(when (slot-docs slot) (list (slot-docs slot)))))
(setf (slot-offset slot) offset)
(exports offset-sym)
(incf offset (slot-length slot))
(when rest-p (setf variable-length t))))
(setf (primitive-object-variable-length prim-obj) variable-length)
(unless variable-length
(let ((size (intern (concatenate 'simple-string
(string name)
"-SIZE"))))
(forms `(defconstant ,size ,offset
,(format nil
"Number of slots used by each ~S~
~@[~* including the header~]."
name header)))
(exports size)))
(setf (primitive-object-size prim-obj) offset))
`(eval-when (compile load eval)
(setf *primitive-objects*
(cons ',prim-obj
(delete ',name *primitive-objects*
:key #'primitive-object-name)))
(export ',(exports))
,@(forms)))))
(defmacro define-for-each-primitive-object ((var) &body body)
(let ((name (gensym)))
`(macrolet ((,name (,var) ,@body))
,@(mapcar #'(lambda (x)
`(,name ,x))
*primitive-objects*))))
;;;; The primitive objects themselves.
(define-primitive-object (cons :lowtag list-pointer-type
:alloc-trans cons)
(car :ref-vop car :ref-trans car
:setf-vop c::set-car :set-trans c::%rplaca
:init :arg)
(cdr :ref-vop cdr :ref-trans cdr
:setf-vop c::set-cdr :set-trans c::%rplacd
:init :arg))
(define-primitive-object (bignum :lowtag other-pointer-type
:header bignum-type
:alloc-trans bignum::%allocate-bignum)
(digits :rest-p t :c-type "long"))
(define-primitive-object (ratio :lowtag other-pointer-type
:header ratio-type
:alloc-vop c::make-ratio
:alloc-trans %make-ratio)
(numerator :ref-vop numerator :init :arg)
(denominator :ref-vop denominator :init :arg))
(define-primitive-object (single-float :lowtag other-pointer-type
:header single-float-type)
(value :c-type "float"))
(define-primitive-object (double-float :lowtag other-pointer-type
:header double-float-type)
(filler)
(value :c-type "double" :length 2))
(define-primitive-object (complex :lowtag other-pointer-type
:header complex-type
:alloc-vop c::make-complex
:alloc-trans %make-complex)
(real :ref-vop realpart :init :arg)
(imag :ref-vop imagpart :init :arg))
(define-primitive-object (array :lowtag other-pointer-type
:header t)
(fill-pointer :type index
:ref-trans %array-fill-pointer
:ref-known (c::flushable c::foldable)
:set-trans (setf %array-fill-pointer)
:set-known (c::unsafe))
(fill-pointer-p :type (member t nil)
:ref-trans %array-fill-pointer-p
:ref-known (c::flushable c::foldable)
:set-trans (setf %array-fill-pointer-p)
:set-known (c::unsafe))
(elements :type index
:ref-trans %array-available-elements
:ref-known (c::flushable c::foldable)
:set-trans (setf %array-available-elements)
:set-known (c::unsafe))
(data :type array
:ref-trans %array-data-vector
:ref-known (c::flushable c::foldable)
:set-trans (setf %array-data-vector)
:set-known (c::unsafe))
(displacement :type (or index null)
:ref-trans %array-displacement
:ref-known (c::flushable c::foldable)
:set-trans (setf %array-displacement)
:set-known (c::unsafe))
(displaced-p :type (member t nil)
:ref-trans %array-displaced-p
:ref-known (c::flushable c::foldable)
:set-trans (setf %array-displaced-p)
:set-known (c::unsafe))
(dimensions :rest-p t))
(define-primitive-object (vector :lowtag other-pointer-type :header t)
(length :ref-trans c::vector-length
:type index
:ref-known (c::flushable c::foldable))
(data :rest-p t :c-type "unsigned long"))
(define-primitive-object (code :lowtag other-pointer-type :header t)
(code-size :ref-vop c::code-code-size)
(entry-points :ref-vop c::code-entry-points
:set-vop c::set-code-entry-points)
(debug-info :type t
:ref-trans di::code-debug-info
:ref-known (c::flushable)
:set-vop c::set-code-debug-info)
(constants :rest-p t))
(define-primitive-object (function-header :lowtag function-pointer-type
:header function-header-type)
(self :ref-vop c::function-self :set-vop c::set-function-self)
(next :ref-vop c::function-next :set-vop c::set-function-next)
(name :ref-vop c::function-name
:ref-known (c::flushable)
:ref-trans %function-header-name
:set-vop c::set-function-name)
(arglist :ref-vop c::function-arglist
:ref-known (c::flushable)
:ref-trans lisp::%function-header-arglist
:set-vop c::set-function-arglist)
(type :ref-vop c::function-type
:ref-known (c::flushable)
:ref-trans lisp::%function-header-type
:set-vop c::set-function-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
:header closure-header-type
:alloc-vop c::make-closure)
(function :init :arg
:ref-vop c::closure-function
:ref-known (c::flushable)
:ref-trans %closure-function)
(info :rest-p t :set-vop c::closure-init :ref-vop c::closure-ref))
(define-primitive-object (value-cell :lowtag other-pointer-type
:header value-cell-header-type
:alloc-vop c::make-value-cell)
(value :set-vop c::value-cell-set
:ref-vop c::value-cell-ref
:init :arg))
(define-primitive-object (symbol :lowtag other-pointer-type
:header symbol-header-type)
(value :set-trans set
:setf-vop set)
(function)
(raw-function-addr :c-type "char *")
(setf-function)
(plist :ref-trans symbol-plist
:setf-vop c::set-symbol-plist
:set-trans c::%sp-set-plist)
(name :ref-trans symbol-name)
(package :ref-trans symbol-package
:setf-vop c::set-package))
(define-primitive-object (sap :lowtag other-pointer-type
:header sap-type)
(pointer :c-type "char *"))
(define-primitive-object (weak-pointer :lowtag other-pointer-type
:header weak-pointer-type
:alloc-trans c::%make-weak-pointer)
(value :ref-trans c::%weak-pointer-value
:ref-known (c::flushable)
:set-trans (setf c::%weak-pointer-value)
:set-known (c::unsafe)
:init :arg)
(broken :ref-trans c::%weak-pointer-broken
:ref-known (c::flushable)
:set-trans (setf c::%weak-pointer-broken)
:set-known (c::unsafe)
:init :arg)
(next :c-type "struct weak_pointer *"))
;;; Other non-heap data blocks.
(define-primitive-object (binding)
value
symbol)
(define-primitive-object (unwind-block)
(current-uwp :c-type "struct unwind_block *")
(current-cont :c-type "lispobj *")
current-code
entry-pc)
(define-primitive-object (catch-block)
(current-uwp :c-type "struct unwind_block *")
(current-cont :c-type "lispobj *")
current-code
entry-pc
tag
(previous-catch :c-type "struct catch_block *")
size)
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public
;;; domain. If you want to use this code or any part of CMU Common
;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/primtype.lisp,v 1.1 1990/11/03 03:16:46 wlott Exp $
;;;
;;; This file contains the machine independent aspects of the object
;;; representation and primitive types.
;;;
;;; Written by William Lott.
;;;
(in-package "VM")
;;;; Primitive Type Definitions
;;; *Anything*
;;;
(def-primitive-type t (descriptor-reg))
(setf (backend-any-primitive-type *backend*) (primitive-type-or-lose 't))
;;; Primitive integer types that fit in registers.
;;;
(def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
:type (unsigned-byte 29))
(def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
:type (unsigned-byte 31))
(def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
:type (unsigned-byte 32))
(def-primitive-type fixnum (any-reg signed-reg)
:type (signed-byte 30))
(def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
:type (signed-byte 32))
(defvar *fixnum-primitive-type* (primitive-type-or-lose 'fixnum))
(def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
(def-primitive-type-alias unsigned-num (:or unsigned-byte-32
unsigned-byte-31
positive-fixnum))
(def-primitive-type-alias signed-num (:or signed-byte-32
fixnum
unsigned-byte-31
positive-fixnum))
;;; Other primitive immediate types.
(def-primitive-type base-character (base-character-reg any-reg))
;;; Primitive pointer types.
;;;
(def-primitive-type function (descriptor-reg))
(def-primitive-type list (descriptor-reg))
(def-primitive-type structure (descriptor-reg))
;;; Primitive other-pointer number types.
;;;
(def-primitive-type bignum (descriptor-reg))
(def-primitive-type ratio (descriptor-reg))
(def-primitive-type complex (descriptor-reg))
(def-primitive-type single-float (single-reg descriptor-reg))
(def-primitive-type double-float (double-reg descriptor-reg))
;;; Primitive other-pointer array types.
;;;
(def-primitive-type simple-string (descriptor-reg) :type simple-base-string)
(def-primitive-type simple-bit-vector (descriptor-reg))
(def-primitive-type simple-vector (descriptor-reg))
(def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg)
:type (simple-array (unsigned-byte 2) (*)))
(def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg)
:type (simple-array (unsigned-byte 4) (*)))
(def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg)
:type (simple-array (unsigned-byte 8) (*)))
(def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg)
:type (simple-array (unsigned-byte 16) (*)))
(def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg)
:type (simple-array (unsigned-byte 32) (*)))
(def-primitive-type simple-array-single-float (descriptor-reg)
:type (simple-array single-float (*)))
(def-primitive-type simple-array-double-float (descriptor-reg)
:type (simple-array double-float (*)))
;;; Note: The complex array types are not inclueded, 'cause it is pointless to
;;; restrict VOPs to them.
;;; Other primitive other-pointer types.
;;;
(def-primitive-type system-area-pointer (sap-reg descriptor-reg))
(def-primitive-type weak-pointer (descriptor-reg))
;;; Random primitive types that don't exist at the LISP level.
;;;
(def-primitive-type random (non-descriptor-reg) :type nil)
(def-primitive-type interior (interior-reg) :type nil)
(def-primitive-type catch-block (catch-block) :type nil)
;;;; Primitive-type-of and friends.
;;; Primitive-Type-Of -- Interface
;;;
;;; Return the most restrictive primitive type that contains Object.
;;;
(def-vm-support-routine primitive-type-of (object)
(let ((type (ctype-of object)))
(cond ((not (member-type-p type)) (primitive-type type))
((equal (member-type-members type) '(nil))
(primitive-type-or-lose 'list))
(t
*any-primitive-type*))))
;;;
(defvar *simple-array-primitive-types*
'((base-character . simple-string)
(string-char . simple-string)
(bit . simple-bit-vector)
((unsigned-byte 2) . simple-array-unsigned-byte-2)
((unsigned-byte 4) . simple-array-unsigned-byte-4)
((unsigned-byte 8) . simple-array-unsigned-byte-8)
((unsigned-byte 16) . simple-array-unsigned-byte-16)
((unsigned-byte 32) . simple-array-unsigned-byte-32)
(single-float . simple-array-single-float)
(double-float . simple-array-double-float)
(t . simple-vector))
"An a-list for mapping simple array element types to their
corresponding primitive types.")
;;; Return the primitive type corresponding to a type descriptor
;;; structure. The second value is true when the primitive type is
;;; exactly equivalent to the argument Lisp type.
;;;
;;; In a bootstrapping situation, we should be careful to use the
;;; correct values for the system parameters.
;;;
;;; We need an aux function because we need to use both def-vm-support-routine
;;; and defun-cached.
;;;
(def-vm-support-routine primitive-type (type)
(primitive-type-aux type))
;;;
(defun-cached (primitive-type-aux
:hash-function (lambda (x)
(logand (cache-hash-eq x) #x1FF))
:hash-bits 9
:values 2
:default (values nil :empty))
((type eq))
(declare (type ctype type))
(macrolet ((any () '(values *any-primitive-type* nil))
(exactly (type) `(values (primitive-type-or-lose ',type) t))
(part-of (type) `(values (primitive-type-or-lose ',type) nil)))
(etypecase type
(numeric-type
(let ((lo (numeric-type-low type))
(hi (numeric-type-high type)))
(case (numeric-type-complexp type)
(:real
(case (numeric-type-class type)
(integer
(cond ((and hi lo)
(dolist (spec
'((positive-fixnum 0 #.(1- (ash 1 29)))
(unsigned-byte-31 0 #.(1- (ash 1 31)))
(unsigned-byte-32 0 #.(1- (ash 1 32)))
(fixnum #.(ash -1 29) #.(1- (ash 1 29)))
(signed-byte-32 #.(ash -1 31)
#.(1- (ash 1 31))))
(if (or (< hi (ash -1 29))
(> lo (1- (ash 1 29))))
(part-of bignum)
(any)))
(let ((type (car spec))
(min (cadr spec))
(max (caddr spec)))
(when (<= min lo hi max)
(return (values (primitive-type-or-lose type)
(and (= lo min) (= hi max))))))))
((or (and hi (< hi most-negative-fixnum))
(and lo (> lo most-positive-fixnum)))
(part-of bignum))
(t
(any))))
(float
(let ((exact (and (null lo) (null hi))))
(case (numeric-type-format type)
((short-float single-float)
(values (primitive-type-or-lose 'single-float) exact))
((double-float long-float)
(values (primitive-type-or-lose 'double-float) exact))
(t
(any)))))
(t
(any))))
(:complex
(part-of complex))
(t
(any)))))
(array-type
(if (array-type-complexp type)
(any)
(let* ((dims (array-type-dimensions type))
(etype (array-type-specialized-element-type type))
(type-spec (type-specifier etype))
(ptype (cdr (assoc type-spec *simple-array-primitive-types*
:test #'equal))))
(if (and (consp dims) (null (rest dims)) ptype)
(values (primitive-type-or-lose ptype) (eq (first dims) '*))
(any)))))
(union-type
(if (type= type (specifier-type 'list))
(exactly list)
(let ((types (union-type-types type)))
(multiple-value-bind (res exact)
(primitive-type (first types))
(dolist (type (rest types) (values res exact))
(multiple-value-bind (ptype ptype-exact)
(primitive-type type)
(unless ptype-exact (setq exact nil))
(unless (eq ptype res)
(return (any)))))))))
(member-type
(let* ((members (member-type-members type))
(res (primitive-type-of (first members))))
(dolist (mem (rest members) (values res nil))
(unless (eq (primitive-type-of mem) res)
(return (values *any-primitive-type* nil))))))
(named-type
(case (named-type-name type)
((t bignum ratio complex function structure
system-area-pointer weak-pointer)
(values (primitive-type-or-lose (named-type-name type)) t))
((character base-character string-char)
(exactly base-character))
(standard-char
(part-of base-character))
(cons
(part-of list))
(t
(any))))
(function-type
(exactly function))
(structure-type
(part-of structure))
(ctype
(any)))))
;;; -*- Package: VM; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/utils.lisp,v 1.1 1990/11/03 03:17:32 wlott Exp $
;;;
;;; Utility functions needed by the back end to generate code.
;;;
;;; Written by William Lott.
;;;
(in-package "VM")
(export '(fixnum static-symbol-p static-symbol-offset offset-static-symbol))
;;;; Handy routine for making fixnums:
(defun fixnum (num)
"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)))
;;;; Routines for dealing with static symbols.
(defun static-symbol-p (symbol)
(member symbol static-symbols))
(defun static-symbol-offset (symbol)
"Returns the byte offset of the static symbol Symbol."
(let ((posn (position symbol static-symbols)))
(unless posn (error "~S is not a static symbol." symbol))
(+ (* posn (pad-data-block symbol-size))
(pad-data-block (1- symbol-size))
other-pointer-type
(- list-pointer-type))))
(defun offset-static-symbol (offset)
"Given a byte offset, Offset, returns the appropriate static symbol."
(multiple-value-bind
(n rem)
(truncate (+ offset list-pointer-type (- other-pointer-type)
(- (pad-data-block (1- symbol-size))))
(pad-data-block symbol-size))
(unless (and (zerop rem) (<= 0 n (1- (length static-symbols))))
(error "Byte offset, ~D, is not correct." offset))
(elt static-symbols n)))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment