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
a332872f
Commit
a332872f
authored
31 years ago
by
wlott
Browse files
Options
Downloads
Patches
Plain Diff
Initial revision
parent
2624da01
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/generic/gengc-genesis.lisp
+2341
-0
2341 additions, 0 deletions
compiler/generic/gengc-genesis.lisp
with
2341 additions
and
0 deletions
compiler/generic/gengc-genesis.lisp
0 → 100644
+
2341
−
0
View file @
a332872f
;;; -*- Package: Lisp -*-
;;; **********************************************************************
;;; 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 or slisp-group@cs.cmu.edu.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/gengc-genesis.lisp,v 1.1 1993/05/07 07:25:58 wlott Exp $"
)
;;;
;;; **********************************************************************
;;;
;;; Core image builder for CMU Common Lisp.
;;;
;;; Written by Skef Wholey. Package hackery courtesy of Rob MacLachlan.
;;;
;;; Completely Rewritten by William Lott for MIPS port.
;;;
(
in-package
"LISP"
)
(
defmacro
round-up
(
num
size
)
"Rounds number up to be an integral multiple of size."
(
let
((
size-var
(
gensym
)))
`
(
let
((
,
size-var
,
size
))
(
*
,
size-var
(
ceiling
,
num
,
size-var
)))))
;;;; Addresses
(
deftype
address
()
`
(
unsigned-byte
,
vm:word-bits
))
(
defconstant
null-address
0
)
;;;; Block allocator.
(
defconstant
block-shift
16
)
(
defconstant
block-bytes
(
ash
1
block-shift
))
(
defconstant
block-words
(
truncate
block-bytes
vm:word-bytes
))
(
defparameter
*heap-start*
#x01000000
)
(
defvar
*heap-free-pointer*
)
(
defvar
*allocations*
)
(
defun
allocate-blocks
(
n
)
(
declare
(
type
index
n
)
(
values
address
system-area-pointer
))
(
let*
((
free-ptr
*heap-free-pointer*
)
(
bytes
(
*
n
block-bytes
))
(
sap
(
system:allocate-system-memory
bytes
)))
(
setf
*heap-free-pointer*
(
+
free-ptr
bytes
))
(
push
(
cons
sap
bytes
)
*allocations*
)
(
values
free-ptr
sap
)))
(
defun
free-allocations
()
(
dolist
(
allocation
*allocations*
)
(
system:deallocate-system-memory
(
car
allocation
)
(
cdr
allocation
))))
(
defmacro
with-allocation-pool
(
&body
body
)
`
(
let
((
*heap-free-pointer*
*heap-start*
)
(
*allocations*
nil
))
(
unwind-protect
(
progn
,@
body
)
(
free-allocations
))))
(
defvar
*block-owners*
)
(
defun
set-address-owner
(
address
blocks
owner
)
(
let*
((
start
(
truncate
(
-
address
*heap-start*
)
block-bytes
))
(
end
(
+
start
blocks
))
(
owners
*block-owners*
)
(
length
(
length
owners
)))
(
when
(
<
length
end
)
(
do
((
new-length
length
(
ash
new-length
2
)))
((
<=
end
new-length
)
(
setf
owners
(
adjust-array
owners
new-length
:initial-element
nil
))
(
setf
*block-owners*
owners
))))
(
do
((
index
start
(
1+
index
)))
((
=
index
end
))
(
assert
(
null
(
aref
owners
index
)))
(
setf
(
aref
owners
index
)
owner
))))
(
defun
address-owner
(
address
)
(
declare
(
type
address
address
))
(
let
((
index
(
truncate
(
-
address
*heap-start*
)
block-bytes
))
(
owners
*block-owners*
))
(
if
(
and
(
<=
0
index
)
(
<
index
(
length
owners
)))
(
aref
owners
index
)
nil
)))
;;;; Generation representation.
(
defconstant
gen-default-policy
0
)
(
defconstant
gen-tenure-policy
1
)
(
defstruct
(
generation
(
:constructor
%make-generation
(
num
policy
))
(
:print-function
%print-generation
))
;;
;; The generation number for this generation. 0 is the youngest.
(
num
0
:type
index
)
;;
;; The policy number for this generation.
(
policy
0
:type
index
)
;;
;; List of all the steps allocated for this generation.
(
steps
nil
:type
list
)
;;
;; Hash table holding all addresses that (might) hold pointers to younger
;; generations.
(
remset
(
make-hash-table
:test
#'
eql
)
:type
hash-table
))
(
defun
%print-generation
(
gen
stream
depth
)
(
declare
(
ignore
depth
))
(
print-unreadable-object
(
gen
stream
:type
t
)
(
format
stream
"~D"
(
generation-num
gen
))))
(
defun
make-generation
(
num
policy
)
(
%make-generation
num
policy
))
(
defun
make-generations
(
&rest
policies
)
(
loop
for
policy
in
policies
for
num
from
0
collect
(
make-generation
num
policy
)))
(
defun
add-remset-entry
(
generation
address
)
(
declare
(
type
generation
generation
)
(
type
address
address
))
(
setf
(
gethash
address
(
generation-remset
generation
))
t
))
;;;; Step representation.
;;; Initially there are two generations, one for static stuff and one for
;;; dynamic stuff. Each generation has only one step.
(
defvar
*static*
)
(
defvar
*dynamic*
)
(
defstruct
(
block
(
:print-function
%print-block
))
;;
;; The step this block belongs to.
(
step
(
required-argument
)
:type
step
)
;;
;; The address this block starts at.
(
base
0
:type
address
)
;;
;; Pointer to the memory actually backing this block.
(
sap
(
required-argument
)
:type
system-area-pointer
)
;;
;; Offset (in bytes) into the block were the next allocation goes.
(
free
0
:type
index
)
;;
;; Number of words remaining in this block.
(
remaining
block-words
:type
index
)
;;
;; The next block allocated to this step.
(
next
nil
:type
(
or
null
block
)))
(
defun
%print-block
(
block
stream
depth
)
(
declare
(
ignore
depth
))
(
print-unreadable-object
(
block
stream
:type
t
)
(
format
stream
"at #x~8,'0X"
(
block-base
block
))))
(
defconstant
step-default-policy
0
)
(
defconstant
step-tenure-policy
1
)
(
defstruct
(
step
(
:constructor
%make-step
(
num
policy
gen
))
(
:print-function
%print-step
))
;;
;; The number for this step.
(
num
0
:type
index
)
;;
;; The policy number for this step.
(
policy
0
:type
index
)
;;
;; The generation this step is part of.
(
gen
(
required-argument
)
:type
generation
)
;;
;; Chain of blocks allocated to this step.
(
block
nil
:type
(
or
null
block
))
;;
;; Address of the first and last large object in this step.
(
first-LO
null-address
:type
address
)
(
last-LO
null-address
:type
address
)
;;
;; SAP pointing to the region_header for the last large object in this step.
(
last-LO-sap
nil
:type
(
or
null
system-area-pointer
)))
(
defun
%print-step
(
step
stream
depth
)
(
declare
(
ignore
depth
))
(
print-unreadable-object
(
step
stream
:type
t
)
(
format
stream
"~D"
(
step-num
step
))))
(
defun
make-step
(
num
policy
gen
)
(
let
((
step
(
%make-step
num
policy
gen
)))
(
push
step
(
generation-steps
gen
))
step
))
(
defun
alloc-small-object
(
words
step
)
(
let
((
padded
(
logandc2
(
1+
words
)
1
))
(
block
(
step-block
step
)))
(
assert
(
<=
padded
block-words
))
(
when
(
or
(
null
block
)
(
<
(
block-remaining
block
)
padded
))
(
multiple-value-bind
(
addr
sap
)
(
allocate-blocks
1
)
(
setf
block
(
make-block
:step
step
:base
addr
:sap
sap
:next
block
))
(
set-address-owner
addr
1
block
)
(
setf
(
step-block
step
)
block
)))
(
let
((
offset
(
block-free
block
)))
(
setf
(
block-free
block
)
(
+
offset
(
*
padded
vm:word-bytes
)))
(
decf
(
block-remaining
block
)
padded
)
(
values
(
+
(
block-base
block
)
offset
)
(
sap+
(
block-sap
block
)
offset
)))))
;;;; Large object stuff
(
defstruct
(
cluster
(
:print-function
%print-cluster
))
;;
;; Number of blocks in this cluster.
(
blocks
0
:type
index
)
;;
;; Address of the start of this cluster.
(
base
(
required-argument
)
:type
address
)
;;
;; Pointer to the memory backing this cluster.
(
sap
(
required-argument
)
:type
system-area-pointer
)
;;
;; Address of the first header in this cluster.
(
first
(
required-argument
)
:type
address
)
;;
;; Offset (in bytes) into the cluster were the next allocation goes.
(
free
0
:type
index
)
;;
;; Number of words remaining in this cluster.
(
remaining
0
:type
index
)
;;
;; The next cluster in the chain of clusters.
(
next
nil
:type
(
or
null
cluster
)))
(
defun
%print-cluster
(
cluster
stream
depth
)
(
declare
(
ignore
depth
))
(
print-unreadable-object
(
cluster
stream
:type
t
)
(
format
stream
"of ~D blocks at #x~8,'0X"
(
cluster-blocks
cluster
)
(
cluster-base
cluster
))))
(
defvar
*current-los-cluster*
)
;;; LOS-OBJECT-WORD-OVERHEAD -- number of words extra we have to pre-pend
;;; to each large object.
;;;
(
defconstant
los-object-word-overhead
6
)
;;; LOS-HEADER-mumble-OFFSET -- byte offset of the various slots in the
;;; large-object header.
;;;
(
defconstant
los-header-longs-offset
0
)
(
defconstant
los-header-step-offset
4
)
(
defconstant
los-header-prev-offset
8
)
(
defconstant
los-header-next-offset
12
)
;;; LOS-OBJECT-MINIMUM-SIZE -- minimum number of words that a large object
;;; can be. Objects smaller then this must be padded out to this. Includes
;;; the los-object-word-overhead.
;;;
(
defconstant
los-object-minimum-size
128
)
;;; LOS-REGION-ALIGNMENT -- word alignment for regions (object + overhead) in
;;; the large object store.
;;;
(
defconstant
los-region-alignment
2
)
;;; MIN-CLUSTER-BLOCKS -- minimum number of blocks to allocate per cluster.
;;;
(
defconstant
min-cluster-blocks
4
)
;;; LOS-CLUSTER-BYTE-OVERHEAD -- number of bytes needs for the cluster
;;; header.
;;;
(
defconstant
los-cluster-byte-overhead
(
*
vm:word-bytes
3
))
;;; LOS-CHUNK-BYTES -- number of bytes per los chunk.
;;;
(
defconstant
los-chunk-bytes
(
ash
1
9
))
;;; LOS-CHUNK-BYTE-OVERHEAD -- number of bytes overhead needed in the
;;; cluster per chuck.
;;;
(
defconstant
los-chunk-byte-overhead
1
)
;;; CLUSTER-START-ALIGNMENT -- Alignment restriction for the first object
;;; in the cluster. Must be at least the largest page size for any system.
;;;
(
defconstant
cluster-start-alignment
(
ash
1
13
))
(
defun
alloc-large-object
(
words
step
)
(
declare
(
type
index
words
)
(
values
address
system-area-pointer
))
(
let
((
padded
(
max
(
round-up
(
+
los-object-word-overhead
words
)
los-region-alignment
)
los-object-minimum-size
))
(
cluster
*current-los-cluster*
))
(
when
(
or
(
null
cluster
)
(
>
padded
(
cluster-remaining
cluster
)))
;; Figure out how many blocks to actually allocate.
(
iterate
repeat
((
blocks
(
max
(
ceiling
padded
block-words
)
min-cluster-blocks
)))
(
let*
((
bytes
(
*
blocks
block-bytes
))
(
chunks
(
ceiling
bytes
los-chunk-bytes
))
(
overhead
(
round-up
(
+
los-cluster-byte-overhead
(
*
chunks
los-chunk-byte-overhead
))
cluster-start-alignment
)))
(
if
(
>
(
-
bytes
overhead
)
(
*
padded
vm:word-bytes
))
(
multiple-value-bind
(
addr
sap
)
(
allocate-blocks
blocks
)
(
setf
cluster
(
make-cluster
:blocks
blocks
:base
addr
:sap
sap
:first
(
+
addr
overhead
)
:free
overhead
:remaining
(
truncate
(
-
bytes
overhead
)
vm:word-bytes
)
:next
cluster
))
(
set-address-owner
addr
blocks
cluster
)
(
setf
*current-los-cluster*
cluster
))
(
repeat
(
1+
blocks
))))))
(
let*
((
offset
(
cluster-free
cluster
))
(
addr
(
+
(
cluster-base
cluster
)
offset
))
(
sap
(
sap+
(
cluster-sap
cluster
)
offset
)))
(
setf
(
cluster-free
cluster
)
(
+
offset
(
*
padded
vm:word-bytes
)))
(
decf
(
cluster-remaining
cluster
)
padded
)
;; Fill in the length.
(
setf
(
sap-ref-32
sap
los-header-longs-offset
)
(
maybe-byte-swap
padded
))
;; Fill in the step with some random non-zero value.
(
setf
(
sap-ref-32
sap
los-header-step-offset
)
(
maybe-byte-swap
1
))
;; Grab the previous large object in this step.
(
let
((
last
(
step-last-LO-sap
step
)))
(
cond
(
last
;; Set our prev link to point to him.
(
setf
(
sap-ref-32
sap
los-header-prev-offset
)
(
maybe-byte-swap
(
step-last-LO
step
)))
;; And his next link to point to us.
(
setf
(
sap-ref-32
last
los-header-next-offset
)
(
maybe-byte-swap
addr
)))
(
t
;; Set out prev link to NULL.
(
setf
(
sap-ref-32
sap
los-header-prev-offset
)
(
maybe-byte-swap
null-address
))
;; And record the fact that we are the first.
(
setf
(
step-first-LO
step
)
addr
))))
;; Set our next link to NULL.
(
setf
(
sap-ref-32
sap
los-header-next-offset
)
(
maybe-byte-swap
null-address
))
;; Record us as the last LO in this step.
(
setf
(
step-last-LO
step
)
addr
)
(
setf
(
step-last-LO-sap
step
)
sap
)
;; Return pointers just past the header.
(
values
(
+
addr
(
*
los-object-word-overhead
vm:word-bytes
))
(
sap+
sap
(
*
los-object-word-overhead
vm:word-bytes
))))))
;;;; Descriptors.
(
defstruct
(
descriptor
(
:constructor
make-random-descriptor
(
bits
))
(
:constructor
make-pointer-descriptor
(
bits
%sap
step
))
(
:print-function
%print-descriptor
))
;;
;; The actual bits of this descriptor.
(
bits
(
required-argument
)
:type
address
)
;;
;; A sap pointing to the memory backing this object if it is heap allocated,
;; or :LOAD-TIME-COOKIE if references to this descriptor need to be fixed
;; up a load time. NIL until known.
(
%sap
nil
:type
(
or
null
system-area-pointer
(
member
:load-time-cookie
)))
;;
;; The step this object is part of, NIL if unknown or immediate.
(
step
nil
:type
(
or
null
step
)))
(
defun
%print-descriptor
(
des
stream
depth
)
(
declare
(
ignore
depth
))
(
let
((
bits
(
descriptor-bits
des
))
(
sap
(
descriptor-%sap
des
)))
(
if
(
eq
sap
:load-time-cookie
)
(
print-unreadable-object
(
des
stream
)
(
format
stream
"load-time-cookie ~D"
bits
))
(
if
(
logbitp
0
bits
)
(
print-unreadable-object
(
des
stream
)
(
format
stream
"pointer: #x~8,'0X"
bits
))
(
if
(
logbitp
1
bits
)
(
print-unreadable-object
(
des
stream
)
(
format
stream
"other immediate: #x~X, type #b~8,'0B"
(
ash
bits
(
-
vm:type-bits
))
(
logand
bits
vm:type-mask
)))
(
print-unreadable-object
(
des
stream
)
(
format
stream
"fixnum: ~D"
(
let
((
unsigned
(
ash
bits
-2
)))
(
if
(
logbitp
29
unsigned
)
(
logior
(
ash
-1
30
)
unsigned
)
unsigned
)))))))))
(
defun
descriptor-sap
(
des
)
(
declare
(
type
descriptor
des
))
(
let
((
sap
(
descriptor-%sap
des
)))
(
case
sap
((
nil
)
(
let*
((
addr
(
logandc2
(
descriptor-bits
des
)
vm:lowtag-mask
))
(
owner
(
address-owner
addr
)))
(
multiple-value-bind
(
base
base-sap
step
)
(
etypecase
owner
(
block
(
values
(
block-base
owner
)
(
block-sap
owner
)
(
block-step
owner
)))
(
cluster
(
values
(
cluster-base
owner
)
(
cluster-sap
owner
)
nil
)))
(
setf
(
descriptor-step
des
)
step
)
(
setf
(
descriptor-%sap
des
)
(
sap+
base-sap
(
-
addr
base
))))))
(
:load-time-cookie
(
error
"Values computed at load time cannot be used as addresses: ~S"
des
))
(
t
sap
))))
(
defun
allocate-descriptor
(
step
words
lowtag
force-large
)
(
declare
(
type
step
step
)
(
type
index
words
)
(
type
(
unsigned-byte
#.
vm:lowtag-bits
)
lowtag
)
(
type
(
member
t
nil
)
force-large
))
(
multiple-value-bind
(
addr
sap
)
(
if
(
or
force-large
(
>=
words
vm:large-object-cutoff
))
(
alloc-large-object
words
step
)
(
alloc-small-object
words
step
))
(
make-pointer-descriptor
(
logior
addr
lowtag
)
sap
step
)))
(
declaim
(
inline
descriptor-lowtag
))
(
defun
descriptor-lowtag
(
des
)
"Return the lowtag bits for DES."
(
logand
(
descriptor-bits
des
)
vm:lowtag-mask
))
(
defun
make-fixnum-descriptor
(
num
)
(
when
(
>=
(
integer-length
num
)
(
1+
(
-
vm:word-bits
vm:lowtag-bits
)))
(
error
"~D is too big for a fixnum."
num
))
(
make-random-descriptor
(
ash
num
(
1-
vm:lowtag-bits
))))
(
defun
make-other-immediate-descriptor
(
data
type
)
(
make-random-descriptor
(
logior
(
ash
data
vm:type-bits
)
type
)))
(
defun
make-character-descriptor
(
data
)
(
make-other-immediate-descriptor
data
vm:base-char-type
))
(
defun
descriptor-beyond
(
des
offset
type
)
(
make-pointer-descriptor
(
logior
(
+
(
logandc2
(
descriptor-bits
des
)
vm:lowtag-mask
)
offset
)
type
)
(
sap+
(
descriptor-sap
des
)
offset
)
(
descriptor-step
des
)))
;;;; Random variables and other noise.
(
defparameter
unbound-marker
(
make-other-immediate-descriptor
0
vm:unbound-marker-type
)
"Handle on the trap object."
)
(
defvar
*nil-descriptor*
nil
"Handle on Nil."
)
(
defvar
*current-init-functions-cons*
nil
"Head of list of functions to be called when the Lisp starts up."
)
(
defvar
*in-cold-load*
nil
"Used by normal loader."
)
;;;; Stuff to read and write the core memory.
(
defun
maybe-byte-swap
(
word
)
(
declare
(
type
(
unsigned-byte
32
)
word
))
(
assert
(
=
vm:word-bits
32
))
(
assert
(
=
vm:byte-bits
8
))
(
if
(
eq
(
c:backend-byte-order
c:*native-backend*
)
(
c:backend-byte-order
c:*backend*
))
word
(
logior
(
ash
(
ldb
(
byte
8
0
)
word
)
24
)
(
ash
(
ldb
(
byte
8
8
)
word
)
16
)
(
ash
(
ldb
(
byte
8
16
)
word
)
8
)
(
ldb
(
byte
8
24
)
word
))))
(
defun
maybe-byte-swap-short
(
short
)
(
declare
(
type
(
unsigned-byte
16
)
short
))
(
assert
(
=
vm:word-bits
32
))
(
assert
(
=
vm:byte-bits
8
))
(
if
(
eq
(
c:backend-byte-order
c:*native-backend*
)
(
c:backend-byte-order
c:*backend*
))
short
(
logior
(
ash
(
ldb
(
byte
8
0
)
short
)
8
)
(
ldb
(
byte
8
8
)
short
))))
(
defun
write-bits
(
address
index
bits
)
(
declare
(
type
descriptor
address
)
(
type
index
index
)
(
type
(
unsigned-byte
#.
vm:word-bits
)
bits
))
(
setf
(
sap-ref-32
(
descriptor-sap
address
)
(
ash
index
vm:word-shift
))
(
maybe-byte-swap
bits
)))
(
defun
write-descriptor
(
address
index
value
&key
(
remember
:slot
))
"Write VALUE (a descriptor) INDEX words from ADDRESS (also a descriptor)."
(
declare
(
type
descriptor
address
value
)
(
type
index
index
)
(
type
(
member
:nothing
:slot
:object
)
remember
))
(
if
(
eq
(
descriptor-%sap
value
)
:load-time-cookie
)
(
note-load-time-value-reference
(
int-sap
(
+
(
logandc2
(
descriptor-bits
address
)
vm:lowtag-mask
)
(
ash
index
vm:word-shift
)))
value
)
(
let
((
bits
(
descriptor-bits
value
)))
(
write-bits
address
index
bits
)
(
unless
(
eq
remember
:nothing
)
(
when
(
logbitp
0
bits
)
(
let
((
from-step
(
descriptor-step
address
))
(
to-step
(
descriptor-step
value
)))
(
unless
from-step
(
error
"Don't know the step for ~S"
address
))
(
unless
to-step
(
error
"Don't know the step for ~S"
value
))
(
let*
((
from-gen
(
step-gen
from-step
))
(
from-gen-num
(
generation-num
from-gen
))
(
to-gen-num
(
generation-num
(
step-gen
to-step
))))
(
when
(
>
from-gen-num
to-gen-num
)
(
add-remset-entry
from-gen
(
ecase
remember
(
:slot
(
+
(
logandc2
(
descriptor-bits
address
)
vm:lowtag-mask
)
(
ash
index
vm:word-shift
)))
(
:object
(
descriptor-bits
address
))))))))))))
(
defun
read-bits
(
address
index
)
(
declare
(
type
descriptor
address
)
(
type
index
index
)
(
values
(
unsigned-byte
#.
vm:word-bits
)))
(
maybe-byte-swap
(
sap-ref-32
(
descriptor-sap
address
)
(
ash
index
vm:word-shift
))))
(
defun
read-descriptor
(
address
index
)
"Return the value (as a descriptor) INDEX words from ADDRESS (a descriptor)."
(
declare
(
type
descriptor
address
)
(
type
index
index
)
(
values
descriptor
))
(
make-random-descriptor
(
read-bits
address
index
)))
;;;; Allocating primitive objects.
;;; There are two common kinds of objects that we have special allocators
;;; for:
;;;
;;; Simple objects:
;;; A header word with the type and the length, plus the data.
;;;
;;; Vector objects:
;;; A header word with the type, a word for the length, plus the data.
;;;
(
defun
allocate-simple-object
(
step
words
lowtag
header-type
)
(
declare
(
type
step
step
)
(
type
index
words
)
(
type
(
unsigned-byte
#.
vm:lowtag-bits
)
lowtag
)
(
type
(
or
(
unsigned-byte
#.
vm:type-bits
)
null
)
header-type
)
(
values
descriptor
))
(
let
((
des
(
allocate-descriptor
step
words
lowtag
nil
)))
(
when
header-type
(
write-descriptor
des
0
(
make-other-immediate-descriptor
(
1-
words
)
header-type
)))
des
))
(
defun
allocate-vector-object
(
step
element-size
length
header-type
)
(
declare
(
type
step
step
)
(
type
index
element-size
length
)
(
type
(
unsigned-byte
#.
vm:type-bits
)
header-type
)
(
values
descriptor
))
(
let*
((
words
(
+
(
ceiling
(
*
length
element-size
)
vm:word-bits
)
2
))
(
des
(
allocate-descriptor
step
words
vm:other-pointer-type
nil
)))
(
write-descriptor
des
0
(
make-other-immediate-descriptor
0
header-type
))
(
write-descriptor
des
vm:vector-length-slot
(
make-fixnum-descriptor
length
))
des
))
;;;; Routines to move simple objects into the core.
(
defun
string-to-core
(
string
)
(
declare
(
type
string
string
)
(
values
descriptor
))
(
let*
((
len
(
length
string
))
(
des
(
allocate-vector-object
*dynamic*
vm:byte-bits
(
1+
len
)
vm:simple-string-type
)))
;; Note: We allocate an extra byte and tweek the length back to make sure
;; there will be a null at the end of the string to aid in call-out to
;; C.
(
write-descriptor
des
vm:vector-length-slot
(
make-fixnum-descriptor
len
))
(
copy-to-system-area
string
(
*
vm:vector-data-offset
vm:word-bits
)
(
descriptor-sap
des
)
(
*
vm:vector-data-offset
vm:word-bits
)
(
*
(
1+
len
)
vm:byte-bits
))
des
))
(
defun
bignum-to-core
(
n
)
(
declare
(
type
integer
n
)
(
values
descriptor
))
(
let*
((
words
(
ceiling
(
1+
(
integer-length
n
))
vm:word-bits
))
(
handle
(
allocate-simple-object
*dynamic*
(
1+
words
)
vm:other-pointer-type
vm:bignum-type
)))
(
declare
(
fixnum
words
))
(
do
((
index
1
(
1+
index
))
(
remainder
n
(
ash
remainder
(
-
vm:word-bits
))))
((
>
index
words
)
(
unless
(
zerop
(
integer-length
remainder
))
(
warn
"Wrote ~D words of ~D, but ~D was left over"
words
n
remainder
)))
(
write-bits
handle
index
(
ldb
(
byte
vm:word-bits
0
)
remainder
)))
handle
))
(
defun
number-pair-to-core
(
first
second
type
)
(
declare
(
type
descriptor
first
second
)
(
type
(
unsigned-byte
#.
vm:type-bits
)
type
)
(
values
descriptor
))
(
let
((
des
(
allocate-simple-object
*dynamic*
2
vm:other-pointer-type
type
)))
(
write-descriptor
des
1
first
)
(
write-descriptor
des
2
second
)
des
))
(
defun
float-to-core
(
num
)
(
declare
(
type
float
num
)
(
values
descriptor
))
(
etypecase
num
(
single-float
(
let
((
des
(
allocate-simple-object
*dynamic*
vm:single-float-size
vm:other-pointer-type
vm:single-float-type
)))
(
write-bits
des
vm:single-float-value-slot
(
single-float-bits
num
))
des
))
(
double-float
(
let
((
des
(
allocate-simple-object
*dynamic*
vm:double-float-size
vm:other-pointer-type
vm:double-float-type
))
(
high-bits
(
double-float-high-bits
num
))
(
low-bits
(
double-float-low-bits
num
)))
(
ecase
(
c:backend-byte-order
c:*backend*
)
(
:little-endian
(
write-bits
des
vm:double-float-value-slot
low-bits
)
(
write-bits
des
(
1+
vm:double-float-value-slot
)
high-bits
))
(
:big-endian
(
write-bits
des
vm:double-float-value-slot
high-bits
)
(
write-bits
des
(
1+
vm:double-float-value-slot
)
low-bits
)))
des
))))
(
defun
number-to-core
(
number
)
(
declare
(
type
number
number
)
(
values
descriptor
))
(
etypecase
number
(
integer
(
if
(
<
(
integer-length
number
)
30
)
(
make-fixnum-descriptor
number
)
(
bignum-to-core
number
)))
(
ratio
(
number-pair-to-core
(
number-to-core
(
numerator
number
))
(
number-to-core
(
denominator
number
))
vm:ratio-type
))
(
complex
(
number-pair-to-core
(
number-to-core
(
realpart
number
))
(
number-to-core
(
imagpart
number
))
vm:complex-type
))
(
float
(
float-to-core
number
))))
(
defun
sap-to-core
(
sap
)
(
declare
(
type
system-area-pointer
sap
)
(
values
descriptor
))
(
let
((
des
(
allocate-simple-object
*dynamic*
vm:sap-size
vm:other-pointer-type
vm:sap-type
)))
(
write-bits
des
vm:sap-pointer-slot
(
sap-int
sap
))
des
))
(
defun
cold-cons
(
car
cdr
)
(
declare
(
type
descriptor
car
cdr
)
(
values
descriptor
))
(
let
((
dest
(
allocate-simple-object
*dynamic*
2
vm:list-pointer-type
nil
)))
(
write-descriptor
dest
0
car
)
(
write-descriptor
dest
1
cdr
)
dest
))
(
defmacro
cold-push
(
thing
list
)
"Generates code to push the THING onto the given cold load LIST."
`
(
setq
,
list
(
cold-cons
,
thing
,
list
)))
;;; COLD-VECTOR -- Internal
;;;
;;; Make a simple-vector that holds the specified Objects and return its
;;; decriptor.
;;;
(
defun
cold-vector
(
&rest
objects
)
(
let*
((
size
(
length
objects
))
(
result
(
allocate-vector-object
*dynamic*
vm:word-bits
size
vm:simple-vector-type
)))
(
dotimes
(
index
size
)
(
write-descriptor
result
(
+
index
vm:vector-data-offset
)
(
pop
objects
)))
result
))
;;;; Symbol magic.
;;; Cold-Make-Symbol allocates a symbol and fills its print name cell and
;;; property list cell.
(
defvar
*cold-symbol-allocation-step*
nil
)
(
defun
cold-make-symbol
(
name
)
(
declare
(
simple-string
name
)
(
values
descriptor
))
(
let
((
symbol
(
allocate-simple-object
(
or
*cold-symbol-allocation-step*
*dynamic*
)
vm:symbol-size
vm:other-pointer-type
vm:symbol-header-type
)))
(
write-descriptor
symbol
vm:symbol-value-slot
unbound-marker
)
(
write-descriptor
symbol
vm:symbol-plist-slot
*nil-descriptor*
)
(
write-descriptor
symbol
vm:symbol-name-slot
(
string-to-core
name
))
(
write-descriptor
symbol
vm:symbol-package-slot
*nil-descriptor*
)
symbol
))
(
defun
cold-setq
(
symbol
value
)
(
declare
(
type
descriptor
symbol
value
))
(
write-descriptor
symbol
vm:symbol-value-slot
value
))
;;;; Interning.
;;; In order to avoid having to know about the package format, we
;;; build a data structure which we stick in *cold-packages* that
;;; holds all interned symbols along with info about their packages.
;;; The data structure is a list of lists in the following format:
;;; (<make-package-arglist>
;;; <internal-symbols>
;;; <external-symbols>
;;; <imported-internal-symbols>
;;; <imported-external-symbols>
;;; <shadowing-symbols>)
;;;
;;; Package manipulation forms are dumped magically by the compiler
;;; so that we can eval them at Genesis time. An eval-for-effect fop
;;; is used, surrounded by fops that switch the fop table to the hot
;;; fop table and back.
;;;
;;; An alist from packages to the list of symbols in that package to be
;;; dumped.
(
defvar
*cold-packages*
)
;;; This holds a hash table mapping from descriptors to symbols, so we can
;;; back up. The key is the *address* in the target core.
;;;
(
defvar
*cold-symbols*
)
;;; Cold-Intern -- Internal
;;;
;;; Return a handle on an interned symbol. If necessary allocate
;;; the symbol and record which package the symbol was referenced in.
;;; When we allocatethe symbol, make sure we record a reference to
;;; the symbol in the home package so that the package gets set.
;;;
(
defun
cold-intern
(
symbol
&optional
(
package
(
symbol-package
symbol
)))
(
declare
(
type
symbol
symbol
)
(
type
(
or
package
null
)
package
)
(
values
descriptor
))
(
let
((
cold-info
(
get
symbol
'cold-info
)))
(
unless
cold-info
(
cond
((
eq
(
symbol-package
symbol
)
package
)
(
let
((
handle
(
cold-make-symbol
(
symbol-name
symbol
))))
(
setf
(
gethash
(
descriptor-bits
handle
)
*cold-symbols*
)
symbol
)
(
when
(
eq
package
*keyword-package*
)
(
cold-setq
handle
handle
))
(
setq
cold-info
(
setf
(
get
symbol
'cold-info
)
(
cons
handle
nil
)))))
(
t
(
cold-intern
symbol
)
(
setq
cold-info
(
get
symbol
'cold-info
)))))
(
unless
(
or
(
null
package
)
(
member
package
(
cdr
cold-info
)
:test
#'
eq
))
(
push
package
(
cdr
cold-info
))
(
push
symbol
(
cdr
(
or
(
assoc
package
*cold-packages*
:test
#'
eq
)
(
car
(
push
(
list
package
)
*cold-packages*
))))))
(
car
cold-info
)))
;;; Initialize-Symbols -- Internal
;;;
;;; Since the initial symbols must be allocated before we can intern
;;; anything else, we intern those here. We also set the values of T and Nil.
;;;
(
defun
initialize-symbols
()
"Initilizes the cold load symbol-hacking data structures."
(
do-all-symbols
(
sym
)
(
remprop
sym
'cold-info
))
(
setq
*cold-packages*
nil
)
(
let
((
*cold-symbol-allocation-step*
*static*
))
;; Special case NIL.
(
let*
((
des
(
allocate-simple-object
*static*
(
+
vm:symbol-size
2
)
0
nil
))
(
nil-des
(
make-pointer-descriptor
(
+
(
descriptor-bits
des
)
vm:word-bytes
vm:other-pointer-type
)
nil
*static*
)))
(
setf
*nil-descriptor*
nil-des
)
(
write-descriptor
nil-des
0
(
make-other-immediate-descriptor
0
vm:symbol-header-type
))
(
write-descriptor
nil-des
vm:symbol-value-slot
*nil-descriptor*
)
(
write-descriptor
nil-des
(
1+
vm:symbol-value-slot
)
*nil-descriptor*
)
(
write-descriptor
nil-des
vm:symbol-plist-slot
*nil-descriptor*
)
(
write-descriptor
nil-des
vm:symbol-name-slot
(
string-to-core
"NIL"
))
(
write-descriptor
nil-des
vm:symbol-package-slot
*nil-descriptor*
)
(
setf
(
get
nil
'cold-info
)
(
cons
*nil-descriptor*
nil
))
(
cold-intern
nil
))
;; Intern the others.
(
dolist
(
symbol
vm:static-symbols
)
(
let
((
des
(
cold-intern
symbol
)))
(
unless
(
=
(
-
(
descriptor-bits
des
)
(
descriptor-bits
*nil-descriptor*
))
(
vm:static-symbol-offset
symbol
))
(
warn
"Offset from ~S to ~S is ~D, not ~D"
symbol
nil
(
-
(
descriptor-bits
des
)
(
descriptor-bits
*nil-descriptor*
))
(
vm:static-symbol-offset
symbol
)))))
;; Establish the value of T.
(
let
((
t-symbol
(
cold-intern
t
)))
(
cold-setq
t-symbol
t-symbol
))))
;;; Finish-Symbols -- Internal
;;;
;;; Establish initial values for magic symbols.
;;;
;;; Scan over all the symbols referenced in each package in *cold-packages*
;;; making the apropriate entry in the *initial-symbols* data structure to
;;; intern the thing.
;;;
(
defun
finish-symbols
()
(
macrolet
((
frob
(
symbol
)
`
(
cold-setq
(
cold-intern
',symbol
)
(
cold-fdefinition-object
(
cold-intern
',symbol
)))))
(
frob
kernel::internal-error
)
(
frob
mach::handle-exception
)
(
frob
di::handle-breakpoint
)
(
frob
di::handle-function-end-breakpoint
)
(
frob
lisp::fdefinition-object
)
(
frob
apply
))
(
macrolet
((
frob
(
symbol
value
)
`
(
cold-setq
(
cold-intern
',symbol
)
,
value
)))
(
frob
*initial-layouts*
(
list-all-layouts
))
(
frob
*initial-symbols*
(
list-initial-symbols
))
(
frob
*initial-fdefn-objects*
(
list-all-fdefn-objects
))
(
frob
*lisp-initialization-functions*
*current-init-functions-cons*
)
(
frob
kernel::*saved-state-chain*
*nil-descriptor*
))
nil
)
(
defun
list-initial-symbols
()
(
let
((
res
*nil-descriptor*
))
(
dolist
(
cpkg
*cold-packages*
)
(
let*
((
pkg
(
car
cpkg
))
(
shadows
(
package-shadowing-symbols
pkg
)))
(
let
((
internal
*nil-descriptor*
)
(
external
*nil-descriptor*
)
(
imported-internal
*nil-descriptor*
)
(
imported-external
*nil-descriptor*
)
(
shadowing
*nil-descriptor*
))
(
dolist
(
sym
(
cdr
cpkg
))
(
let
((
handle
(
car
(
get
sym
'cold-info
))))
(
multiple-value-bind
(
found
where
)
(
find-symbol
(
symbol-name
sym
)
pkg
)
(
unless
(
and
where
(
eq
found
sym
))
(
error
"Symbol ~S is not available in ~S."
sym
pkg
))
(
when
(
memq
sym
shadows
)
(
cold-push
handle
shadowing
))
(
case
where
(
:internal
(
if
(
eq
(
symbol-package
sym
)
pkg
)
(
cold-push
handle
internal
)
(
cold-push
handle
imported-internal
)))
(
:external
(
if
(
eq
(
symbol-package
sym
)
pkg
)
(
cold-push
handle
external
)
(
cold-push
handle
imported-external
)))))))
(
let
((
r
*nil-descriptor*
))
(
cold-push
shadowing
r
)
(
cold-push
imported-external
r
)
(
cold-push
imported-internal
r
)
(
cold-push
external
r
)
(
cold-push
internal
r
)
(
cold-push
(
make-make-package-args
pkg
)
r
)
(
cold-push
r
res
)))))
res
))
;;; Make-Make-Package-Args -- Internal
;;;
;;; Make a cold list that can be used as the arglist to make-package to
;;; make a similar package.
;;;
(
defun
make-make-package-args
(
package
)
(
let*
((
use
*nil-descriptor*
)
(
nicknames
*nil-descriptor*
)
(
res
*nil-descriptor*
))
(
dolist
(
u
(
package-use-list
package
))
(
when
(
assoc
u
*cold-packages*
)
(
cold-push
(
string-to-core
(
package-name
u
))
use
)))
(
dolist
(
n
(
package-nicknames
package
))
(
cold-push
(
string-to-core
n
)
nicknames
))
(
cold-push
(
number-to-core
(
truncate
(
internal-symbol-count
package
)
0.8
))
res
)
(
cold-push
(
cold-intern
:internal-symbols
)
res
)
(
cold-push
(
number-to-core
(
truncate
(
external-symbol-count
package
)
0.8
))
res
)
(
cold-push
(
cold-intern
:external-symbols
)
res
)
(
cold-push
nicknames
res
)
(
cold-push
(
cold-intern
:nicknames
)
res
)
(
cold-push
use
res
)
(
cold-push
(
cold-intern
:use
)
res
)
(
cold-push
(
string-to-core
(
package-name
package
))
res
)
res
))
;;;; Fdefinition objects.
(
defvar
*fdefn-objects*
)
(
defvar
*fdefn-space*
nil
)
(
defun
extract-fdefn-name
(
des
)
(
ecase
(
descriptor-lowtag
des
)
(
#.
vm:list-pointer-type
(
if
(
=
(
descriptor-bits
des
)
(
descriptor-bits
*nil-descriptor*
))
nil
(
cons
(
extract-fdefn-name
(
read-descriptor
des
vm:cons-car-slot
))
(
extract-fdefn-name
(
read-descriptor
des
vm:cons-cdr-slot
)))))
(
#.
vm:other-pointer-type
(
or
(
gethash
(
descriptor-bits
des
)
*cold-symbols*
)
(
descriptor-bits
des
)))))
(
defun
cold-fdefinition-object
(
name
&optional
leave-fn-raw
)
(
let
((
hash
(
extract-fdefn-name
name
)))
(
or
(
gethash
hash
*fdefn-objects*
)
(
let
((
fdefn
(
allocate-simple-object
(
or
*fdefn-space*
*dynamic*
)
vm:fdefn-size
vm:other-pointer-type
vm:fdefn-type
)))
(
setf
(
gethash
hash
*fdefn-objects*
)
fdefn
)
(
write-descriptor
fdefn
vm:fdefn-name-slot
name
)
(
unless
leave-fn-raw
(
write-descriptor
fdefn
vm:fdefn-function-slot
*nil-descriptor*
)
(
write-descriptor
fdefn
vm:fdefn-raw-addr-slot
(
make-random-descriptor
(
ecase
(
c:backend-fasl-file-implementation
c:*backend*
)
((
#.
c:pmax-fasl-file-implementation
#.
c:rt-fasl-file-implementation
#.
c:rt-afpa-fasl-file-implementation
#.
c:x86-fasl-file-implementation
#.
c:hppa-fasl-file-implementation
)
(
lookup-foreign-symbol
"undefined_tramp"
))
(
#.
c:sparc-fasl-file-implementation
(
lookup-foreign-symbol
"_undefined_tramp"
))))))
fdefn
))))
(
defun
cold-fset
(
name
defn
)
(
assert
(
=
(
logand
(
read-bits
defn
0
)
vm:type-mask
)
vm:function-header-type
))
(
let
((
fdefn
(
cold-fdefinition-object
name
t
)))
(
write-descriptor
fdefn
vm:fdefn-function-slot
defn
:remember
:object
)
(
write-bits
fdefn
vm:fdefn-raw-addr-slot
(
read-bits
defn
vm:function-entry-point-slot
))
fdefn
))
(
defun
initialize-static-fns
()
(
let
((
*fdefn-space*
*static*
))
(
dolist
(
sym
vm:static-functions
)
(
let*
((
fdefn
(
cold-fdefinition-object
(
cold-intern
sym
)))
(
offset
(
-
(
+
(
-
(
descriptor-bits
fdefn
)
vm:other-pointer-type
)
(
*
vm:fdefn-raw-addr-slot
vm:word-bytes
))
(
descriptor-bits
*nil-descriptor*
)))
(
desired
(
vm:static-function-offset
sym
)))
(
unless
(
=
offset
desired
)
(
warn
"Offset from FDEFN ~S to ~S is ~D, not ~D"
sym
nil
offset
desired
))))))
(
defun
list-all-fdefn-objects
()
(
let
((
result
*nil-descriptor*
))
(
maphash
#'
(
lambda
(
key
value
)
(
declare
(
ignore
key
))
(
cold-push
value
result
))
*fdefn-objects*
)
result
))
;;;; Layouts & type system pre-initialization:
;;;
;;; Since we want to be able to dump structure constants and predicates with
;;; reference layouts, we need to create layouts at cold-load time. We use the
;;; name to intern layouts by, and dump a list of all cold layouts in
;;; *INITIAL-LAYOUTS* so that type-system initialization can find them. The
;;; only thing that's tricky is initializing layout's layout, which must point
;;; to itself.
;;; Table mapping from class names to descriptors for their layouts.
;;;
(
defvar
*cold-layouts*
(
make-hash-table
:test
#'
equal
))
;;; The descriptor for layout's layout, which we need when making layouts.
;;;
(
defvar
*layout-layout*
)
(
defparameter
target-layout-length
16
)
(
defun
make-cold-layout
(
name
length
inherits
depth
)
(
let
((
result
(
allocate-simple-object
*dynamic*
(
1+
target-layout-length
)
vm:instance-pointer-type
vm:instance-header-type
)))
(
write-descriptor
result
vm:instance-slots-offset
*layout-layout*
)
(
let
((
base
(
+
vm:instance-slots-offset
kernel:layout-hash-length
1
)))
;0 class uninitialized
(
write-descriptor
result
(
+
base
1
)
*nil-descriptor*
)
; invalid
(
write-descriptor
result
(
+
base
2
)
inherits
)
(
write-descriptor
result
(
+
base
3
)
depth
)
(
write-descriptor
result
(
+
base
4
)
length
)
(
write-descriptor
result
(
+
base
5
)
*nil-descriptor*
)
; info
(
write-descriptor
result
(
+
base
6
)
*nil-descriptor*
))
; pure
(
setf
(
gethash
name
*cold-layouts*
)
result
)
result
))
;;; INITIALIZE-LAYOUTS -- Internal
;;;
;;; Clear the layout table and set *layout-layout*. We initially create
;;; LAYOUT with NIL as the LAYOUT and INHERITS, then back-patch with itself and
;;; the correct INHERITS vector (which includes T, INSTANCE and
;;; STRUCTURE-OBJECT).
;;;
(
defun
initialize-layouts
()
(
clrhash
*cold-layouts*
)
(
setq
*layout-layout*
*nil-descriptor*
)
(
setq
*layout-layout*
(
make-cold-layout
'layout
(
number-to-core
target-layout-length
)
*nil-descriptor*
(
number-to-core
3
)))
(
write-descriptor
*layout-layout*
vm:instance-slots-offset
*layout-layout*
)
(
let*
((
t-layout
(
make-cold-layout
't
(
number-to-core
0
)
(
cold-vector
)
(
number-to-core
0
)))
(
inst-layout
(
make-cold-layout
'instance
(
number-to-core
0
)
(
cold-vector
t-layout
)
(
number-to-core
1
)))
(
so-layout
(
make-cold-layout
'structure-object
(
number-to-core
1
)
(
cold-vector
t-layout
inst-layout
)
(
number-to-core
2
))))
(
write-descriptor
*layout-layout*
(
+
vm:instance-slots-offset
layout-hash-length
1
2
)
(
cold-vector
t-layout
inst-layout
so-layout
))))
;;; LIST-ALL-LAYOUTS -- Internal
;;;
;;; Return a cold alist that we're going to store in *INITIAL-LAYOUTS*.
;;;
(
defun
list-all-layouts
()
(
let
((
result
*nil-descriptor*
))
(
maphash
#'
(
lambda
(
key
value
)
(
cold-push
(
cold-cons
(
cold-intern
key
)
value
)
result
))
*cold-layouts*
)
result
))
;;;; Reading FASL files.
(
defvar
*cold-fop-functions*
(
replace
(
make-array
256
)
fop-functions
)
"FOP functions for cold loading."
)
(
defvar
*normal-fop-functions*
)
;;; Define-Cold-FOP -- Internal
;;;
;;; Like Define-FOP in load, but looks up the code, and stores into
;;; the *cold-fop-functions* vector.
;;;
(
defmacro
define-cold-fop
((
name
&optional
(
pushp
t
))
&rest
forms
)
(
let
((
fname
(
concat-pnames
'cold-
name
))
(
code
(
get
name
'fop-code
)))
`
(
progn
(
defun
,
fname
()
,@
(
if
(
eq
pushp
:nope
)
forms
`
((
with-fop-stack
,
pushp
,@
forms
))))
,@
(
if
code
`
((
setf
(
svref
*cold-fop-functions*
,
code
)
#'
,
fname
))
(
warn
"~S is not a defined FOP."
name
)))))
;;; Clone-Cold-FOP -- Internal
;;;
;;; Clone a couple of cold fops.
;;;
(
defmacro
clone-cold-fop
((
name
&optional
(
pushp
t
))
(
small-name
)
&rest
forms
)
`
(
progn
(
macrolet
((
clone-arg
()
'
(
read-arg
4
)))
(
define-cold-fop
(
,
name
,
pushp
)
,@
forms
))
(
macrolet
((
clone-arg
()
'
(
read-arg
1
)))
(
define-cold-fop
(
,
small-name
,
pushp
)
,@
forms
))))
;;; Not-Cold-Fop -- Internal
;;;
;;; Define a fop to be undefined in cold load.
;;;
(
defmacro
not-cold-fop
(
name
)
`
(
define-cold-fop
(
,
name
)
(
error
"~S is not supported in cold load."
',name
)))
;;;; Random cold fops...
(
define-cold-fop
(
fop-misc-trap
)
unbound-marker
)
(
define-cold-fop
(
fop-character
)
(
make-character-descriptor
(
read-arg
3
)))
(
define-cold-fop
(
fop-short-character
)
(
make-character-descriptor
(
read-arg
1
)))
(
define-cold-fop
(
fop-empty-list
)
*nil-descriptor*
)
(
define-cold-fop
(
fop-truth
)
(
cold-intern
t
))
(
define-cold-fop
(
fop-normal-load
:nope
)
(
setq
fop-functions
*normal-fop-functions*
))
(
define-fop
(
fop-maybe-cold-load
82
:nope
)
(
when
*in-cold-load*
(
setq
fop-functions
*cold-fop-functions*
)))
(
define-cold-fop
(
fop-maybe-cold-load
:nope
))
(
clone-cold-fop
(
fop-struct
)
(
fop-small-struct
)
(
let*
((
size
(
clone-arg
))
(
result
(
allocate-simple-object
*dynamic*
(
1+
size
)
vm:instance-pointer-type
vm:instance-header-type
)))
(
do
((
index
(
1-
size
)
(
1-
index
)))
((
minusp
index
))
(
declare
(
fixnum
index
))
(
write-descriptor
result
(
+
index
vm:instance-slots-offset
)
(
pop-stack
)))
result
))
(
define-cold-fop
(
fop-layout
)
(
let
((
length
(
pop-stack
))
(
depth
(
pop-stack
))
(
inherits
(
pop-stack
))
(
name
(
pop-stack
)))
(
or
(
gethash
name
*cold-layouts*
)
(
make-cold-layout
name
length
inherits
depth
))))
;;; Loading symbols...
;;; Cold-Load-Symbol loads a symbol N characters long from the File and interns
;;; that symbol in the given Package.
;;;
(
defun
cold-load-symbol
(
size
package
)
(
let
((
string
(
make-string
size
)))
(
read-n-bytes
*fasl-file*
string
0
size
)
(
cold-intern
(
intern
string
package
)
package
)))
(
clone-cold-fop
(
fop-symbol-save
)
(
fop-small-symbol-save
)
(
push-table
(
cold-load-symbol
(
clone-arg
)
*package*
)))
(
macrolet
((
frob
(
name
pname-len
package-len
)
`
(
define-cold-fop
(
,
name
)
(
let
((
index
(
read-arg
,
package-len
)))
(
push-table
(
cold-load-symbol
(
read-arg
,
pname-len
)
(
svref
*current-fop-table*
index
)))))))
(
frob
fop-symbol-in-package-save
4
4
)
(
frob
fop-small-symbol-in-package-save
1
4
)
(
frob
fop-symbol-in-byte-package-save
4
1
)
(
frob
fop-small-symbol-in-byte-package-save
1
1
))
(
clone-cold-fop
(
fop-lisp-symbol-save
)
(
fop-lisp-small-symbol-save
)
(
push-table
(
cold-load-symbol
(
clone-arg
)
*lisp-package*
)))
(
clone-cold-fop
(
fop-keyword-symbol-save
)
(
fop-keyword-small-symbol-save
)
(
push-table
(
cold-load-symbol
(
clone-arg
)
*keyword-package*
)))
(
clone-cold-fop
(
fop-uninterned-symbol-save
)
(
fop-uninterned-small-symbol-save
)
(
let*
((
size
(
clone-arg
))
(
name
(
make-string
size
)))
(
read-n-bytes
*fasl-file*
name
0
size
)
(
let
((
symbol
(
cold-make-symbol
name
)))
(
push-table
symbol
))))
;;; Loading lists...
;;; Cold-Stack-List makes a list of the top Length things on the Fop-Stack.
;;; The last cdr of the list is set to Last.
(
defmacro
cold-stack-list
(
length
last
)
`
(
do*
((
index
,
length
(
1-
index
))
(
result
,
last
(
cold-cons
(
pop-stack
)
result
)))
((
=
index
0
)
result
)
(
declare
(
fixnum
index
))))
(
define-cold-fop
(
fop-list
)
(
cold-stack-list
(
read-arg
1
)
*nil-descriptor*
))
(
define-cold-fop
(
fop-list*
)
(
cold-stack-list
(
read-arg
1
)
(
pop-stack
)))
(
define-cold-fop
(
fop-list-1
)
(
cold-stack-list
1
*nil-descriptor*
))
(
define-cold-fop
(
fop-list-2
)
(
cold-stack-list
2
*nil-descriptor*
))
(
define-cold-fop
(
fop-list-3
)
(
cold-stack-list
3
*nil-descriptor*
))
(
define-cold-fop
(
fop-list-4
)
(
cold-stack-list
4
*nil-descriptor*
))
(
define-cold-fop
(
fop-list-5
)
(
cold-stack-list
5
*nil-descriptor*
))
(
define-cold-fop
(
fop-list-6
)
(
cold-stack-list
6
*nil-descriptor*
))
(
define-cold-fop
(
fop-list-7
)
(
cold-stack-list
7
*nil-descriptor*
))
(
define-cold-fop
(
fop-list-8
)
(
cold-stack-list
8
*nil-descriptor*
))
(
define-cold-fop
(
fop-list*-1
)
(
cold-stack-list
1
(
pop-stack
)))
(
define-cold-fop
(
fop-list*-2
)
(
cold-stack-list
2
(
pop-stack
)))
(
define-cold-fop
(
fop-list*-3
)
(
cold-stack-list
3
(
pop-stack
)))
(
define-cold-fop
(
fop-list*-4
)
(
cold-stack-list
4
(
pop-stack
)))
(
define-cold-fop
(
fop-list*-5
)
(
cold-stack-list
5
(
pop-stack
)))
(
define-cold-fop
(
fop-list*-6
)
(
cold-stack-list
6
(
pop-stack
)))
(
define-cold-fop
(
fop-list*-7
)
(
cold-stack-list
7
(
pop-stack
)))
(
define-cold-fop
(
fop-list*-8
)
(
cold-stack-list
8
(
pop-stack
)))
;;; Loading vectors...
(
clone-cold-fop
(
fop-string
)
(
fop-small-string
)
(
let*
((
len
(
clone-arg
))
(
string
(
make-string
len
)))
(
read-n-bytes
*fasl-file*
string
0
len
)
(
string-to-core
string
)))
(
clone-cold-fop
(
fop-vector
)
(
fop-small-vector
)
(
let*
((
size
(
clone-arg
))
(
result
(
allocate-vector-object
*dynamic*
vm:word-bits
size
vm:simple-vector-type
)))
(
do
((
index
(
1-
size
)
(
1-
index
)))
((
minusp
index
))
(
declare
(
fixnum
index
))
(
write-descriptor
result
(
+
index
vm:vector-data-offset
)
(
pop-stack
)))
result
))
(
clone-cold-fop
(
fop-uniform-vector
)
(
fop-small-uniform-vector
)
(
let*
((
size
(
clone-arg
))
(
datum
(
pop-stack
))
(
result
(
allocate-vector-object
*dynamic*
vm:word-bits
size
vm:simple-vector-type
)))
(
do
((
index
(
1-
size
)
(
1-
index
)))
((
minusp
index
))
(
declare
(
fixnum
index
))
(
write-descriptor
result
(
+
index
vm:vector-data-offset
)
datum
))
result
))
(
define-cold-fop
(
fop-uniform-int-vector
)
(
let*
((
len
(
read-arg
4
))
(
size
(
read-arg
1
))
(
type
(
case
size
(
1
vm:simple-bit-vector-type
)
(
2
vm:simple-array-unsigned-byte-2-type
)
(
4
vm:simple-array-unsigned-byte-4-type
)
(
8
vm:simple-array-unsigned-byte-8-type
)
(
16
vm:simple-array-unsigned-byte-16-type
)
(
32
vm:simple-array-unsigned-byte-32-type
)
(
t
(
error
"Losing element size: ~D."
size
))))
(
value
(
case
size
((
1
2
4
8
)
(
read-arg
1
))
(
16
(
read-arg
2
))
(
32
(
read-arg
4
))))
(
result
(
allocate-vector-object
*dynamic*
size
len
type
)))
(
do
((
bits
size
(
*
bits
2
))
(
word
value
(
logior
word
(
ash
word
bits
))))
((
=
size
vm:word-bits
)
(
dotimes
(
index
(
ceiling
(
*
len
size
)
vm:word-bits
))
(
write-bits
result
(
+
index
vm:vector-data-offset
)
word
))))
result
))
(
define-cold-fop
(
fop-int-vector
)
(
let*
((
len
(
read-arg
4
))
(
size
(
read-arg
1
))
(
type
(
case
size
(
1
vm:simple-bit-vector-type
)
(
2
vm:simple-array-unsigned-byte-2-type
)
(
4
vm:simple-array-unsigned-byte-4-type
)
(
8
vm:simple-array-unsigned-byte-8-type
)
(
16
vm:simple-array-unsigned-byte-16-type
)
(
32
vm:simple-array-unsigned-byte-32-type
)
(
t
(
error
"Losing element size: ~D."
size
))))
(
result
(
allocate-vector-object
*dynamic*
size
len
type
)))
(
unless
(
zerop
len
)
(
read-n-bytes
*fasl-file*
(
descriptor-sap
result
)
(
ash
vm:vector-data-offset
vm:word-shift
)
(
ceiling
(
*
len
size
)
vm:byte-bits
)))
result
))
(
define-cold-fop
(
fop-single-float-vector
)
(
let*
((
len
(
read-arg
4
))
(
result
(
allocate-vector-object
*dynamic*
vm:word-bits
len
vm:simple-array-single-float-type
)))
(
unless
(
zerop
len
)
(
read-n-bytes
*fasl-file*
(
descriptor-sap
result
)
(
ash
vm:vector-data-offset
vm:word-shift
)
(
*
len
vm:word-bytes
)))
result
))
(
define-cold-fop
(
fop-double-float-vector
)
(
let*
((
len
(
read-arg
4
))
(
result
(
allocate-vector-object
*dynamic*
(
*
vm:word-bits
2
)
len
vm:simple-array-double-float-type
)))
(
unless
(
zerop
len
)
(
read-n-bytes
*fasl-file*
(
descriptor-sap
result
)
(
ash
vm:vector-data-offset
vm:word-shift
)
(
*
len
vm:word-bytes
2
)))
result
))
(
define-cold-fop
(
fop-array
)
(
let*
((
rank
(
read-arg
4
))
(
data-vector
(
pop-stack
))
(
result
(
allocate-simple-object
*dynamic*
(
+
vm:array-dimensions-offset
rank
)
vm:other-pointer-type
vm:simple-array-type
)))
(
write-descriptor
result
vm:array-fill-pointer-slot
*nil-descriptor*
)
(
write-descriptor
result
vm:array-data-slot
data-vector
)
(
write-descriptor
result
vm:array-displacement-slot
*nil-descriptor*
)
(
write-descriptor
result
vm:array-displaced-p-slot
*nil-descriptor*
)
(
let
((
total-elements
1
))
(
dotimes
(
axis
rank
)
(
let*
((
dim
(
pop-stack
))
(
bits
(
descriptor-bits
dim
)))
(
unless
(
zerop
(
ldb
(
byte
2
0
)
bits
))
(
error
"Non-fixnum dimension? (~S)"
dim
))
(
setf
total-elements
(
*
total-elements
(
ash
bits
-2
)))
(
write-descriptor
result
(
+
vm:array-dimensions-offset
axis
)
dim
)))
(
write-descriptor
result
vm:array-elements-slot
(
make-fixnum-descriptor
total-elements
)))
result
))
;;; Loading numbers.
(
defmacro
cold-number
(
fop
)
`
(
define-cold-fop
(
,
fop
:nope
)
(
,
fop
)
(
with-fop-stack
t
(
number-to-core
(
pop-stack
)))))
(
cold-number
fop-single-float
)
(
cold-number
fop-double-float
)
(
cold-number
fop-integer
)
(
cold-number
fop-small-integer
)
(
cold-number
fop-word-integer
)
(
cold-number
fop-byte-integer
)
(
define-cold-fop
(
fop-ratio
)
(
let
((
den
(
pop-stack
)))
(
number-pair-to-core
(
pop-stack
)
den
vm:ratio-type
)))
(
define-cold-fop
(
fop-complex
)
(
let
((
im
(
pop-stack
)))
(
number-pair-to-core
(
pop-stack
)
im
vm:complex-type
)))
;;; Calling (or not calling).
(
not-cold-fop
fop-eval
)
(
not-cold-fop
fop-eval-for-effect
)
(
defvar
*load-time-value-counter*
)
(
define-cold-fop
(
fop-funcall
)
(
unless
(
=
(
read-arg
1
)
0
)
(
error
"Can't FOP-FUNCALL random stuff in cold load."
))
(
let
((
counter
*load-time-value-counter*
))
(
cold-push
(
cold-cons
(
cold-intern
:load-time-value
)
(
cold-cons
(
pop-stack
)
(
cold-cons
(
number-to-core
counter
)
*nil-descriptor*
)))
*current-init-functions-cons*
)
(
setf
*load-time-value-counter*
(
1+
counter
))
(
make-pointer-descriptor
counter
:load-time-cookie
nil
)))
(
defun
note-load-time-value-reference
(
address
marker
)
(
cold-push
(
cold-cons
(
cold-intern
:load-time-value-fixup
)
(
cold-cons
(
sap-to-core
address
)
(
cold-cons
(
number-to-core
(
descriptor-bits
marker
))
*nil-descriptor*
)))
*current-init-functions-cons*
))
(
defun
finalize-load-time-value-noise
()
(
cold-setq
(
cold-intern
'lisp::*load-time-values*
)
(
allocate-vector-object
*dynamic*
vm:word-bits
*load-time-value-counter*
vm:simple-vector-type
)))
(
define-cold-fop
(
fop-funcall-for-effect
nil
)
(
if
(
=
(
read-arg
1
)
0
)
(
cold-push
(
pop-stack
)
*current-init-functions-cons*
)
(
error
"Can't FOP-FUNCALL random stuff in cold load."
)))
;;;; Fixing up circularities.
(
define-cold-fop
(
fop-rplaca
nil
)
(
let
((
obj
(
svref
*current-fop-table*
(
read-arg
4
)))
(
idx
(
read-arg
4
)))
(
write-descriptor
(
cold-nthcdr
idx
obj
)
0
(
pop-stack
))))
(
define-cold-fop
(
fop-rplacd
nil
)
(
let
((
obj
(
svref
*current-fop-table*
(
read-arg
4
)))
(
idx
(
read-arg
4
)))
(
write-descriptor
(
cold-nthcdr
idx
obj
)
1
(
pop-stack
))))
(
define-cold-fop
(
fop-svset
nil
)
(
let
((
obj
(
svref
*current-fop-table*
(
read-arg
4
)))
(
idx
(
read-arg
4
)))
(
write-descriptor
obj
(
+
idx
vm:vector-data-offset
)
(
pop-stack
))))
(
define-cold-fop
(
fop-structset
nil
)
(
let
((
obj
(
svref
*current-fop-table*
(
read-arg
4
)))
(
idx
(
read-arg
4
)))
(
write-descriptor
obj
(
+
idx
vm:instance-slots-offset
)
(
pop-stack
))))
(
define-cold-fop
(
fop-nthcdr
t
)
(
cold-nthcdr
(
read-arg
4
)
(
pop-stack
)))
(
defun
cold-nthcdr
(
index
obj
)
(
iterate
repeat
((
result
obj
)
(
index
index
))
(
cond
((
plusp
index
)
(
repeat
(
read-descriptor
result
1
)
(
1-
index
)))
(
t
(
setf
(
descriptor-step
result
)
(
descriptor-step
obj
))
result
))))
;;; Loading code objects and functions.
(
define-cold-fop
(
fop-fset
nil
)
(
let
((
fn
(
pop-stack
))
(
name
(
pop-stack
)))
(
cold-fset
name
fn
)))
(
define-cold-fop
(
fop-fdefinition
)
(
cold-fdefinition-object
(
pop-stack
)))
(
define-cold-fop
(
fop-sanctify-for-execution
)
(
pop-stack
))
(
defun
cold-verify-code-format
()
(
unless
*current-code-format*
(
error
"Can't load code until after FOP-CODE-FORMAT."
))
(
let
((
implementation
(
car
*current-code-format*
))
(
version
(
cdr
*current-code-format*
)))
(
unless
(
=
implementation
(
c:backend-fasl-file-implementation
c:*backend*
))
(
error
"~A was compiled for a ~A, but we are trying to build a core for a ~A"
*Fasl-file*
(
or
(
elt
c:fasl-file-implementations
implementation
)
"unknown machine"
)
(
or
(
elt
c:fasl-file-implementations
(
c:backend-fasl-file-implementation
c:*backend*
))
"unknown machine"
)))
(
unless
(
=
version
(
c:backend-fasl-file-version
c:*backend*
))
(
error
"~A was compiled for a fasl-file version ~A, but we need version ~A"
*Fasl-file*
version
(
c:backend-fasl-file-version
c:*backend*
)))))
(
defmacro
define-cold-code-fop
(
name
nconst
size
)
`
(
define-cold-fop
(
,
name
)
(
cold-verify-code-format
)
(
let*
((
nconst
,
nconst
)
(
inst-words
,
size
)
(
header-size
;; Note: we round the number of constants up to assure that
;; the code vector will be properly aligned.
(
round-up
(
+
vm:code-debug-info-slot
nconst
)
2
))
(
des
(
allocate-descriptor
*dynamic*
(
+
header-size
inst-words
)
vm:other-pointer-type
t
)))
(
write-descriptor
des
0
(
make-other-immediate-descriptor
header-size
vm:code-header-type
))
(
write-descriptor
des
vm:code-code-size-slot
(
make-fixnum-descriptor
inst-words
))
(
write-descriptor
des
vm:code-entry-points-slot
*nil-descriptor*
)
(
do
((
index
(
1-
(
+
nconst
vm:code-debug-info-slot
))
(
1-
index
)))
((
<
index
vm:code-debug-info-slot
))
(
write-descriptor
des
index
(
pop-stack
)))
(
read-n-bytes
*fasl-file*
(
descriptor-sap
des
)
(
ash
header-size
vm:word-shift
)
(
ash
inst-words
vm:word-shift
))
des
)))
(
define-cold-code-fop
fop-code
(
read-arg
4
)
(
read-arg
4
))
(
define-cold-code-fop
fop-small-code
(
read-arg
1
)
(
read-arg
2
))
(
clone-cold-fop
(
fop-alter-code
nil
)
(
fop-byte-alter-code
)
(
let
((
slot
(
clone-arg
))
(
value
(
pop-stack
))
(
code
(
pop-stack
)))
(
write-descriptor
code
slot
value
)))
(
defun
calc-offset
(
code-object
after-header
)
(
+
after-header
(
ash
(
ash
(
read-bits
code-object
0
)
(
-
vm:type-bits
))
vm:word-shift
)))
(
define-cold-fop
(
fop-function-entry
)
(
let*
((
type
(
pop-stack
))
(
arglist
(
pop-stack
))
(
name
(
pop-stack
))
(
code-object
(
pop-stack
))
(
offset
(
calc-offset
code-object
(
read-arg
4
)))
(
fn
(
descriptor-beyond
code-object
offset
vm:function-pointer-type
))
(
next
(
read-descriptor
code-object
vm:code-entry-points-slot
)))
(
unless
(
zerop
(
logand
offset
vm:lowtag-mask
))
(
warn
"Unaligned function entry: ~S at #x~X"
name
offset
))
(
write-descriptor
code-object
vm:code-entry-points-slot
fn
)
(
write-descriptor
fn
0
(
make-other-immediate-descriptor
(
ash
offset
(
-
vm:word-shift
))
vm:function-header-type
))
(
write-bits
fn
vm:function-entry-point-slot
(
if
(
=
(
c:backend-fasl-file-implementation
c:*backend*
)
c:sparc-fasl-file-implementation
)
(
descriptor-bits
fn
)
(
+
(
logandc2
(
descriptor-bits
fn
)
vm:lowtag-mask
)
(
ash
vm:function-code-offset
vm:word-shift
))))
(
write-descriptor
fn
vm:function-next-slot
next
:remember
:nothing
)
(
write-descriptor
fn
vm:function-name-slot
name
)
(
write-descriptor
fn
vm:function-arglist-slot
arglist
)
(
write-descriptor
fn
vm:function-type-slot
type
)
fn
))
(
define-cold-fop
(
fop-foreign-fixup
)
(
let*
((
kind
(
pop-stack
))
(
code-object
(
pop-stack
))
(
len
(
read-arg
1
))
(
sym
(
make-string
len
)))
(
read-n-bytes
*fasl-file*
sym
0
len
)
(
let
((
offset
(
calc-offset
code-object
(
read-arg
4
))))
(
do-cold-fixup
code-object
offset
(
lookup-foreign-symbol
sym
)
kind
))
code-object
))
(
define-cold-fop
(
fop-assembler-code
)
(
cold-verify-code-format
)
(
let*
((
length
(
read-arg
4
))
(
header-size
;; Note: we round the number of constants up to assure that
;; the code vector will be properly aligned.
(
round-up
vm:code-constants-offset
2
))
(
des
(
allocate-descriptor
*static*
(
+
header-size
length
)
vm:other-pointer-type
t
)))
(
write-descriptor
des
0
(
make-other-immediate-descriptor
header-size
vm:code-header-type
))
(
write-descriptor
des
vm:code-code-size-slot
(
make-fixnum-descriptor
length
))
(
write-descriptor
des
vm:code-entry-points-slot
*nil-descriptor*
)
(
write-descriptor
des
vm:code-debug-info-slot
*nil-descriptor*
)
(
read-n-bytes
*fasl-file*
(
descriptor-sap
des
)
(
ash
header-size
vm:word-shift
)
(
ash
length
vm:word-shift
))
des
))
(
define-cold-fop
(
fop-assembler-routine
)
(
let*
((
routine
(
pop-stack
))
(
des
(
pop-stack
))
(
offset
(
calc-offset
des
(
read-arg
4
))))
(
record-cold-assembler-routine
routine
(
+
(
logandc2
(
descriptor-bits
des
)
vm:lowtag-mask
)
offset
))
des
))
(
define-cold-fop
(
fop-assembler-fixup
)
(
let*
((
routine
(
pop-stack
))
(
kind
(
pop-stack
))
(
code-object
(
pop-stack
))
(
offset
(
calc-offset
code-object
(
read-arg
4
))))
(
record-cold-assembler-fixup
routine
code-object
offset
kind
)
code-object
))
(
define-cold-fop
(
fop-code-object-fixup
)
(
let*
((
kind
(
pop-stack
))
(
code-object
(
pop-stack
))
(
offset
(
calc-offset
code-object
(
read-arg
4
))))
(
do-cold-fixup
code-object
offset
(
descriptor-bits
code-object
)
kind
)
code-object
))
;;; Cold-Load loads stuff into the core image being built by rebinding
;;; the Fop-Functions table to a table of cold loading functions.
(
defun
cold-load
(
filename
)
"Loads the file named by FileName into the cold load image being built."
(
let*
((
*normal-fop-functions*
fop-functions
)
(
fop-functions
*cold-fop-functions*
)
(
*in-cold-load*
t
))
(
with-open-file
(
file
(
merge-pathnames
filename
(
make-pathname
:type
(
c:backend-fasl-file-type
c:*backend*
)))
:element-type
'
(
unsigned-byte
8
))
(
load
file
:verbose
nil
))))
;;;; Fixups and related stuff.
(
defvar
*cold-foreign-symbol-table*
)
(
defun
load-foreign-symbol-table
(
filename
)
(
with-open-file
(
file
filename
)
(
let*
((
version-line
(
read-line
file
))
(
last-space
(
position
#\Space
version-line
:from-end
t
))
(
version
(
parse-integer
version-line
:start
(
1+
last-space
))))
(
loop
(
let
((
line
(
read-line
file
nil
nil
)))
(
unless
line
(
return
))
(
multiple-value-bind
(
value
name
)
(
if
(
string=
"0x"
line
:end2
2
)
(
values
(
parse-integer
line
:start
2
:end
10
:radix
16
)
(
subseq
line
13
))
(
values
(
parse-integer
line
:end
8
:radix
16
)
(
subseq
line
11
)))
(
multiple-value-bind
(
old-value
found
)
(
gethash
name
*cold-foreign-symbol-table*
)
(
when
found
(
warn
"Redefining ~S from #x~X to #x~X"
name
old-value
value
)))
(
setf
(
gethash
name
*cold-foreign-symbol-table*
)
value
))))
version
)))
(
defun
lookup-foreign-symbol
(
name
)
(
multiple-value-bind
(
value
found
)
(
gethash
name
*cold-foreign-symbol-table*
0
)
(
unless
found
(
warn
"Undefined foreign symbol: ~S"
name
))
value
))
(
defvar
*cold-assembler-routines*
)
(
defvar
*cold-assembler-fixups*
)
(
defun
record-cold-assembler-routine
(
name
address
)
(
push
(
cons
name
address
)
*cold-assembler-routines*
))
(
defun
record-cold-assembler-fixup
(
routine
code-object
offset
&optional
(
kind
:both
))
(
push
(
list
routine
code-object
offset
kind
)
*cold-assembler-fixups*
))
(
defun
lookup-assembler-reference
(
symbol
)
(
let
((
value
(
cdr
(
assoc
symbol
*cold-assembler-routines*
))))
(
unless
value
(
warn
"Assembler routine ~S not defined."
symbol
))
value
))
(
defun
resolve-assembler-fixups
()
(
dolist
(
fixup
*cold-assembler-fixups*
)
(
let*
((
routine
(
car
fixup
))
(
value
(
lookup-assembler-reference
routine
)))
(
when
value
(
do-cold-fixup
(
second
fixup
)
(
third
fixup
)
value
(
fourth
fixup
))))))
(
defun
do-cold-fixup
(
code-object
offset
value
kind
)
(
let
((
sap
(
sap+
(
descriptor-sap
code-object
)
offset
)))
(
ecase
(
c:backend-fasl-file-implementation
c:*backend*
)
(
#.
c:pmax-fasl-file-implementation
(
ecase
kind
(
:jump
(
assert
(
zerop
(
ash
value
-26
)))
(
setf
(
ldb
(
byte
26
0
)
(
sap-ref-32
sap
0
))
(
ash
value
-2
)))
(
:lui
(
setf
(
sap-ref-16
sap
0
)
(
+
(
ash
value
-16
)
(
if
(
logbitp
15
value
)
1
0
))))
(
:addi
(
setf
(
sap-ref-16
sap
0
)
(
ldb
(
byte
16
0
)
value
)))))
(
#.
c:sparc-fasl-file-implementation
(
let
((
inst
(
maybe-byte-swap
(
sap-ref-32
sap
0
))))
(
ecase
kind
(
:call
(
error
"Can't deal with call fixups yet."
))
(
:sethi
(
setf
inst
(
dpb
(
ldb
(
byte
22
10
)
value
)
(
byte
22
0
)
inst
)))
(
:add
(
setf
inst
(
dpb
(
ldb
(
byte
10
0
)
value
)
(
byte
10
0
)
inst
))))
(
setf
(
sap-ref-32
sap
0
)
(
maybe-byte-swap
inst
))))
((
#.
c:rt-fasl-file-implementation
#.
c:rt-afpa-fasl-file-implementation
)
(
ecase
kind
(
:cal
(
setf
(
sap-ref-16
sap
2
)
(
maybe-byte-swap-short
(
ldb
(
byte
16
0
)
value
))))
(
:cau
(
let
((
high
(
ldb
(
byte
16
16
)
value
)))
(
setf
(
sap-ref-16
sap
2
)
(
maybe-byte-swap-short
(
if
(
logbitp
15
value
)
(
1+
high
)
high
)))))
(
:ba
(
unless
(
zerop
(
ash
value
-24
))
(
warn
"#x~8,'0X out of range for branch-absolute."
value
))
(
let
((
inst
(
maybe-byte-swap-short
(
sap-ref-16
sap
0
))))
(
setf
(
sap-ref-16
sap
0
)
(
maybe-byte-swap-short
(
dpb
(
ldb
(
byte
8
16
)
value
)
(
byte
8
0
)
inst
))))
(
setf
(
sap-ref-16
sap
2
)
(
maybe-byte-swap-short
(
ldb
(
byte
16
0
)
value
))))))
(
#.
c:x86-fasl-file-implementation
(
let*
((
disp
(
logior
(
sap-ref-8
sap
0
)
(
ash
(
sap-ref-8
sap
1
)
8
)
(
ash
(
sap-ref-8
sap
2
)
16
)
(
ash
(
sap-ref-8
sap
3
)
24
)))
(
bits
(
descriptor-bits
code-object
))
(
value
(
ecase
kind
(
:absolute
(
+
value
disp
))
(
:relative
(
-
(
+
value
disp
vm:other-pointer-type
)
bits
offset
4
)))))
(
setf
(
sap-ref-8
sap
0
)
(
ldb
(
byte
8
0
)
value
))
(
setf
(
sap-ref-8
sap
1
)
(
ldb
(
byte
8
8
)
value
))
(
setf
(
sap-ref-8
sap
2
)
(
ldb
(
byte
8
16
)
value
))
(
setf
(
sap-ref-8
sap
3
)
(
ldb
(
byte
8
24
)
value
))))
(
#.
c:hppa-fasl-file-implementation
(
let
((
inst
(
maybe-byte-swap
(
sap-ref-32
sap
0
))))
(
setf
(
sap-ref-32
sap
0
)
(
maybe-byte-swap
(
ecase
kind
(
:load
(
logior
(
ash
(
ldb
(
byte
11
0
)
value
)
1
)
(
logand
inst
#xffffc000
)))
(
:load-short
(
let
((
low-bits
(
ldb
(
byte
11
0
)
value
)))
(
assert
(
<=
0
low-bits
(
1-
(
ash
1
4
))))
(
logior
(
ash
low-bits
17
)
(
logand
inst
#xffe0ffff
))))
(
:hi
(
logior
(
ash
(
ldb
(
byte
5
13
)
value
)
16
)
(
ash
(
ldb
(
byte
2
18
)
value
)
14
)
(
ash
(
ldb
(
byte
2
11
)
value
)
12
)
(
ash
(
ldb
(
byte
11
20
)
value
)
1
)
(
ldb
(
byte
1
31
)
value
)
(
logand
inst
#xffe00000
)))
(
:branch
(
let
((
bits
(
ldb
(
byte
9
2
)
value
)))
(
assert
(
zerop
(
ldb
(
byte
2
0
)
value
)))
(
logior
(
ash
bits
3
)
(
logand
inst
#xffe0e002
)))))))))))
(
undefined-value
))
(
defun
linkage-info-to-core
()
(
let
((
result
*nil-descriptor*
))
(
maphash
#'
(
lambda
(
symbol
value
)
(
cold-push
(
cold-cons
(
string-to-core
symbol
)
(
number-to-core
value
))
result
))
*cold-foreign-symbol-table*
)
(
cold-setq
(
cold-intern
'*initial-foreign-symbols*
)
result
))
(
let
((
result
*nil-descriptor*
))
(
dolist
(
rtn
*cold-assembler-routines*
)
(
cold-push
(
cold-cons
(
cold-intern
(
car
rtn
))
(
number-to-core
(
cdr
rtn
)))
result
))
(
cold-setq
(
cold-intern
'*initial-assembler-routines*
)
result
)))
;;;; Emit C Header.
(
defun
tail-comp
(
string
tail
)
(
and
(
>=
(
length
string
)
(
length
tail
))
(
string=
string
tail
:start1
(
-
(
length
string
)
(
length
tail
)))))
(
defun
head-comp
(
string
head
)
(
and
(
>=
(
length
string
)
(
length
head
))
(
string=
string
head
:end1
(
length
head
))))
(
defun
emit-c-header-aux
()
(
format
t
"/*~% * Machine generated header file. Do not edit.~% */~2%"
)
(
format
t
"#ifndef _INTERNALS_H_~%#define _INTERNALS_H_~2%"
)
(
let
((
constants
nil
))
(
do-external-symbols
(
symbol
(
find-package
"VM"
))
(
when
(
constantp
symbol
)
(
let
((
name
(
symbol-name
symbol
)))
(
labels
((
record
(
prefix
string
priority
)
(
push
(
list
(
concatenate
'simple-string
prefix
(
delete
#\-
(
string-capitalize
string
)))
priority
(
symbol-value
symbol
)
(
documentation
symbol
'variable
))
constants
))
(
test-tail
(
tail
prefix
priority
)
(
when
(
tail-comp
name
tail
)
(
record
prefix
(
subseq
name
0
(
-
(
length
name
)
(
length
tail
)))
priority
)))
(
test-head
(
head
prefix
priority
)
(
when
(
head-comp
name
head
)
(
record
prefix
(
subseq
name
(
length
head
))
priority
))))
(
test-tail
"-TYPE"
"type_"
0
)
(
test-tail
"-TRAP"
"trap_"
2
)
(
test-head
"TRACE-TABLE-"
"tracetab_"
4
)
(
test-tail
"-SC-NUMBER"
"sc_"
5
)))))
(
setf
constants
(
sort
constants
#'
(
lambda
(
const1
const2
)
(
if
(
=
(
second
const1
)
(
second
const2
))
(
<
(
third
const1
)
(
third
const2
))
(
<
(
second
const1
)
(
second
const2
))))))
(
let
((
prev-priority
(
second
(
car
constants
))))
(
dolist
(
const
constants
)
(
unless
(
=
prev-priority
(
second
const
))
(
terpri
)
(
setf
prev-priority
(
second
const
)))
(
format
t
"#define ~A ~D~@[ /* ~A */~]~%"
(
first
const
)
(
third
const
)
(
fourth
const
))))
(
terpri
)
(
format
t
"#define ERRORS { \\~%"
)
(
loop
for
info
across
(
c:backend-internal-errors
c:*backend*
)
do
(
format
t
" ~S, \\~%"
(
cdr
info
)))
(
format
t
" NULL \\~%}~%"
)
(
terpri
))
(
let
((
structs
(
sort
(
copy-list
vm:*primitive-objects*
)
#'
string<
:key
#'
(
lambda
(
obj
)
(
symbol-name
(
vm:primitive-object-name
obj
))))))
(
format
t
"#ifndef LANGUAGE_ASSEMBLY~2%"
)
(
format
t
"#define LISPOBJ(x) ((lispobj)x)~2%"
)
(
dolist
(
obj
structs
)
(
format
t
"struct ~A {~%"
(
nsubstitute
#\_
#\-
(
string-downcase
(
string
(
vm:primitive-object-name
obj
)))))
(
when
(
vm:primitive-object-header
obj
)
(
format
t
" lispobj header;~%"
))
(
dolist
(
slot
(
vm:primitive-object-slots
obj
))
(
format
t
" ~A ~A~@[[0]~];~%"
(
getf
(
vm:slot-options
slot
)
:c-type
"lispobj"
)
(
nsubstitute
#\_
#\-
(
string-downcase
(
string
(
vm:slot-name
slot
))))
(
vm:slot-rest-p
slot
)))
(
format
t
"};~2%"
))
(
format
t
"#else /* LANGUAGE_ASSEMBLY */~2%"
)
(
format
t
"#define LISPOBJ(thing) thing~2%"
)
(
dolist
(
obj
structs
)
(
let
((
name
(
vm:primitive-object-name
obj
))
(
lowtag
(
or
(
eval
(
vm:primitive-object-lowtag
obj
))
0
)))
(
dolist
(
slot
(
vm:primitive-object-slots
obj
))
(
format
t
"#define ~A_~A_OFFSET ~D~%"
(
substitute
#\_
#\-
(
string
name
))
(
substitute
#\_
#\-
(
string
(
vm:slot-name
slot
)))
(
-
(
*
(
vm:slot-offset
slot
)
vm:word-bytes
)
lowtag
)))
(
terpri
)))
(
format
t
"#endif /* LANGUAGE_ASSEMBLY */~2%"
))
(
dolist
(
symbol
(
cons
nil
vm:static-symbols
))
(
format
t
"#define ~A LISPOBJ(0x~X)~%"
(
nsubstitute
#\_
#\-
(
remove-if
#'
(
lambda
(
char
)
(
member
char
'
(
#\%
#\*
)))
(
symbol-name
symbol
)))
(
if
(
boundp
'*static*
)
;; We actually ran Genesis, use the real value.
(
descriptor-bits
(
cold-intern
symbol
))
;; We didn't run Genesis, so guess at the address.
(
+
*heap-start*
vm:word-bytes
vm:other-pointer-type
(
if
symbol
(
vm:static-symbol-offset
symbol
)
0
)))))
(
format
t
"~%#endif~%"
))
;;; FILES-DIFFER --- internal
;;;
;;; Return T iff the two files differ.
;;;
(
defun
files-differ
(
name1
name2
)
(
with-open-file
(
file1
name1
)
(
with-open-file
(
file2
name2
)
(
or
(
not
(
=
(
file-length
file1
)
(
file-length
file2
)))
(
do
((
line1
"foo"
(
read-line
file1
nil
nil
))
(
line2
"foo"
(
read-line
file2
nil
nil
)))
((
and
(
null
line1
)
(
null
line2
))
nil
)
(
when
(
or
(
null
line1
)
(
null
line2
)
(
string/=
line1
line2
))
(
return
t
)))))))
(
defun
emit-c-header
(
name
)
(
let*
((
new-name
(
concatenate
'string
(
namestring
name
)
".NEW"
))
(
unix-newname
(
unix-namestring
new-name
nil
)))
(
with-open-file
(
*standard-output*
new-name
:direction
:output
:if-exists
:supersede
)
(
emit-c-header-aux
))
(
cond
((
not
(
probe-file
name
))
(
unix:unix-chmod
unix-newname
#o444
)
(
rename-file
new-name
name
))
((
files-differ
name
new-name
)
(
rename-file
name
(
concatenate
'simple-string
(
namestring
name
)
".OLD"
))
(
unix:unix-chmod
unix-newname
#o444
)
(
rename-file
new-name
name
)
(
warn
"The C header file has changed.~%Be sure to ~
re-compile the startup code."
))
(
t
(
unix:unix-unlink
unix-newname
))))
(
undefined-value
))
;;;; The actual genesis function.
(
defvar
*genesis-core-name*
"lisp.core"
)
(
defvar
*genesis-map-name*
nil
)
(
defvar
*genesis-c-header-name*
t
)
(
defvar
*genesis-symbol-table*
nil
)
(
defun
genesis
(
file-list
&key
(
symbol-table
*genesis-symbol-table*
)
(
core-name
*genesis-core-name*
)
(
map-name
*genesis-map-name*
)
(
header-name
*genesis-c-header-name*
))
"Builds a kernel Lisp image from the .FASL files specified in the given
File-List and writes it to a file named by Core-Name."
(
unless
symbol-table
(
error
"Can't genesis without a symbol-table."
))
(
format
t
"~&Building ~S for the ~A~%"
core-name
(
c:backend-version
c:*backend*
))
(
with-allocation-pool
(
let*
((
*block-owners*
(
make-array
16
:initial-element
nil
))
(
generations
(
make-generations
gen-default-policy
gen-tenure-policy
))
(
*static*
(
make-step
1
step-tenure-policy
(
second
generations
)))
(
*dynamic*
(
make-step
0
step-default-policy
(
first
generations
)))
(
*current-los-cluster*
nil
)
(
*current-init-functions-cons*
nil
)
(
*cold-packages*
nil
)
(
*cold-symbols*
(
make-hash-table
:test
#'
equal
))
(
*fdefn-objects*
(
make-hash-table
:test
#'
equal
))
(
*load-time-value-counter*
0
)
(
*cold-foreign-symbol-table*
(
make-hash-table
:test
#'
equal
))
(
*cold-assembler-routines*
nil
)
(
*cold-assembler-fixups*
nil
)
(
version
(
load-foreign-symbol-table
symbol-table
))
(
initial-function
nil
))
(
initialize-symbols
)
(
initialize-layouts
)
(
setf
*current-init-functions-cons*
*nil-descriptor*
)
(
initialize-static-fns
)
(
dolist
(
file
(
if
(
listp
file-list
)
file-list
(
list
file-list
)))
(
let
((
file
(
truename
(
merge-pathnames
file
(
make-pathname
:type
(
c:backend-fasl-file-type
c:*backend*
))))))
(
write-line
(
namestring
file
))
(
cold-load
file
))
(
maybe-gc
))
(
let
((
initial-fdefn
(
cold-fdefinition-object
(
cold-intern
'lisp::%initial-function
))))
(
setf
initial-function
(
read-bits
initial-fdefn
vm:fdefn-function-slot
)))
(
resolve-assembler-fixups
)
(
linkage-info-to-core
)
(
finish-symbols
)
(
finalize-load-time-value-noise
)
(
when
map-name
(
with-open-file
(
*standard-output*
(
if
(
eq
map-name
t
)
(
make-pathname
:type
"map"
:defaults
core-name
)
(
merge-pathnames
map-name
(
make-pathname
:type
"map"
:defaults
core-name
)))
:direction
:output
:if-exists
:supersede
)
(
write-map-file
)))
(
when
header-name
(
emit-c-header
(
merge-pathnames
(
if
(
eq
header-name
t
)
"internals.h"
(
merge-pathnames
header-name
(
make-pathname
:type
"h"
)))
core-name
)))
(
write-initial-core-file
core-name
version
generations
initial-function
))))
(
defun
write-map-file
()
(
let
((
*print-pretty*
nil
)
(
*print-case*
:upcase
))
(
format
t
"Assembler routines defined in core image:~2%"
)
(
dolist
(
routine
(
sort
(
copy-list
*cold-assembler-routines*
)
#'
<
:key
#'
cdr
))
(
format
t
"#x~8,'0X: ~S~%"
(
cdr
routine
)
(
car
routine
)))
(
let
((
funs
nil
)
(
undefs
nil
))
(
maphash
#'
(
lambda
(
name
fdefn
)
(
let
((
fun-bits
(
read-bits
fdefn
vm:fdefn-function-slot
)))
(
if
(
=
fun-bits
(
descriptor-bits
*nil-descriptor*
))
(
push
name
undefs
)
(
push
(
list*
name
fun-bits
(
read-bits
fdefn
vm:fdefn-raw-addr-slot
))
funs
))))
*fdefn-objects*
)
(
format
t
"~%~|~%Initially defined functions:~2%"
)
(
dolist
(
info
(
sort
funs
#'
<
:key
#'
cddr
))
(
format
t
"#x~8,'0X: ~S #x~8,'0X~%"
(
cddr
info
)
(
car
info
)
(
cadr
info
)))
(
format
t
"~%~|~%Undefined function references:~2%"
)
(
labels
((
key
(
name
)
(
etypecase
name
(
symbol
(
symbol-name
name
))
(
integer
(
prin1-to-string
name
))
(
list
(
key
(
second
name
))))))
(
dolist
(
fun
(
sort
undefs
#'
string<
:key
#'
key
))
(
format
t
"~S~%"
fun
)))
(
format
t
"~%~|~%Layout names:~2%"
)
(
collect
((
stuff
))
(
maphash
#'
(
lambda
(
name
desc
)
(
stuff
(
cons
(
descriptor-bits
desc
)
name
)))
*cold-layouts*
)
(
dolist
(
x
(
sort
(
stuff
)
#'
<
:key
#'
car
))
(
format
t
"#x~8,'0X: ~S~%"
(
car
x
)
(
cdr
x
))))))
(
undefined-value
))
;;;; Core file writing magic.
(
defstruct
(
range
(
:print-function
%print-range
))
;;
(
address
(
required-argument
)
:type
address
)
;;
bytes
;;
pieces
;;
next
)
(
defun
%print-range
(
range
stream
depth
)
(
declare
(
ignore
depth
))
(
print-unreadable-object
(
range
stream
:type
t
)
(
format
stream
"#x~8,'0X...#x~8,'0X"
(
range-address
range
)
(
+
(
range-address
range
)
(
range-bytes
range
)))))
(
defconstant
max-gap
(
ash
1
14
))
(
defun
compute-ranges
(
generations
)
(
let
((
ranges
nil
)
(
page-size
(
c:backend-page-size
c:*backend*
)))
(
flet
((
write-range
(
sap
addr
bytes
)
(
let*
((
start-offset
(
rem
addr
page-size
))
(
addr
(
-
addr
start-offset
))
(
sap
(
sap+
sap
(
-
start-offset
)))
(
pages
(
ceiling
(
+
bytes
start-offset
)
page-size
))
(
bytes
(
*
pages
page-size
)))
(
iterate
repeat
((
prev
nil
)
(
range
ranges
))
(
flet
((
insert
(
next
)
(
if
prev
(
setf
(
range-next
prev
)
next
)
(
setf
ranges
next
))))
(
if
range
(
if
(
<
addr
(
range-address
range
))
(
insert
(
make-range
:address
addr
:bytes
bytes
:pieces
(
list
(
cons
sap
bytes
))
:next
range
))
(
repeat
range
(
range-next
range
)))
(
insert
(
make-range
:address
addr
:bytes
bytes
:pieces
(
list
(
cons
sap
bytes
))))))))))
(
dolist
(
gen
generations
)
(
dolist
(
step
(
generation-steps
gen
))
(
do
((
block
(
step-block
step
)
(
block-next
block
)))
((
null
block
))
(
write-range
(
block-sap
block
)
(
block-base
block
)
(
block-free
block
)))))
(
do
((
cluster
*current-los-cluster*
(
cluster-next
cluster
)))
((
null
cluster
))
(
let*
((
first
(
cluster-first
cluster
))
(
base
(
cluster-base
cluster
))
(
offset
(
-
first
base
)))
(
write-range
(
sap+
(
cluster-sap
cluster
)
offset
)
first
(
-
(
cluster-free
cluster
)
offset
)))))
(
when
ranges
(
iterate
repeat
((
prev
ranges
)
(
next
(
range-next
ranges
)))
(
when
next
(
let*
((
prev-length
(
range-bytes
prev
))
(
prev-end
(
+
(
range-address
prev
)
prev-length
))
(
next-start
(
range-address
next
))
(
gap
(
-
next-start
prev-end
)))
(
if
(
<
gap
max-gap
)
(
let
((
next-next
(
range-next
next
)))
(
setf
(
range-pieces
prev
)
(
append
(
range-pieces
prev
)
(
cons
(
cons
(
int-sap
0
)
gap
)
(
range-pieces
next
))))
(
setf
(
range-next
prev
)
next-next
)
(
setf
(
range-bytes
prev
)
(
+
prev-length
gap
(
range-bytes
next
)))
(
repeat
prev
next-next
))
(
repeat
next
(
range-next
next
)))))))
ranges
))
(
defconstant
max-header-size
(
ash
1
12
))
(
defvar
*header-buffer*
)
(
defvar
*header-fill-pointer*
)
(
defun
write-long
(
num
)
(
let
((
fill-pointer
*header-fill-pointer*
))
(
setf
(
sap-ref-32
*header-buffer*
fill-pointer
)
(
maybe-byte-swap
num
))
(
setf
*header-fill-pointer*
(
+
fill-pointer
4
))))
(
defun
write-magic-number
(
version
)
(
write-long
(
logior
(
ash
(
char-code
#\C
)
24
)
(
ash
(
char-code
#\O
)
16
)
(
ash
(
char-code
#\R
)
8
)
(
char-code
#\E
)))
(
write-long
version
))
(
defun
write-chunks
(
chunks
)
(
do
((
range
chunks
(
range-next
range
)))
((
null
range
))
(
write-long
(
range-address
range
))
(
write-long
(
range-bytes
range
))
(
write-long
0
))
(
write-long
0
))
(
defun
really-do-writing
(
chunk-info-start
chunks
file
)
(
let
((
header-length
(
round-up
*header-fill-pointer*
(
c:backend-page-size
c:*backend*
))))
(
do
((
range
chunks
(
range-next
range
))
(
index
(
+
chunk-info-start
8
)
(
+
index
12
))
(
file-offset
header-length
(
+
file-offset
(
range-bytes
range
))))
((
null
range
))
(
setf
(
sap-ref-32
*header-buffer*
index
)
(
maybe-byte-swap
file-offset
))
(
format
t
"Writing ~:D bytes from #x~8,'0X...~%"
(
range-bytes
range
)
(
range-address
range
))
(
do
((
file-offset
file-offset
(
+
file-offset
(
cdar
pieces
)))
(
pieces
(
range-pieces
range
)
(
cdr
pieces
)))
((
null
pieces
))
(
let*
((
piece
(
car
pieces
))
(
sap
(
car
piece
)))
(
unless
(
zerop
(
sap-int
sap
))
(
file-position
file
file-offset
)
(
system:output-raw-bytes
file
sap
0
(
cdr
piece
))))))
(
file-position
file
0
)
(
system:output-raw-bytes
file
*header-buffer*
0
header-length
))
nil
)
(
defun
write-clusters
()
(
do
((
cluster
*current-los-cluster*
(
cluster-next
cluster
)))
((
null
cluster
))
(
let
((
base
(
cluster-base
cluster
)))
(
write-long
base
)
(
write-long
(
cluster-blocks
cluster
))
(
write-long
(
cluster-first
cluster
))
(
write-long
(
+
base
(
cluster-free
cluster
)))))
(
write-long
0
))
(
defun
write-generations
(
generations
)
(
write-long
(
length
generations
))
(
dolist
(
gen
generations
)
(
write-long
(
generation-policy
gen
))
(
let
((
steps
(
generation-steps
gen
)))
(
write-long
(
length
steps
))
(
dolist
(
step
steps
)
(
write-long
0
)
; step pointer
(
write-long
(
step-num
step
))
; step number
(
write-long
(
step-num
step
))
; promotion step
(
write-long
0
)
; max blocks
(
write-long
(
step-policy
step
))
(
do
((
block
(
step-block
step
)
(
block-next
block
)))
((
null
block
))
(
let
((
base
(
block-base
block
)))
(
write-long
base
)
(
write-long
(
+
base
(
block-free
block
)))))
(
write-long
0
)
(
let*
((
block
(
step-block
step
))
(
base
(
block-base
block
)))
(
write-long
(
+
base
(
block-free
block
)))
(
write-long
(
+
base
block-bytes
)))
(
write-long
(
step-first-LO
step
))
(
write-long
(
step-last-LO
step
))))
(
maphash
#'
(
lambda
(
address
ignore
)
(
declare
(
ignore
ignore
))
(
write-long
address
))
(
generation-remset
gen
))
(
write-long
0
)))
(
defun
write-initial-core-file
(
name
version
generations
initial-function
)
(
format
t
"[Building Initial Core File (version ~D) in file ~S: ~%"
version
(
namestring
name
))
(
force-output
)
(
let
((
*header-buffer*
(
nth-value
1
(
allocate-blocks
1
)))
(
*header-fill-pointer*
0
))
(
with-open-file
(
file
name
:direction
:output
:element-type
'
(
unsigned-byte
8
)
:if-exists
:rename-and-delete
)
(
write-magic-number
version
)
(
let*
((
chunks-start
*header-fill-pointer*
)
(
chunks
(
compute-ranges
generations
)))
(
write-chunks
chunks
)
(
write-clusters
)
(
write-generations
generations
)
(
write-long
initial-function
)
(
really-do-writing
chunks-start
chunks
file
))))
(
format
t
"done]~%"
)
(
force-output
))
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