Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
eecb8c53
Commit
eecb8c53
authored
34 years ago
by
wlott
Browse files
Options
Downloads
Patches
Plain Diff
Initial revision
parent
851571b9
No related branches found
No related tags found
No related merge requests found
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
compiler/generic/objdef.lisp
+414
-0
414 additions, 0 deletions
compiler/generic/objdef.lisp
compiler/generic/primtype.lisp
+254
-0
254 additions, 0 deletions
compiler/generic/primtype.lisp
compiler/generic/utils.lisp
+57
-0
57 additions, 0 deletions
compiler/generic/utils.lisp
with
725 additions
and
0 deletions
compiler/generic/objdef.lisp
0 → 100644
+
414
−
0
View file @
eecb8c53
;;; -*- 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
)
This diff is collapsed.
Click to expand it.
compiler/generic/primtype.lisp
0 → 100644
+
254
−
0
View file @
eecb8c53
;;; -*- 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
)))))
This diff is collapsed.
Click to expand it.
compiler/generic/utils.lisp
0 → 100644
+
57
−
0
View file @
eecb8c53
;;; -*- 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
)))
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment