1 ! Copyright (C) 2004, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien arrays byte-arrays generic assocs hashtables assocs
4 hashtables.private io kernel kernel.private math namespaces
5 parser prettyprint sequences sequences.private strings sbufs
6 vectors words quotations assocs system layouts splitting
7 grouping growable classes classes.builtin classes.tuple
8 classes.tuple.private words.private io.binary io.files vocabs
9 vocabs.loader source-files definitions debugger
10 quotations.private sequences.private combinators
11 io.encodings.binary math.order math.private accessors slots.private ;
16 dup "ppc" = [ >r os name>> "-" r> 3append ] when ;
18 : boot-image-name ( arch -- string )
19 "boot." swap ".image" 3append ;
21 : my-boot-image-name ( -- string )
22 my-arch boot-image-name ;
28 "linux-ppc" "macosx-ppc"
34 ! Object cache; we only consider numbers equal if they have the
40 M: id hashcode* obj>> hashcode* ;
42 GENERIC: (eql?) ( obj1 obj2 -- ? )
44 : eql? ( obj1 obj2 -- ? )
45 [ (eql?) ] [ [ class ] bi@ = ] 2bi and ;
52 [ [ eql? ] 2all? ] [ 2drop f ] if
58 over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
62 : (objects) <id> objects get ; inline
64 : lookup-object ( obj -- n/f ) (objects) at ;
66 : put-object ( n obj -- ) (objects) set-at ;
68 : cache-object ( obj quot -- value )
69 >r (objects) r> [ obj>> ] prepose cache ; inline
73 : image-magic HEX: 0f0e0d0c ; inline
74 : image-version 4 ; inline
76 : data-base 1024 ; inline
78 : userenv-size 70 ; inline
80 : header-size 10 ; inline
82 : data-heap-size-offset 3 ; inline
86 : -1-offset 9 ; inline
88 SYMBOL: sub-primitives
90 : make-jit ( quot rc rt offset -- quad )
91 { [ { } make ] [ ] [ ] [ ] } spread 4array ; inline
93 : jit-define ( quot rc rt offset name -- )
94 >r make-jit r> set ; inline
96 : define-sub-primitive ( quot rc rt offset word -- )
97 >r make-jit r> sub-primitives get set-at ;
99 ! The image being constructed; a vector of word-size integers
102 ! Image output format
105 ! Bootstrap architecture name
108 ! Bootstrap global namesapce
109 SYMBOL: bootstrap-global
111 ! Boot quotation, set in stage1.factor
112 SYMBOL: bootstrap-boot-quot
115 SYMBOL: jit-code-format
117 SYMBOL: jit-primitive-word
118 SYMBOL: jit-primitive
119 SYMBOL: jit-word-jump
120 SYMBOL: jit-word-call
121 SYMBOL: jit-push-literal
122 SYMBOL: jit-push-immediate
125 SYMBOL: jit-dispatch-word
129 SYMBOL: jit-profiling
130 SYMBOL: jit-declare-word
132 ! Default definition for undefined words
133 SYMBOL: undefined-quot
135 : userenv-offset ( symbol -- n )
137 { bootstrap-boot-quot 20 }
138 { bootstrap-global 21 }
139 { jit-code-format 22 }
141 { jit-primitive-word 24 }
145 { jit-push-literal 28 }
148 { jit-dispatch-word 31 }
153 { jit-push-immediate 36 }
154 { jit-declare-word 42 }
155 { undefined-quot 60 }
158 : emit ( cell -- ) image get push ;
160 : emit-64 ( cell -- )
164 d>w/w big-endian get [ swap ] unless emit emit
167 : emit-seq ( seq -- ) image get push-all ;
169 : fixup ( value offset -- ) image get set-nth ;
171 : heap-size ( -- size )
172 image get length header-size - userenv-size -
175 : here ( -- size ) heap-size data-base + ;
177 : here-as ( tag -- pointer ) here bitor ;
180 here 8 mod 4 = [ 0 emit ] when ;
182 : emit-fixnum ( n -- ) tag-fixnum emit ;
184 : emit-object ( header tag quot -- addr )
185 swap here-as >r swap tag-fixnum emit call align-here r> ;
188 ! Write an object to the image.
189 GENERIC: ' ( obj -- ptr )
196 data-base emit ! relocation base at end of header
197 0 emit ! size of data heap set later
198 0 emit ! reloc base of code heap is 0
199 0 emit ! size of code heap is 0
200 0 emit ! pointer to t object
201 0 emit ! pointer to bignum 0
202 0 emit ! pointer to bignum 1
203 0 emit ! pointer to bignum -1
204 userenv-size [ f ' emit ] times ;
206 : emit-userenv ( symbol -- )
207 [ get ' ] [ userenv-offset ] bi fixup ;
211 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
213 : bignum-radix ( -- n ) bignum-bits 2^ 1- ;
215 : bignum>seq ( n -- seq )
216 #! n is positive or zero.
218 [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
221 : emit-bignum ( n -- )
222 dup dup 0 < [ neg ] when bignum>seq
223 [ nip length 1+ emit-fixnum ]
224 [ drop 0 < 1 0 ? emit ]
230 bignum tag-number dup [ emit-bignum ] emit-object
236 #! When generating a 32-bit image on a 64-bit system,
237 #! some fixnums should be bignums.
239 bootstrap-most-negative-fixnum
240 bootstrap-most-positive-fixnum between?
241 [ tag-fixnum ] [ >bignum ' ] if ;
243 TUPLE: fake-bignum n ;
245 C: <fake-bignum> fake-bignum
247 M: fake-bignum ' n>> tag-fixnum ;
253 float tag-number dup [
254 align-here double>bits emit-64
260 ! Padded with fixnums for 8-byte alignment
262 : t, ( -- ) t t-offset fixup ;
265 #! f is #define F RETAG(0,F_TYPE)
266 drop \ f tag-number ;
268 : 0, ( -- ) 0 >bignum ' 0-offset fixup ;
269 : 1, ( -- ) 1 >bignum ' 1-offset fixup ;
270 : -1, ( -- ) -1 >bignum ' -1-offset fixup ;
274 : word-sub-primitive ( word -- obj )
275 global [ target-word ] bind sub-primitives get at ;
277 : emit-word ( word -- )
279 [ subwords [ emit-word ] each ]
290 [ word-sub-primitive , ]
293 [ drop 0 , ] ! profiling
297 \ word type-number object tag-number
298 [ emit-seq ] emit-object
301 : word-error ( word msg -- * )
302 [ % dup vocabulary>> % " " % name>> % ] "" make throw ;
304 : transfer-word ( word -- word )
305 [ target-word ] keep or ;
307 : fixup-word ( word -- offset )
308 transfer-word dup lookup-object
309 [ ] [ "Not in image: " word-error ] ?if ;
312 image get [ dup word? [ fixup-word ] when ] change-each ;
319 wrapped>> ' wrapper type-number object tag-number
320 [ emit ] emit-object ;
323 : emit-bytes ( seq -- )
324 bootstrap-cell <groups>
325 big-endian get [ [ be> ] map ] [ [ le> ] map ] if
328 : pad-bytes ( seq -- newseq )
329 dup length bootstrap-cell align 0 pad-right ;
331 : emit-string ( string -- ptr )
332 string type-number object tag-number [
333 dup length emit-fixnum
340 #! We pool strings so that each string is only written once
342 [ emit-string ] cache-object ;
344 : assert-empty ( seq -- )
347 : emit-dummy-array ( obj type -- ptr )
349 type-number object tag-number
350 [ 0 emit-fixnum ] emit-object
354 byte-array type-number object tag-number [
355 dup length emit-fixnum
360 : (emit-tuple) ( tuple -- pointer )
361 [ tuple>array rest-slice ]
362 [ class transfer-word tuple-layout ] bi prefix [ ' ] map
363 tuple type-number dup [ emit-seq ] emit-object ;
365 : emit-tuple ( tuple -- pointer )
366 dup class name>> "tombstone" =
367 [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
369 M: tuple ' emit-tuple ;
382 \ tuple-layout type-number
383 object tag-number [ emit-seq ] emit-object
388 "((tombstone))" "((empty))" ? "hashtables.private" lookup
389 def>> first [ emit-tuple ] cache-object ;
393 [ ' ] map array type-number object tag-number
394 [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
401 quotation type-number object tag-number [
403 f ' emit ! compiled>>
412 all-words [ emit-word ] each ;
417 dictionary source-files builtins
418 update-map implementors-map class<=-cache
419 class-not-cache classes-intersect-cache class-and-cache
421 } [ dup get swap bootstrap-word set ] each
424 bootstrap-global emit-userenv ;
426 : emit-boot-quot ( -- )
427 bootstrap-boot-quot emit-userenv ;
429 : emit-jit-data ( -- )
431 \ dispatch jit-dispatch-word set
432 \ do-primitive jit-primitive-word set
433 \ declare jit-declare-word set
434 [ undefined ] undefined-quot set
453 } [ emit-userenv ] each ;
455 : fixup-header ( -- )
456 heap-size data-heap-size-offset fixup ;
458 : build-image ( -- image )
459 800000 <vector> image set
460 20000 <hashtable> objects set
461 emit-header t, 0, 1, -1,
462 "Serializing words..." print flush
464 "Serializing JIT data..." print flush
466 "Serializing global namespace..." print flush
468 "Serializing boot quotation..." print flush
470 "Performing word fixups..." print flush
472 "Performing header fixups..." print flush
474 "Image length: " write image get length .
475 "Object cache size: " write objects get assoc-size .
476 \ word global delete-at
481 : (write-image) ( image -- )
482 bootstrap-cell big-endian get [
483 [ >be write ] curry each
485 [ >le write ] curry each
488 : write-image ( image -- )
489 "Writing image to " write
490 architecture get boot-image-name resource-path
491 [ write "..." print flush ]
492 [ binary [ (write-image) ] with-file-writer ] bi ;
496 : make-image ( arch -- )
499 "resource:/core/bootstrap/stage1.factor" run-file
505 images [ make-image ] each ;