1 ! Copyright (C) 2004, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien arrays byte-arrays generic hashtables hashtables.private
4 io io.binary io.files io.encodings.binary io.pathnames kernel
5 kernel.private math namespaces make parser prettyprint sequences
6 strings sbufs vectors words quotations assocs system layouts splitting
7 grouping growable classes classes.builtin classes.tuple
8 classes.tuple.private vocabs vocabs.loader source-files definitions
9 debugger quotations.private combinators math.order math.private
10 accessors slots.private generic.single.private compiler.units
11 compiler.constants fry bootstrap.image.syntax ;
14 : arch ( os cpu -- arch )
16 { "ppc" [ "-ppc" append ] }
17 { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
22 os name>> cpu name>> arch ;
24 : boot-image-name ( arch -- string )
25 "boot." ".image" surround ;
27 : my-boot-image-name ( -- string )
28 my-arch boot-image-name ;
33 "winnt-x86.64" "unix-x86.64"
34 "linux-ppc" "macosx-ppc"
39 ! Object cache; we only consider numbers equal if they have the
45 M: id hashcode* obj>> hashcode* ;
47 GENERIC: (eql?) ( obj1 obj2 -- ? )
49 : eql? ( obj1 obj2 -- ? )
50 [ (eql?) ] [ [ class ] bi@ = ] 2bi and ;
55 over float? [ fp-bitwise= ] [ 2drop f ] if ;
60 [ [ eql? ] 2all? ] [ 2drop f ] if
66 over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
70 : (objects) ( obj -- id assoc ) <id> objects get ; inline
72 : lookup-object ( obj -- n/f ) (objects) at ;
74 : put-object ( n obj -- ) (objects) set-at ;
76 : cache-object ( obj quot -- value )
77 [ (objects) ] dip '[ obj>> @ ] cache ; inline
81 CONSTANT: image-magic HEX: 0f0e0d0c
82 CONSTANT: image-version 4
84 CONSTANT: data-base 1024
86 CONSTANT: userenv-size 70
88 CONSTANT: header-size 10
90 CONSTANT: data-heap-size-offset 3
96 SYMBOL: sub-primitives
98 SYMBOL: jit-relocations
100 : compute-offset ( rc -- offset )
101 [ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
103 : jit-rel ( rc rt -- )
104 over compute-offset 3array jit-relocations get push-all ;
106 : make-jit ( quot -- jit-data )
108 V{ } clone jit-relocations set
110 jit-relocations get >array
113 : jit-define ( quot name -- )
114 [ make-jit ] dip set ;
116 : define-sub-primitive ( quot word -- )
117 [ make-jit ] dip sub-primitives get set-at ;
119 ! The image being constructed; a vector of word-size integers
122 ! Image output format
125 ! Bootstrap architecture name
130 ! Boot quotation, set in stage1.factor
131 USERENV: bootstrap-boot-quot 20
133 ! Bootstrap global namesapce
134 USERENV: bootstrap-global 21
137 USERENV: jit-prolog 23
138 USERENV: jit-primitive-word 24
139 USERENV: jit-primitive 25
140 USERENV: jit-word-jump 26
141 USERENV: jit-word-call 27
142 USERENV: jit-word-special 28
143 USERENV: jit-if-word 29
145 USERENV: jit-epilog 31
146 USERENV: jit-return 32
147 USERENV: jit-profiling 33
148 USERENV: jit-push-immediate 34
149 USERENV: jit-dip-word 35
151 USERENV: jit-2dip-word 37
153 USERENV: jit-3dip-word 39
155 USERENV: jit-execute-word 41
156 USERENV: jit-execute-jump 42
157 USERENV: jit-execute-call 43
162 USERENV: pic-hi-tag 49
163 USERENV: pic-tuple 50
164 USERENV: pic-hi-tag-tuple 51
165 USERENV: pic-check-tag 52
166 USERENV: pic-check 53
168 USERENV: pic-miss-word 55
169 USERENV: pic-miss-tail-word 56
171 ! Megamorphic dispatch
172 USERENV: mega-lookup 57
173 USERENV: mega-lookup-word 58
174 USERENV: mega-miss-word 59
176 ! Default definition for undefined words
177 USERENV: undefined-quot 60
179 : userenv-offset ( symbol -- n )
180 userenvs get at header-size + ;
182 : emit ( cell -- ) image get push ;
184 : emit-64 ( cell -- )
188 d>w/w big-endian get [ swap ] unless emit emit
191 : emit-seq ( seq -- ) image get push-all ;
193 : fixup ( value offset -- ) image get set-nth ;
195 : heap-size ( -- size )
196 image get length header-size - userenv-size -
199 : here ( -- size ) heap-size data-base + ;
201 : here-as ( tag -- pointer ) here bitor ;
204 here 8 mod 4 = [ 0 emit ] when ;
206 : emit-fixnum ( n -- ) tag-fixnum emit ;
208 : emit-object ( class quot -- addr )
209 over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
212 ! Write an object to the image.
213 GENERIC: ' ( obj -- ptr )
220 data-base emit ! relocation base at end of header
221 0 emit ! size of data heap set later
222 0 emit ! reloc base of code heap is 0
223 0 emit ! size of code heap is 0
224 0 emit ! pointer to t object
225 0 emit ! pointer to bignum 0
226 0 emit ! pointer to bignum 1
227 0 emit ! pointer to bignum -1
228 userenv-size [ f ' emit ] times ;
230 : emit-userenv ( symbol -- )
231 [ get ' ] [ userenv-offset ] bi fixup ;
235 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
237 : bignum-radix ( -- n ) bignum-bits 2^ 1- ;
239 : bignum>seq ( n -- seq )
240 #! n is positive or zero.
242 [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
245 : emit-bignum ( n -- )
246 dup dup 0 < [ neg ] when bignum>seq
247 [ nip length 1+ emit-fixnum ]
248 [ drop 0 < 1 0 ? emit ]
254 bignum [ emit-bignum ] emit-object
260 #! When generating a 32-bit image on a 64-bit system,
261 #! some fixnums should be bignums.
263 bootstrap-most-negative-fixnum
264 bootstrap-most-positive-fixnum between?
265 [ tag-fixnum ] [ >bignum ' ] if ;
267 TUPLE: fake-bignum n ;
269 C: <fake-bignum> fake-bignum
271 M: fake-bignum ' n>> tag-fixnum ;
278 align-here double>bits emit-64
284 ! Padded with fixnums for 8-byte alignment
286 : t, ( -- ) t t-offset fixup ;
289 #! f is #define F RETAG(0,F_TYPE)
290 drop \ f tag-number ;
292 : 0, ( -- ) 0 >bignum ' 0-offset fixup ;
293 : 1, ( -- ) 1 >bignum ' 1-offset fixup ;
294 : -1, ( -- ) -1 >bignum ' -1-offset fixup ;
298 : word-sub-primitive ( word -- obj )
299 global [ target-word ] bind sub-primitives get at ;
301 : emit-word ( word -- )
303 [ subwords [ emit-word ] each ]
307 [ hashcode <fake-bignum> , ]
315 [ word-sub-primitive , ]
318 [ drop 0 , ] ! profiling
322 \ word [ emit-seq ] emit-object
325 : word-error ( word msg -- * )
326 [ % dup vocabulary>> % " " % name>> % ] "" make throw ;
328 : transfer-word ( word -- word )
329 [ target-word ] keep or ;
331 : fixup-word ( word -- offset )
332 transfer-word dup lookup-object
333 [ ] [ "Not in image: " word-error ] ?if ;
336 image get [ dup word? [ fixup-word ] when ] change-each ;
343 wrapped>> ' wrapper [ emit ] emit-object ;
346 : native> ( object -- object )
347 big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
349 : emit-bytes ( seq -- )
350 bootstrap-cell <groups> native> emit-seq ;
352 : pad-bytes ( seq -- newseq )
353 dup length bootstrap-cell align 0 pad-tail ;
355 : extended-part ( str -- str' )
356 dup [ 128 < ] all? [ drop f ] [
357 [ -7 shift 1 bitxor ] { } map-as
359 [ [ 2 >be ] { } map-as ]
360 [ [ 2 >le ] { } map-as ] if
364 : ascii-part ( str -- str' )
366 [ 128 mod ] [ 128 >= ] bi
370 : emit-string ( string -- ptr )
371 [ length ] [ extended-part ' ] [ ] tri
375 [ f ' emit ascii-part pad-bytes emit-bytes ]
380 #! We pool strings so that each string is only written once
382 [ emit-string ] cache-object ;
384 : assert-empty ( seq -- )
387 : emit-dummy-array ( obj type -- ptr )
389 [ 0 emit-fixnum ] emit-object
394 dup length emit-fixnum
399 ERROR: tuple-removed class ;
401 : require-tuple-layout ( word -- layout )
402 dup tuple-layout [ ] [ tuple-removed ] ?if ;
404 : (emit-tuple) ( tuple -- pointer )
406 [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
407 tuple [ emit-seq ] emit-object ;
409 : emit-tuple ( tuple -- pointer )
410 dup class name>> "tombstone" =
411 [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
413 M: tuple ' emit-tuple ;
416 state>> "((tombstone))" "((empty))" ?
417 "hashtables.private" lookup def>> first
418 [ emit-tuple ] cache-object ;
421 : emit-array ( array -- offset )
422 [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
424 M: array ' emit-array ;
426 ! This is a hack. We need to detect arrays which are tuple
427 ! layout arrays so that they can be internalized, but making
428 ! them a built-in type is not worth it.
429 PREDICATE: tuple-layout-array < array
431 [ first tuple-class? ]
437 M: tuple-layout-array '
439 [ dup integer? [ <fake-bignum> ] when ] map
450 f ' emit ! cached-effect
451 f ' emit ! cache-counter
460 all-words [ emit-word ] each ;
464 dictionary source-files builtins
465 update-map implementors-map
466 } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
468 class<=-cache class-not-cache classes-intersect-cache
469 class-and-cache class-or-cache next-method-quot-cache
470 } [ H{ } clone ] H{ } map>assoc assoc-union
471 bootstrap-global set ;
473 : emit-jit-data ( -- )
475 \ do-primitive jit-primitive-word set
476 \ dip jit-dip-word set
477 \ 2dip jit-2dip-word set
478 \ 3dip jit-3dip-word set
479 \ (execute) jit-execute-word set
480 \ inline-cache-miss \ pic-miss-word set
481 \ inline-cache-miss-tail \ pic-miss-tail-word set
482 \ mega-cache-lookup \ mega-lookup-word set
483 \ mega-cache-miss \ mega-miss-word set
484 [ undefined ] undefined-quot set ;
486 : emit-userenvs ( -- )
487 userenvs get keys [ emit-userenv ] each ;
489 : fixup-header ( -- )
490 heap-size data-heap-size-offset fixup ;
492 : build-image ( -- image )
493 800000 <vector> image set
494 20000 <hashtable> objects set
495 emit-header t, 0, 1, -1,
496 "Building generic words..." print flush
498 "Serializing words..." print flush
500 "Serializing JIT data..." print flush
502 "Serializing global namespace..." print flush
504 "Serializing user environment..." print flush
506 "Performing word fixups..." print flush
508 "Performing header fixups..." print flush
510 "Image length: " write image get length .
511 "Object cache size: " write objects get assoc-size .
512 \ word global delete-at
517 : (write-image) ( image -- )
518 bootstrap-cell big-endian get
519 [ '[ _ >be write ] each ]
520 [ '[ _ >le write ] each ] if ;
522 : write-image ( image -- )
523 "Writing image to " write
524 architecture get boot-image-name resource-path
525 [ write "..." print flush ]
526 [ binary [ (write-image) ] with-file-writer ] bi ;
530 : make-image ( arch -- )
533 "resource:/core/bootstrap/stage1.factor" run-file
539 images [ make-image ] each ;