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
ac9ab79f
Commit
ac9ab79f
authored
34 years ago
by
wlott
Browse files
Options
Downloads
Patches
Plain Diff
Moved primitive-object and utility functions (fixnum, static-symbol-p, etc)
into seperate files so they can be shared between vms.
parent
d4c29bc2
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
compiler/mips/parms.lisp
+24
-464
24 additions, 464 deletions
compiler/mips/parms.lisp
with
24 additions
and
464 deletions
compiler/mips/parms.lisp
+
24
−
464
View file @
ac9ab79f
;;; -*- Package:
V
M; Log: C.Log -*-
;;; -*- Package: M
IPS
; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
...
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.7
8
1990/1
0/23 02:37:09
wlott Exp $
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.7
9
1990/1
1/03 03:20:53
wlott Exp $
;;;
;;; This file contains some parameterizations of various VM
;;; attributes for the MIPS. This file is separate from other stuff so
...
...
@@ -18,7 +18,10 @@
;;; Converted to MIPS by William Lott.
;;;
(
in-package
"VM"
)
(
in-package
"MIPS"
)
(
use-package
"C"
)
(
export
'
(
word-bits
byte-bits
word-shift
word-bytes
))
(
export
'
(
float-underflow-trap-bit
float-overflow-trap-bit
float-imprecise-trap-bit
float-invalid-trap-bit
...
...
@@ -32,14 +35,25 @@
;;;
(
defconstant
sc-number-limit
32
)
;;; The number of references that a TN must have to offset the overhead of
;;; saving the TN across a call.
;;;
(
defconstant
register-save-penalty
3
)
(
eval-when
(
compile
eval
load
)
(
setf
(
backend-name
*backend*
)
"PMAX"
)
(
setf
(
backend-version
*backend*
)
"DECstation 3100/Mach 0.0"
)
(
setf
(
backend-fasl-file-type
*backend*
)
"mips-fasl"
)
(
setf
(
backend-fasl-file-implementation
*backend*
)
pmax-fasl-file-implementation
)
(
setf
(
backend-fasl-file-version
*backend*
)
1
)
(
setf
(
backend-register-save-penalty
*backend*
)
3
)
(
setf
(
backend-byte-order
*backend*
)
:little-endian
)
)
; eval-when
;;;; Machine Architecture parameters:
(
eval-when
(
compile
load
eval
)
(
defconstant
word-bits
32
"Number of bits per word where a word holds one lisp descriptor."
)
...
...
@@ -52,21 +66,6 @@
(
defconstant
word-bytes
(
/
word-bits
byte-bits
)
"Number of bytes in a word."
)
(
defparameter
target-byte-order
:little-endian
"The byte order of the target machine. Should either be :big-endian
which has the MSB first (RT) or :little-endian which has the MSB last
(VAX)."
)
(
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."
)
;;; ### This should be somewhere else.
#-
new-compiler
(
defconstant
native-byte-order
:big-endian
"The byte order we are running under."
)
(
defconstant
float-sign-shift
31
)
...
...
@@ -92,6 +91,8 @@
(
defconstant
double-float-digits
(
+
(
byte-size
double-float-significand-byte
)
word-bits
1
))
)
; eval-when
;;;; Description of the target address space.
...
...
@@ -101,110 +102,7 @@
(
defparameter
target-static-space-start
#x04000000
)
(
defparameter
target-dynamic-space-start
#x06000000
)
;;;; Type definitions:
(
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."
)
(
defmacro
pad-data-block
(
words
)
`
(
logandc2
(
+
(
ash
,
words
vm:word-shift
)
lowtag-mask
)
lowtag-mask
))
(
defmacro
defenum
((
&key
(
prefix
""
)
(
suffix
""
)
(
start
0
)
(
step
1
))
&rest
identifiers
)
(
let
((
results
nil
)
(
index
0
)
(
start
(
eval
start
))
(
step
(
eval
step
)))
(
dolist
(
id
identifiers
)
(
when
id
(
multiple-value-bind
(
root
docs
)
(
if
(
consp
id
)
(
values
(
car
id
)
(
cdr
id
))
(
values
id
nil
))
(
push
`
(
defconstant
,
(
intern
(
concatenate
'simple-string
(
string
prefix
)
(
string
root
)
(
string
suffix
)))
,
(
+
start
(
*
step
index
))
,@
docs
)
results
)))
(
incf
index
))
`
(
eval-when
(
compile
load
eval
)
,@
(
nreverse
results
))))
;;; 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
)
;;;; Other non-type constants.
...
...
@@ -219,297 +117,6 @@
error
cerror
)
(
defenum
(
:prefix
vector-
:suffix
-subtype
)
normal
structure
valid-hashing
must-rehash
)
;;;; Primitive data objects definition noise.
(
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
)))
(
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
)))))
(
defvar
*primitive-objects*
nil
)
(
defmacro
define-for-each-primitive-object
((
var
)
&body
body
)
`
(
c::expand
`
(
progn
,@
(
remove
nil
(
mapcar
#'
(
lambda
(
,
var
)
,@
body
)
*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
)
(
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
)
...
...
@@ -587,43 +194,6 @@
))
(
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
)))
;;;; 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 doesn't work on negative bignums in the old compiler, but
;; it we #-new-compiler this, the wrong defn will be used when we try
;; to ncompile-file it in the bootstrap env.
(
if
(
minusp
num
)
(
-
(
ash
(
-
num
)
2
))
(
ash
num
2
))
(
error
"~D is too big for a fixnum."
num
)))
;;;; Assembler parameters:
...
...
@@ -635,13 +205,3 @@
;;;; Other parameters:
;;; The number representing the version of fasl files we are going to dump.
;;;
(
defparameter
target-fasl-file-implementation
#.
pmax-fasl-file-implementation
)
(
defparameter
target-fasl-file-version
1
)
(
defparameter
target-fasl-file-type
"mips-fasl"
)
;;; The version string for the implementation dependent code.
;;;
(
defparameter
vm-version
"DECstation 3100/Mach 0.0"
)
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