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 make
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"
33 ! Object cache; we only consider numbers equal if they have the
39 M: id hashcode* obj>> hashcode* ;
41 GENERIC: (eql?) ( obj1 obj2 -- ? )
43 : eql? ( obj1 obj2 -- ? )
44 [ (eql?) ] [ [ class ] bi@ = ] 2bi and ;
51 [ [ eql? ] 2all? ] [ 2drop f ] if
57 over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
61 : (objects) <id> objects get ; inline
63 : lookup-object ( obj -- n/f ) (objects) at ;
65 : put-object ( n obj -- ) (objects) set-at ;
67 : cache-object ( obj quot -- value )
68 >r (objects) r> [ obj>> ] prepose cache ; inline
72 : image-magic HEX: 0f0e0d0c ; inline
73 : image-version 4 ; inline
75 : data-base 1024 ; inline
77 : userenv-size 70 ; inline
79 : header-size 10 ; inline
81 : data-heap-size-offset 3 ; inline
85 : -1-offset 9 ; inline
87 SYMBOL: sub-primitives
89 : make-jit ( quot rc rt offset -- quad )
90 { [ { } make ] [ ] [ ] [ ] } spread 4array ; inline
92 : jit-define ( quot rc rt offset name -- )
93 >r make-jit r> set ; inline
95 : define-sub-primitive ( quot rc rt offset word -- )
96 >r make-jit r> sub-primitives get set-at ;
98 ! The image being constructed; a vector of word-size integers
101 ! Image output format
104 ! Bootstrap architecture name
107 ! Bootstrap global namesapce
108 SYMBOL: bootstrap-global
110 ! Boot quotation, set in stage1.factor
111 SYMBOL: bootstrap-boot-quot
114 SYMBOL: jit-code-format
116 SYMBOL: jit-primitive-word
117 SYMBOL: jit-primitive
118 SYMBOL: jit-word-jump
119 SYMBOL: jit-word-call
120 SYMBOL: jit-push-literal
121 SYMBOL: jit-push-immediate
124 SYMBOL: jit-dispatch-word
128 SYMBOL: jit-profiling
129 SYMBOL: jit-declare-word
131 ! Default definition for undefined words
132 SYMBOL: undefined-quot
134 : userenv-offset ( symbol -- n )
136 { bootstrap-boot-quot 20 }
137 { bootstrap-global 21 }
138 { jit-code-format 22 }
140 { jit-primitive-word 24 }
144 { jit-push-literal 28 }
147 { jit-dispatch-word 31 }
152 { jit-push-immediate 36 }
153 { jit-declare-word 42 }
154 { undefined-quot 60 }
157 : emit ( cell -- ) image get push ;
159 : emit-64 ( cell -- )
163 d>w/w big-endian get [ swap ] unless emit emit
166 : emit-seq ( seq -- ) image get push-all ;
168 : fixup ( value offset -- ) image get set-nth ;
170 : heap-size ( -- size )
171 image get length header-size - userenv-size -
174 : here ( -- size ) heap-size data-base + ;
176 : here-as ( tag -- pointer ) here bitor ;
179 here 8 mod 4 = [ 0 emit ] when ;
181 : emit-fixnum ( n -- ) tag-fixnum emit ;
183 : emit-object ( header tag quot -- addr )
184 swap here-as >r swap tag-fixnum emit call align-here r> ;
187 ! Write an object to the image.
188 GENERIC: ' ( obj -- ptr )
195 data-base emit ! relocation base at end of header
196 0 emit ! size of data heap set later
197 0 emit ! reloc base of code heap is 0
198 0 emit ! size of code heap is 0
199 0 emit ! pointer to t object
200 0 emit ! pointer to bignum 0
201 0 emit ! pointer to bignum 1
202 0 emit ! pointer to bignum -1
203 userenv-size [ f ' emit ] times ;
205 : emit-userenv ( symbol -- )
206 [ get ' ] [ userenv-offset ] bi fixup ;
210 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
212 : bignum-radix ( -- n ) bignum-bits 2^ 1- ;
214 : bignum>seq ( n -- seq )
215 #! n is positive or zero.
217 [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
220 : emit-bignum ( n -- )
221 dup dup 0 < [ neg ] when bignum>seq
222 [ nip length 1+ emit-fixnum ]
223 [ drop 0 < 1 0 ? emit ]
229 bignum tag-number dup [ emit-bignum ] emit-object
235 #! When generating a 32-bit image on a 64-bit system,
236 #! some fixnums should be bignums.
238 bootstrap-most-negative-fixnum
239 bootstrap-most-positive-fixnum between?
240 [ tag-fixnum ] [ >bignum ' ] if ;
242 TUPLE: fake-bignum n ;
244 C: <fake-bignum> fake-bignum
246 M: fake-bignum ' n>> tag-fixnum ;
252 float tag-number dup [
253 align-here double>bits emit-64
259 ! Padded with fixnums for 8-byte alignment
261 : t, ( -- ) t t-offset fixup ;
264 #! f is #define F RETAG(0,F_TYPE)
265 drop \ f tag-number ;
267 : 0, ( -- ) 0 >bignum ' 0-offset fixup ;
268 : 1, ( -- ) 1 >bignum ' 1-offset fixup ;
269 : -1, ( -- ) -1 >bignum ' -1-offset fixup ;
273 : word-sub-primitive ( word -- obj )
274 global [ target-word ] bind sub-primitives get at ;
276 : emit-word ( word -- )
278 [ subwords [ emit-word ] each ]
282 [ hashcode <fake-bignum> , ]
289 [ word-sub-primitive , ]
292 [ drop 0 , ] ! profiling
296 \ word type-number object tag-number
297 [ emit-seq ] emit-object
300 : word-error ( word msg -- * )
301 [ % dup vocabulary>> % " " % name>> % ] "" make throw ;
303 : transfer-word ( word -- word )
304 [ target-word ] keep or ;
306 : fixup-word ( word -- offset )
307 transfer-word dup lookup-object
308 [ ] [ "Not in image: " word-error ] ?if ;
311 image get [ dup word? [ fixup-word ] when ] change-each ;
318 wrapped>> ' wrapper type-number object tag-number
319 [ emit ] emit-object ;
322 : emit-bytes ( seq -- )
323 bootstrap-cell <groups>
324 big-endian get [ [ be> ] map ] [ [ le> ] map ] if
327 : pad-bytes ( seq -- newseq )
328 dup length bootstrap-cell align 0 pad-right ;
330 : emit-string ( string -- ptr )
331 string type-number object tag-number [
332 dup length emit-fixnum
339 #! We pool strings so that each string is only written once
341 [ emit-string ] cache-object ;
343 : assert-empty ( seq -- )
346 : emit-dummy-array ( obj type -- ptr )
348 type-number object tag-number
349 [ 0 emit-fixnum ] emit-object
353 byte-array type-number object tag-number [
354 dup length emit-fixnum
359 : (emit-tuple) ( tuple -- pointer )
361 [ class transfer-word tuple-layout ] bi prefix [ ' ] map
362 tuple type-number dup [ emit-seq ] emit-object ;
364 : emit-tuple ( tuple -- pointer )
365 dup class name>> "tombstone" =
366 [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
368 M: tuple ' emit-tuple ;
381 \ tuple-layout type-number
382 object tag-number [ emit-seq ] emit-object
386 state>> "((tombstone))" "((empty))" ?
387 "hashtables.private" lookup def>> first
388 [ emit-tuple ] cache-object ;
392 [ ' ] map array type-number object tag-number
393 [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
400 quotation type-number object tag-number [
402 f ' emit ! compiled>>
411 all-words [ emit-word ] each ;
415 dictionary source-files builtins
416 update-map implementors-map
417 } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
419 class<=-cache class-not-cache classes-intersect-cache
420 class-and-cache class-or-cache next-method-quot-cache
421 } [ H{ } clone ] H{ } map>assoc assoc-union
423 bootstrap-global emit-userenv ;
425 : emit-boot-quot ( -- )
426 bootstrap-boot-quot emit-userenv ;
428 : emit-jit-data ( -- )
430 \ dispatch jit-dispatch-word set
431 \ do-primitive jit-primitive-word set
432 \ declare jit-declare-word set
433 [ undefined ] undefined-quot set
452 } [ emit-userenv ] each ;
454 : fixup-header ( -- )
455 heap-size data-heap-size-offset fixup ;
457 : build-image ( -- image )
458 800000 <vector> image set
459 20000 <hashtable> objects set
460 emit-header t, 0, 1, -1,
461 "Serializing words..." print flush
463 "Serializing JIT data..." print flush
465 "Serializing global namespace..." print flush
467 "Serializing boot quotation..." print flush
469 "Performing word fixups..." print flush
471 "Performing header fixups..." print flush
473 "Image length: " write image get length .
474 "Object cache size: " write objects get assoc-size .
475 \ word global delete-at
480 : (write-image) ( image -- )
481 bootstrap-cell big-endian get [
482 [ >be write ] curry each
484 [ >le write ] curry each
487 : write-image ( image -- )
488 "Writing image to " write
489 architecture get boot-image-name resource-path
490 [ write "..." print flush ]
491 [ binary [ (write-image) ] with-file-writer ] bi ;
495 : make-image ( arch -- )
498 "resource:/core/bootstrap/stage1.factor" run-file
504 images [ make-image ] each ;