543 lines
14 KiB
Factor
543 lines
14 KiB
Factor
! Copyright (C) 2004, 2011 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors arrays assocs byte-arrays classes classes.builtin
|
|
classes.private classes.tuple classes.tuple.private combinators
|
|
combinators.short-circuit combinators.smart
|
|
compiler.codegen.relocation compiler.units fry generic
|
|
generic.single.private grouping hashtables hashtables.private io
|
|
io.binary io.encodings.binary io.files io.pathnames kernel
|
|
kernel.private layouts locals make math math.order namespaces
|
|
namespaces.private parser parser.notes prettyprint quotations
|
|
sequences sequences.private source-files strings system vectors
|
|
vocabs words ;
|
|
IN: bootstrap.image
|
|
|
|
: arch-name ( os cpu -- arch )
|
|
2dup [ windows? ] [ ppc? ] bi* or [
|
|
[ drop unix ] dip
|
|
] unless
|
|
[ name>> ] bi@ "-" glue ;
|
|
|
|
: my-arch-name ( -- arch )
|
|
os cpu arch-name ;
|
|
|
|
: boot-image-name ( arch -- string )
|
|
"boot." ".image" surround ;
|
|
|
|
: my-boot-image-name ( -- string )
|
|
my-arch-name boot-image-name ;
|
|
|
|
CONSTANT: image-names
|
|
{
|
|
"windows-x86.32" "unix-x86.32"
|
|
"windows-x86.64" "unix-x86.64"
|
|
}
|
|
|
|
<PRIVATE
|
|
|
|
! Object cache; we only consider numbers equal if they have the
|
|
! same type
|
|
TUPLE: eql-wrapper { obj read-only } ;
|
|
|
|
C: <eql-wrapper> eql-wrapper
|
|
|
|
M: eql-wrapper hashcode* obj>> hashcode* ;
|
|
|
|
GENERIC: (eql?) ( obj1 obj2 -- ? )
|
|
|
|
: eql? ( obj1 obj2 -- ? )
|
|
{ [ [ class-of ] same? ] [ (eql?) ] } 2&& ;
|
|
|
|
M: fixnum (eql?) eq? ;
|
|
|
|
M: bignum (eql?) { bignum bignum } declare = ;
|
|
|
|
M: float (eql?) fp-bitwise= ;
|
|
|
|
M: sequence (eql?)
|
|
2dup [ length ] same? [ [ eql? ] 2all? ] [ 2drop f ] if ;
|
|
|
|
M: object (eql?) = ;
|
|
|
|
M: eql-wrapper equal?
|
|
over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
|
|
|
|
TUPLE: eq-wrapper { obj read-only } ;
|
|
|
|
C: <eq-wrapper> eq-wrapper
|
|
|
|
M: eq-wrapper equal?
|
|
over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
|
|
|
|
M: eq-wrapper hashcode*
|
|
nip obj>> identity-hashcode ;
|
|
|
|
SYMBOL: objects
|
|
|
|
: cache-eql-object ( obj quot -- value )
|
|
[ <eql-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
|
|
|
|
: cache-eq-object ( obj quot -- value )
|
|
[ <eq-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
|
|
|
|
: lookup-object ( obj -- n/f )
|
|
<eq-wrapper> objects get at ;
|
|
|
|
: put-object ( n obj -- )
|
|
<eq-wrapper> objects get set-at ;
|
|
|
|
! Constants need to be synced with
|
|
! vm/image.hpp
|
|
CONSTANT: image-magic 0x0f0e0d0c
|
|
CONSTANT: image-version 4
|
|
|
|
CONSTANT: data-base 1024
|
|
|
|
CONSTANT: header-size 10
|
|
|
|
CONSTANT: data-heap-size-offset 3
|
|
|
|
SYMBOL: sub-primitives
|
|
|
|
SYMBOL: special-objects
|
|
|
|
:: jit-conditional ( test-quot false-quot -- )
|
|
[ 0 test-quot call ] B{ } make length :> len
|
|
building get length extra-offset get + len +
|
|
[ extra-offset set false-quot call ] B{ } make
|
|
[ length test-quot call ] [ % ] bi ; inline
|
|
|
|
: make-jit ( quot -- parameters literals code )
|
|
[
|
|
0 extra-offset set
|
|
init-relocation
|
|
call( -- )
|
|
parameter-table get >array
|
|
literal-table get >array
|
|
relocation-table get >byte-array
|
|
] B{ } make 2array ;
|
|
|
|
: make-jit-no-params ( quot -- code )
|
|
make-jit 2nip ;
|
|
|
|
: jit-define ( quot n -- )
|
|
[ make-jit-no-params ] dip special-objects get set-at ;
|
|
|
|
: define-sub-primitive ( quot word -- )
|
|
[ make-jit 3array ] dip sub-primitives get set-at ;
|
|
|
|
: define-sub-primitives ( assoc -- )
|
|
[ swap define-sub-primitive ] assoc-each ;
|
|
|
|
: define-combinator-primitive ( quot non-tail-quot tail-quot word -- )
|
|
[
|
|
[
|
|
[ make-jit ]
|
|
[ make-jit-no-params ]
|
|
[ make-jit-no-params ]
|
|
tri*
|
|
] output>array
|
|
] dip
|
|
sub-primitives get set-at ;
|
|
|
|
SYMBOL: bootstrapping-image
|
|
|
|
! Image output format
|
|
SYMBOL: big-endian
|
|
|
|
SYMBOL: architecture
|
|
|
|
: emit ( cell -- ) bootstrapping-image get push ;
|
|
|
|
: emit-64 ( cell -- )
|
|
bootstrap-cell 8 = [
|
|
emit
|
|
] [
|
|
d>w/w big-endian get [ swap ] unless emit emit
|
|
] if ;
|
|
|
|
: emit-seq ( seq -- ) bootstrapping-image get push-all ;
|
|
|
|
: fixup ( value offset -- ) bootstrapping-image get set-nth ;
|
|
|
|
: heap-size ( -- size )
|
|
bootstrapping-image get length header-size - special-object-count -
|
|
bootstrap-cells ;
|
|
|
|
: here ( -- size ) heap-size data-base + ;
|
|
|
|
: here-as ( tag -- pointer ) here bitor ;
|
|
|
|
: (align-here) ( alignment -- )
|
|
[ here neg ] dip rem
|
|
[ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
|
|
|
|
: align-here ( -- )
|
|
data-alignment get (align-here) ;
|
|
|
|
: emit-fixnum ( n -- ) tag-fixnum emit ;
|
|
|
|
: emit-header ( n -- ) tag-header emit ;
|
|
|
|
: emit-object ( class quot -- addr )
|
|
[ type-number ] dip over here-as
|
|
[ swap emit-header call align-here ] dip ; inline
|
|
|
|
! Read any object for emitting.
|
|
GENERIC: prepare-object ( obj -- ptr )
|
|
|
|
! Image header
|
|
|
|
: emit-image-header ( -- )
|
|
image-magic emit
|
|
image-version emit
|
|
data-base emit ! relocation base at end of header
|
|
0 emit ! size of data heap set later
|
|
0 emit ! reloc base of code heap is 0
|
|
0 emit ! size of code heap is 0
|
|
0 emit ! reserved
|
|
0 emit ! reserved
|
|
0 emit ! reserved
|
|
0 emit ! reserved
|
|
special-object-count [ f prepare-object emit ] times ;
|
|
|
|
! Bignums
|
|
|
|
: bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
|
|
|
|
: bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
|
|
|
|
: bignum>sequence ( n -- seq )
|
|
! n is positive or zero.
|
|
[ dup 0 > ]
|
|
[ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
|
|
produce nip ;
|
|
|
|
: emit-bignum ( n -- )
|
|
dup dup 0 < [ neg ] when bignum>sequence
|
|
[ nip length 1 + emit-fixnum ]
|
|
[ drop 0 < 1 0 ? emit ]
|
|
[ nip emit-seq ]
|
|
2tri ;
|
|
|
|
M: bignum prepare-object
|
|
[
|
|
bignum [ emit-bignum ] emit-object
|
|
] cache-eql-object ;
|
|
|
|
! Fixnums
|
|
|
|
M: fixnum prepare-object
|
|
! When generating a 32-bit image on a 64-bit system,
|
|
! some fixnums should be bignums.
|
|
dup
|
|
bootstrap-most-negative-fixnum
|
|
bootstrap-most-positive-fixnum between?
|
|
[ tag-fixnum ] [ >bignum prepare-object ] if ;
|
|
|
|
TUPLE: fake-bignum n ;
|
|
|
|
C: <fake-bignum> fake-bignum
|
|
|
|
M: fake-bignum prepare-object n>> tag-fixnum ;
|
|
|
|
! Floats
|
|
|
|
M: float prepare-object
|
|
[
|
|
float [
|
|
8 (align-here) double>bits emit-64
|
|
] emit-object
|
|
] cache-eql-object ;
|
|
|
|
! Special objects
|
|
|
|
! Padded with fixnums for 8-byte alignment
|
|
M: f prepare-object drop \ f type-number ;
|
|
|
|
! Words
|
|
|
|
: word-sub-primitive ( word -- obj )
|
|
[ target-word ] with-global sub-primitives get at ;
|
|
|
|
: emit-word ( word -- )
|
|
[
|
|
[ subwords [ emit-word ] each ]
|
|
[
|
|
[
|
|
{
|
|
[ hashcode <fake-bignum> ]
|
|
[ name>> ]
|
|
[ vocabulary>> ]
|
|
[ def>> ]
|
|
[ props>> ]
|
|
[ pic-def>> ]
|
|
[ pic-tail-def>> ]
|
|
[ word-sub-primitive ]
|
|
[ drop 0 ] ! entry point
|
|
} cleave
|
|
] output>array [ prepare-object ] map!
|
|
] bi
|
|
\ word [ emit-seq ] emit-object
|
|
] keep put-object ;
|
|
|
|
ERROR: not-in-image vocabulary word ;
|
|
|
|
: transfer-word ( word -- word )
|
|
[ target-word ] keep or ;
|
|
|
|
: fixup-word ( word -- offset )
|
|
transfer-word dup lookup-object
|
|
[ ] [ [ vocabulary>> ] [ name>> ] bi not-in-image ] ?if ;
|
|
|
|
: fixup-words ( -- )
|
|
bootstrapping-image get [ dup word? [ fixup-word ] when ] map! drop ;
|
|
|
|
M: word prepare-object ;
|
|
|
|
! Wrappers
|
|
|
|
M: wrapper prepare-object
|
|
[ wrapped>> prepare-object wrapper [ emit ] emit-object ] cache-eql-object ;
|
|
|
|
! Strings
|
|
: native> ( object -- object )
|
|
big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
|
|
|
|
: emit-bytes ( seq -- )
|
|
bootstrap-cell <groups> native> emit-seq ;
|
|
|
|
: pad-bytes ( seq -- newseq )
|
|
dup length bootstrap-cell align 0 pad-tail ;
|
|
|
|
: extended-part ( str -- str' )
|
|
dup [ 128 < ] all? [ drop f ] [
|
|
[ -7 shift 1 bitxor ] { } map-as
|
|
big-endian get
|
|
[ [ 2 >be ] { } map-as ]
|
|
[ [ 2 >le ] { } map-as ] if
|
|
B{ } join
|
|
] if ;
|
|
|
|
: ascii-part ( str -- str' )
|
|
[
|
|
[ 128 mod ] [ 128 >= ] bi
|
|
[ 128 bitor ] when
|
|
] B{ } map-as ;
|
|
|
|
: emit-string ( string -- ptr )
|
|
[ length ] [ extended-part prepare-object ] [ ] tri
|
|
string [
|
|
[ emit-fixnum ]
|
|
[ emit ]
|
|
[ f prepare-object emit ascii-part pad-bytes emit-bytes ]
|
|
tri*
|
|
] emit-object ;
|
|
|
|
M: string prepare-object
|
|
! We pool strings so that each string is only written once
|
|
! to the image
|
|
[ emit-string ] cache-eql-object ;
|
|
|
|
: assert-empty ( seq -- )
|
|
length 0 assert= ;
|
|
|
|
: emit-dummy-array ( obj type -- ptr )
|
|
[ assert-empty ] [
|
|
[ 0 emit-fixnum ] emit-object
|
|
] bi* ;
|
|
|
|
M: byte-array prepare-object
|
|
[
|
|
byte-array [
|
|
dup length emit-fixnum
|
|
bootstrap-cell 4 = [ 0 emit 0 emit ] when
|
|
pad-bytes emit-bytes
|
|
] emit-object
|
|
] cache-eq-object ;
|
|
|
|
! Tuples
|
|
ERROR: tuple-removed class ;
|
|
|
|
: require-tuple-layout ( word -- layout )
|
|
dup tuple-layout [ ] [ tuple-removed ] ?if ;
|
|
|
|
: (emit-tuple) ( tuple -- pointer )
|
|
[ tuple-slots ]
|
|
[ class-of transfer-word require-tuple-layout ] bi prefix [ prepare-object ] map
|
|
tuple [ emit-seq ] emit-object ;
|
|
|
|
: emit-tuple ( tuple -- pointer )
|
|
dup class-of name>> "tombstone" =
|
|
[ [ (emit-tuple) ] cache-eql-object ]
|
|
[ [ (emit-tuple) ] cache-eq-object ]
|
|
if ;
|
|
|
|
M: tuple prepare-object emit-tuple ;
|
|
|
|
M: tombstone prepare-object
|
|
state>> "+tombstone+" "+empty+" ?
|
|
"hashtables.private" lookup-word def>> first
|
|
[ emit-tuple ] cache-eql-object ;
|
|
|
|
! Arrays
|
|
: emit-array ( array -- offset )
|
|
[ prepare-object ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
|
|
|
|
M: array prepare-object [ emit-array ] cache-eq-object ;
|
|
|
|
! This is a hack. We need to detect arrays which are tuple
|
|
! layout arrays so that they can be internalized, but making
|
|
! them a built-in type is not worth it.
|
|
PREDICATE: tuple-layout-array < array
|
|
dup length 5 >= [
|
|
{
|
|
[ first-unsafe tuple-class? ]
|
|
[ second-unsafe fixnum? ]
|
|
[ third-unsafe fixnum? ]
|
|
} 1&&
|
|
] [ drop f ] if ;
|
|
|
|
M: tuple-layout-array prepare-object
|
|
[
|
|
[ dup integer? [ <fake-bignum> ] when ] map
|
|
emit-array
|
|
] cache-eql-object ;
|
|
|
|
! Quotations
|
|
|
|
M: quotation prepare-object
|
|
[
|
|
array>> prepare-object
|
|
quotation [
|
|
emit ! array
|
|
f prepare-object emit ! cached-effect
|
|
f prepare-object emit ! cache-counter
|
|
0 emit ! entry point
|
|
] emit-object
|
|
] cache-eql-object ;
|
|
|
|
! End of the image
|
|
|
|
: emit-words ( -- )
|
|
all-words [ emit-word ] each ;
|
|
|
|
: emit-singletons ( -- )
|
|
t OBJ-CANONICAL-TRUE special-objects get set-at
|
|
0 >bignum OBJ-BIGNUM-ZERO special-objects get set-at
|
|
1 >bignum OBJ-BIGNUM-POS-ONE special-objects get set-at
|
|
-1 >bignum OBJ-BIGNUM-NEG-ONE special-objects get set-at ;
|
|
|
|
: create-global-hashtable ( -- global-hashtable )
|
|
{
|
|
dictionary source-files builtins
|
|
update-map implementors-map
|
|
} [ [ bootstrap-word ] [ get global-box boa ] bi ] H{ } map>assoc
|
|
{
|
|
class<=-cache class-not-cache classes-intersect-cache
|
|
class-and-cache class-or-cache next-method-quot-cache
|
|
} [ H{ } clone global-box boa ] H{ } map>assoc assoc-union
|
|
global-hashtable boa ;
|
|
|
|
: emit-global ( -- )
|
|
create-global-hashtable
|
|
OBJ-GLOBAL special-objects get set-at ;
|
|
|
|
: emit-jit-data ( -- )
|
|
{
|
|
{ JIT-IF-WORD if }
|
|
{ JIT-PRIMITIVE-WORD do-primitive }
|
|
{ JIT-DIP-WORD dip }
|
|
{ JIT-2DIP-WORD 2dip }
|
|
{ JIT-3DIP-WORD 3dip }
|
|
{ PIC-MISS-WORD inline-cache-miss }
|
|
{ PIC-MISS-TAIL-WORD inline-cache-miss-tail }
|
|
{ MEGA-LOOKUP-WORD mega-cache-lookup }
|
|
{ MEGA-MISS-WORD mega-cache-miss }
|
|
{ JIT-DECLARE-WORD declare }
|
|
{ C-TO-FACTOR-WORD c-to-factor }
|
|
{ LAZY-JIT-COMPILE-WORD lazy-jit-compile }
|
|
{ UNWIND-NATIVE-FRAMES-WORD unwind-native-frames }
|
|
{ GET-FPU-STATE-WORD fpu-state }
|
|
{ SET-FPU-STATE-WORD set-fpu-state }
|
|
{ SIGNAL-HANDLER-WORD signal-handler }
|
|
{ LEAF-SIGNAL-HANDLER-WORD leaf-signal-handler }
|
|
}
|
|
\ OBJ-UNDEFINED undefined-def 2array suffix [
|
|
swap execute( -- x ) special-objects get set-at
|
|
] assoc-each ;
|
|
|
|
: emit-special-object ( obj idx -- )
|
|
[ prepare-object ] [ header-size + ] bi* fixup ;
|
|
|
|
: emit-special-objects ( -- )
|
|
special-objects get [ swap emit-special-object ] assoc-each ;
|
|
|
|
: fixup-header ( -- )
|
|
heap-size data-heap-size-offset fixup ;
|
|
|
|
: build-generics ( -- )
|
|
[
|
|
all-words
|
|
[ generic? ] filter
|
|
[ make-generic ] each
|
|
] with-compilation-unit ;
|
|
|
|
: build-image ( -- image )
|
|
600,000 <vector> bootstrapping-image set
|
|
60,000 <hashtable> objects set
|
|
emit-image-header
|
|
"Building generic words..." print flush
|
|
build-generics
|
|
"Serializing words..." print flush
|
|
emit-words
|
|
"Serializing JIT data..." print flush
|
|
emit-jit-data
|
|
"Serializing global namespace..." print flush
|
|
emit-global
|
|
"Serializing singletons..." print flush
|
|
emit-singletons
|
|
"Serializing special object table..." print flush
|
|
emit-special-objects
|
|
"Performing word fixups..." print flush
|
|
fixup-words
|
|
"Performing header fixups..." print flush
|
|
fixup-header
|
|
"Image length: " write bootstrapping-image get length .
|
|
"Object cache size: " write objects get assoc-size .
|
|
\ last-word global delete-at
|
|
bootstrapping-image get ;
|
|
|
|
! Image output
|
|
|
|
: (write-image) ( image -- )
|
|
bootstrap-cell output-stream get
|
|
big-endian get
|
|
[ '[ _ >be _ stream-write ] each ]
|
|
[ '[ _ >le _ stream-write ] each ] if ;
|
|
|
|
: write-image ( image -- )
|
|
"Writing image to " write
|
|
architecture get boot-image-name resource-path
|
|
[ write "..." print flush ]
|
|
[ binary [ (write-image) ] with-file-writer ] bi ;
|
|
|
|
PRIVATE>
|
|
|
|
: make-image ( arch -- )
|
|
architecture associate H{
|
|
{ parser-quiet? f }
|
|
{ auto-use? f }
|
|
} assoc-union! [
|
|
H{ } clone special-objects set
|
|
"resource:/core/bootstrap/stage1.factor" run-file
|
|
build-image
|
|
write-image
|
|
] with-variables ;
|
|
|
|
: make-images ( -- )
|
|
image-names [ make-image ] each ;
|
|
|
|
: make-my-image ( -- )
|
|
my-arch-name make-image ;
|