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
4 hashtables.private io io.binary io.files io.encodings.binary
5 io.pathnames kernel kernel.private math namespaces make parser
6 prettyprint sequences strings sbufs vectors words quotations
7 assocs system layouts splitting grouping growable classes
8 classes.builtin classes.tuple classes.tuple.private vocabs
9 vocabs.loader source-files definitions debugger
10 quotations.private combinators combinators.short-circuit
11 math.order math.private accessors slots.private
12 generic.single.private compiler.units compiler.constants fry
13 bootstrap.image.syntax ;
16 : arch ( os cpu -- arch )
18 { "ppc" [ "-ppc" append ] }
19 { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
24 os name>> cpu name>> arch ;
26 : boot-image-name ( arch -- string )
27 "boot." ".image" surround ;
29 : my-boot-image-name ( -- string )
30 my-arch boot-image-name ;
35 "winnt-x86.64" "unix-x86.64"
36 "linux-ppc" "macosx-ppc"
41 ! Object cache; we only consider numbers equal if they have the
43 TUPLE: eql-wrapper { obj read-only } ;
45 C: <eql-wrapper> eql-wrapper
47 M: eql-wrapper hashcode* obj>> hashcode* ;
49 GENERIC: (eql?) ( obj1 obj2 -- ? )
51 : eql? ( obj1 obj2 -- ? )
52 { [ [ class ] bi@ = ] [ (eql?) ] } 2&& ;
54 M: fixnum (eql?) eq? ;
58 M: float (eql?) fp-bitwise= ;
60 M: sequence (eql?) 2dup [ length ] bi@ = [ [ eql? ] 2all? ] [ 2drop f ] if ;
65 over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
67 TUPLE: eq-wrapper { obj read-only } ;
69 C: <eq-wrapper> eq-wrapper
72 over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
76 : cache-eql-object ( obj quot -- value )
77 [ <eql-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
79 : cache-eq-object ( obj quot -- value )
80 [ <eq-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
82 : lookup-object ( obj -- n/f ) <eq-wrapper> objects get at ;
84 : put-object ( n obj -- ) <eq-wrapper> objects get set-at ;
88 CONSTANT: image-magic HEX: 0f0e0d0c
89 CONSTANT: image-version 4
91 CONSTANT: data-base 1024
93 CONSTANT: userenv-size 70
95 CONSTANT: header-size 10
97 CONSTANT: data-heap-size-offset 3
101 CONSTANT: -1-offset 9
103 SYMBOL: sub-primitives
105 SYMBOL: jit-relocations
107 : compute-offset ( rc -- offset )
108 [ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
110 : jit-rel ( rc rt -- )
111 over compute-offset 3array jit-relocations get push-all ;
115 : jit-literal ( literal -- )
116 jit-literals get push ;
118 : make-jit ( quot -- jit-literals jit-data )
120 V{ } clone jit-literals set
121 V{ } clone jit-relocations set
123 jit-literals get >array
124 jit-relocations get >array
127 : jit-define ( quot name -- )
128 [ make-jit nip ] dip set ;
130 : define-sub-primitive ( quot word -- )
131 [ make-jit 2array ] dip sub-primitives get set-at ;
133 ! The image being constructed; a vector of word-size integers
136 ! Image output format
139 ! Bootstrap architecture name
144 ! Boot quotation, set in stage1.factor
145 USERENV: bootstrap-boot-quot 20
147 ! Bootstrap global namesapce
148 USERENV: bootstrap-global 21
151 USERENV: jit-prolog 23
152 USERENV: jit-primitive-word 24
153 USERENV: jit-primitive 25
154 USERENV: jit-word-jump 26
155 USERENV: jit-word-call 27
156 USERENV: jit-word-special 28
157 USERENV: jit-if-word 29
159 USERENV: jit-epilog 31
160 USERENV: jit-return 32
161 USERENV: jit-profiling 33
162 USERENV: jit-push-immediate 34
163 USERENV: jit-dip-word 35
165 USERENV: jit-2dip-word 37
167 USERENV: jit-3dip-word 39
169 USERENV: jit-execute-word 41
170 USERENV: jit-execute-jump 42
171 USERENV: jit-execute-call 43
172 USERENV: jit-declare-word 44
174 USERENV: callback-stub 45
179 USERENV: pic-hi-tag 49
180 USERENV: pic-tuple 50
181 USERENV: pic-hi-tag-tuple 51
182 USERENV: pic-check-tag 52
183 USERENV: pic-check 53
185 USERENV: pic-miss-word 55
186 USERENV: pic-miss-tail-word 56
188 ! Megamorphic dispatch
189 USERENV: mega-lookup 57
190 USERENV: mega-lookup-word 58
191 USERENV: mega-miss-word 59
193 ! Default definition for undefined words
194 USERENV: undefined-quot 60
196 : userenv-offset ( symbol -- n )
197 userenvs get at header-size + ;
199 : emit ( cell -- ) image get push ;
201 : emit-64 ( cell -- )
205 d>w/w big-endian get [ swap ] unless emit emit
208 : emit-seq ( seq -- ) image get push-all ;
210 : fixup ( value offset -- ) image get set-nth ;
212 : heap-size ( -- size )
213 image get length header-size - userenv-size -
216 : here ( -- size ) heap-size data-base + ;
218 : here-as ( tag -- pointer ) here bitor ;
221 here 8 mod 4 = [ 0 emit ] when ;
223 : emit-fixnum ( n -- ) tag-fixnum emit ;
225 : emit-object ( class quot -- addr )
226 over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
229 ! Write an object to the image.
230 GENERIC: ' ( obj -- ptr )
237 data-base emit ! relocation base at end of header
238 0 emit ! size of data heap set later
239 0 emit ! reloc base of code heap is 0
240 0 emit ! size of code heap is 0
241 0 emit ! pointer to t object
242 0 emit ! pointer to bignum 0
243 0 emit ! pointer to bignum 1
244 0 emit ! pointer to bignum -1
245 userenv-size [ f ' emit ] times ;
247 : emit-userenv ( symbol -- )
248 [ get ' ] [ userenv-offset ] bi fixup ;
252 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
254 : bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
256 : bignum>seq ( n -- seq )
257 #! n is positive or zero.
259 [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
262 : emit-bignum ( n -- )
263 dup dup 0 < [ neg ] when bignum>seq
264 [ nip length 1 + emit-fixnum ]
265 [ drop 0 < 1 0 ? emit ]
271 bignum [ emit-bignum ] emit-object
277 #! When generating a 32-bit image on a 64-bit system,
278 #! some fixnums should be bignums.
280 bootstrap-most-negative-fixnum
281 bootstrap-most-positive-fixnum between?
282 [ tag-fixnum ] [ >bignum ' ] if ;
284 TUPLE: fake-bignum n ;
286 C: <fake-bignum> fake-bignum
288 M: fake-bignum ' n>> tag-fixnum ;
295 align-here double>bits emit-64
301 ! Padded with fixnums for 8-byte alignment
303 : t, ( -- ) t t-offset fixup ;
306 #! f is #define F RETAG(0,F_TYPE)
307 drop \ f tag-number ;
309 : 0, ( -- ) 0 >bignum ' 0-offset fixup ;
310 : 1, ( -- ) 1 >bignum ' 1-offset fixup ;
311 : -1, ( -- ) -1 >bignum ' -1-offset fixup ;
315 : word-sub-primitive ( word -- obj )
316 global [ target-word ] bind sub-primitives get at ;
318 : emit-word ( word -- )
320 [ subwords [ emit-word ] each ]
324 [ hashcode <fake-bignum> , ]
332 [ word-sub-primitive , ]
335 [ drop 0 , ] ! profiling
339 \ word [ emit-seq ] emit-object
342 : word-error ( word msg -- * )
343 [ % dup vocabulary>> % " " % name>> % ] "" make throw ;
345 : transfer-word ( word -- word )
346 [ target-word ] keep or ;
348 : fixup-word ( word -- offset )
349 transfer-word dup lookup-object
350 [ ] [ "Not in image: " word-error ] ?if ;
353 image get [ dup word? [ fixup-word ] when ] map! drop ;
360 [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
363 : native> ( object -- object )
364 big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
366 : emit-bytes ( seq -- )
367 bootstrap-cell <groups> native> emit-seq ;
369 : pad-bytes ( seq -- newseq )
370 dup length bootstrap-cell align 0 pad-tail ;
372 : extended-part ( str -- str' )
373 dup [ 128 < ] all? [ drop f ] [
374 [ -7 shift 1 bitxor ] { } map-as
376 [ [ 2 >be ] { } map-as ]
377 [ [ 2 >le ] { } map-as ] if
381 : ascii-part ( str -- str' )
383 [ 128 mod ] [ 128 >= ] bi
387 : emit-string ( string -- ptr )
388 [ length ] [ extended-part ' ] [ ] tri
392 [ f ' emit ascii-part pad-bytes emit-bytes ]
397 #! We pool strings so that each string is only written once
399 [ emit-string ] cache-eql-object ;
401 : assert-empty ( seq -- )
404 : emit-dummy-array ( obj type -- ptr )
406 [ 0 emit-fixnum ] emit-object
412 dup length emit-fixnum
418 ERROR: tuple-removed class ;
420 : require-tuple-layout ( word -- layout )
421 dup tuple-layout [ ] [ tuple-removed ] ?if ;
423 : (emit-tuple) ( tuple -- pointer )
425 [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
426 tuple [ emit-seq ] emit-object ;
428 : emit-tuple ( tuple -- pointer )
429 dup class name>> "tombstone" =
430 [ [ (emit-tuple) ] cache-eql-object ]
431 [ [ (emit-tuple) ] cache-eq-object ]
434 M: tuple ' emit-tuple ;
437 state>> "((tombstone))" "((empty))" ?
438 "hashtables.private" lookup def>> first
439 [ emit-tuple ] cache-eql-object ;
442 : emit-array ( array -- offset )
443 [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
445 M: array ' [ emit-array ] cache-eq-object ;
447 ! This is a hack. We need to detect arrays which are tuple
448 ! layout arrays so that they can be internalized, but making
449 ! them a built-in type is not worth it.
450 PREDICATE: tuple-layout-array < array
452 [ first tuple-class? ]
458 M: tuple-layout-array '
460 [ dup integer? [ <fake-bignum> ] when ] map
471 f ' emit ! cached-effect
472 f ' emit ! cache-counter
481 all-words [ emit-word ] each ;
485 dictionary source-files builtins
486 update-map implementors-map
487 } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
489 class<=-cache class-not-cache classes-intersect-cache
490 class-and-cache class-or-cache next-method-quot-cache
491 } [ H{ } clone ] H{ } map>assoc assoc-union
492 bootstrap-global set ;
494 : emit-jit-data ( -- )
496 \ do-primitive jit-primitive-word set
497 \ dip jit-dip-word set
498 \ 2dip jit-2dip-word set
499 \ 3dip jit-3dip-word set
500 \ (execute) jit-execute-word set
501 \ inline-cache-miss \ pic-miss-word set
502 \ inline-cache-miss-tail \ pic-miss-tail-word set
503 \ mega-cache-lookup \ mega-lookup-word set
504 \ mega-cache-miss \ mega-miss-word set
505 \ declare jit-declare-word set
506 [ undefined ] undefined-quot set ;
508 : emit-userenvs ( -- )
509 userenvs get keys [ emit-userenv ] each ;
511 : fixup-header ( -- )
512 heap-size data-heap-size-offset fixup ;
514 : build-image ( -- image )
515 800000 <vector> image set
516 20000 <hashtable> objects set
517 emit-header t, 0, 1, -1,
518 "Building generic words..." print flush
520 "Serializing words..." print flush
522 "Serializing JIT data..." print flush
524 "Serializing global namespace..." print flush
526 "Serializing user environment..." print flush
528 "Performing word fixups..." print flush
530 "Performing header fixups..." print flush
532 "Image length: " write image get length .
533 "Object cache size: " write objects get assoc-size .
534 \ word global delete-at
539 : (write-image) ( image -- )
540 bootstrap-cell big-endian get
541 [ '[ _ >be write ] each ]
542 [ '[ _ >le write ] each ] if ;
544 : write-image ( image -- )
545 "Writing image to " write
546 architecture get boot-image-name resource-path
547 [ write "..." print flush ]
548 [ binary [ (write-image) ] with-file-writer ] bi ;
552 : make-image ( arch -- )
555 "resource:/core/bootstrap/stage1.factor" run-file
561 images [ make-image ] each ;