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 ;
74 M: eq-wrapper hashcode*
75 nip obj>> identity-hashcode ;
79 : cache-eql-object ( obj quot -- value )
80 [ <eql-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
82 : cache-eq-object ( obj quot -- value )
83 [ <eq-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
85 : lookup-object ( obj -- n/f ) <eq-wrapper> objects get at ;
87 : put-object ( n obj -- ) <eq-wrapper> objects get set-at ;
91 CONSTANT: image-magic HEX: 0f0e0d0c
92 CONSTANT: image-version 4
94 CONSTANT: data-base 1024
96 CONSTANT: userenv-size 70
98 CONSTANT: header-size 10
100 CONSTANT: data-heap-size-offset 3
104 CONSTANT: -1-offset 9
106 SYMBOL: sub-primitives
108 SYMBOL: jit-relocations
110 : compute-offset ( rc -- offset )
111 [ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
113 : jit-rel ( rc rt -- )
114 over compute-offset 3array jit-relocations get push-all ;
118 : jit-literal ( literal -- )
119 jit-literals get push ;
121 : make-jit ( quot -- jit-literals jit-data )
123 V{ } clone jit-literals set
124 V{ } clone jit-relocations set
126 jit-literals get >array
127 jit-relocations get >array
130 : jit-define ( quot name -- )
131 [ make-jit nip ] dip set ;
133 : define-sub-primitive ( quot word -- )
134 [ make-jit 2array ] dip sub-primitives get set-at ;
136 ! The image being constructed; a vector of word-size integers
139 ! Image output format
142 ! Bootstrap architecture name
147 ! Boot quotation, set in stage1.factor
148 USERENV: bootstrap-startup-quot 20
150 ! Bootstrap global namesapce
151 USERENV: bootstrap-global 21
154 USERENV: jit-prolog 23
155 USERENV: jit-primitive-word 24
156 USERENV: jit-primitive 25
157 USERENV: jit-word-jump 26
158 USERENV: jit-word-call 27
159 USERENV: jit-word-special 28
160 USERENV: jit-if-word 29
162 USERENV: jit-epilog 31
163 USERENV: jit-return 32
164 USERENV: jit-profiling 33
165 USERENV: jit-push-immediate 34
166 USERENV: jit-dip-word 35
168 USERENV: jit-2dip-word 37
170 USERENV: jit-3dip-word 39
172 USERENV: jit-execute-word 41
173 USERENV: jit-execute-jump 42
174 USERENV: jit-execute-call 43
175 USERENV: jit-declare-word 44
177 USERENV: callback-stub 45
182 USERENV: pic-tuple 49
183 USERENV: pic-check-tag 50
184 USERENV: pic-check-tuple 51
186 USERENV: pic-miss-word 53
187 USERENV: pic-miss-tail-word 54
189 ! Megamorphic dispatch
190 USERENV: mega-lookup 57
191 USERENV: mega-lookup-word 58
192 USERENV: mega-miss-word 59
194 ! Default definition for undefined words
195 USERENV: undefined-quot 60
197 : userenv-offset ( symbol -- n )
198 userenvs get at header-size + ;
200 : emit ( cell -- ) image get push ;
202 : emit-64 ( cell -- )
206 d>w/w big-endian get [ swap ] unless emit emit
209 : emit-seq ( seq -- ) image get push-all ;
211 : fixup ( value offset -- ) image get set-nth ;
213 : heap-size ( -- size )
214 image get length header-size - userenv-size -
217 : here ( -- size ) heap-size data-base + ;
219 : here-as ( tag -- pointer ) here bitor ;
221 : (align-here) ( alignment -- )
223 [ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
226 data-alignment get (align-here) ;
228 : emit-fixnum ( n -- ) tag-fixnum emit ;
230 : emit-header ( n -- ) tag-header emit ;
232 : emit-object ( class quot -- addr )
233 [ type-number ] dip over here-as
234 [ swap emit-header call align-here ] dip ;
237 ! Write an object to the image.
238 GENERIC: ' ( obj -- ptr )
242 : emit-image-header ( -- )
245 data-base emit ! relocation base at end of header
246 0 emit ! size of data heap set later
247 0 emit ! reloc base of code heap is 0
248 0 emit ! size of code heap is 0
249 0 emit ! pointer to t object
250 0 emit ! pointer to bignum 0
251 0 emit ! pointer to bignum 1
252 0 emit ! pointer to bignum -1
253 userenv-size [ f ' emit ] times ;
255 : emit-userenv ( symbol -- )
256 [ get ' ] [ userenv-offset ] bi fixup ;
260 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
262 : bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
264 : bignum>seq ( n -- seq )
265 #! n is positive or zero.
267 [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
270 : emit-bignum ( n -- )
271 dup dup 0 < [ neg ] when bignum>seq
272 [ nip length 1 + emit-fixnum ]
273 [ drop 0 < 1 0 ? emit ]
279 bignum [ emit-bignum ] emit-object
285 #! When generating a 32-bit image on a 64-bit system,
286 #! some fixnums should be bignums.
288 bootstrap-most-negative-fixnum
289 bootstrap-most-positive-fixnum between?
290 [ tag-fixnum ] [ >bignum ' ] if ;
292 TUPLE: fake-bignum n ;
294 C: <fake-bignum> fake-bignum
296 M: fake-bignum ' n>> tag-fixnum ;
303 8 (align-here) double>bits emit-64
309 ! Padded with fixnums for 8-byte alignment
311 : t, ( -- ) t t-offset fixup ;
314 #! f is #define F RETAG(0,F_TYPE)
315 drop \ f type-number ;
317 : 0, ( -- ) 0 >bignum ' 0-offset fixup ;
318 : 1, ( -- ) 1 >bignum ' 1-offset fixup ;
319 : -1, ( -- ) -1 >bignum ' -1-offset fixup ;
323 : word-sub-primitive ( word -- obj )
324 global [ target-word ] bind sub-primitives get at ;
326 : emit-word ( word -- )
328 [ subwords [ emit-word ] each ]
332 [ hashcode <fake-bignum> , ]
340 [ word-sub-primitive , ]
343 [ drop 0 , ] ! profiling
347 \ word [ emit-seq ] emit-object
350 : word-error ( word msg -- * )
351 [ % dup vocabulary>> % " " % name>> % ] "" make throw ;
353 : transfer-word ( word -- word )
354 [ target-word ] keep or ;
356 : fixup-word ( word -- offset )
357 transfer-word dup lookup-object
358 [ ] [ "Not in image: " word-error ] ?if ;
361 image get [ dup word? [ fixup-word ] when ] map! drop ;
368 [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
371 : native> ( object -- object )
372 big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
374 : emit-bytes ( seq -- )
375 bootstrap-cell <groups> native> emit-seq ;
377 : pad-bytes ( seq -- newseq )
378 dup length bootstrap-cell align 0 pad-tail ;
380 : extended-part ( str -- str' )
381 dup [ 128 < ] all? [ drop f ] [
382 [ -7 shift 1 bitxor ] { } map-as
384 [ [ 2 >be ] { } map-as ]
385 [ [ 2 >le ] { } map-as ] if
389 : ascii-part ( str -- str' )
391 [ 128 mod ] [ 128 >= ] bi
395 : emit-string ( string -- ptr )
396 [ length ] [ extended-part ' ] [ ] tri
400 [ f ' emit ascii-part pad-bytes emit-bytes ]
405 #! We pool strings so that each string is only written once
407 [ emit-string ] cache-eql-object ;
409 : assert-empty ( seq -- )
412 : emit-dummy-array ( obj type -- ptr )
414 [ 0 emit-fixnum ] emit-object
420 dup length emit-fixnum
421 bootstrap-cell 4 = [ 0 emit 0 emit ] when
427 ERROR: tuple-removed class ;
429 : require-tuple-layout ( word -- layout )
430 dup tuple-layout [ ] [ tuple-removed ] ?if ;
432 : (emit-tuple) ( tuple -- pointer )
434 [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
435 tuple [ emit-seq ] emit-object ;
437 : emit-tuple ( tuple -- pointer )
438 dup class name>> "tombstone" =
439 [ [ (emit-tuple) ] cache-eql-object ]
440 [ [ (emit-tuple) ] cache-eq-object ]
443 M: tuple ' emit-tuple ;
446 state>> "((tombstone))" "((empty))" ?
447 "hashtables.private" lookup def>> first
448 [ emit-tuple ] cache-eql-object ;
451 : emit-array ( array -- offset )
452 [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
454 M: array ' [ emit-array ] cache-eq-object ;
456 ! This is a hack. We need to detect arrays which are tuple
457 ! layout arrays so that they can be internalized, but making
458 ! them a built-in type is not worth it.
459 PREDICATE: tuple-layout-array < array
461 [ first tuple-class? ]
467 M: tuple-layout-array '
469 [ dup integer? [ <fake-bignum> ] when ] map
480 f ' emit ! cached-effect
481 f ' emit ! cache-counter
490 all-words [ emit-word ] each ;
494 dictionary source-files builtins
495 update-map implementors-map
496 } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
498 class<=-cache class-not-cache classes-intersect-cache
499 class-and-cache class-or-cache next-method-quot-cache
500 } [ H{ } clone ] H{ } map>assoc assoc-union
501 bootstrap-global set ;
503 : emit-jit-data ( -- )
505 \ do-primitive jit-primitive-word set
506 \ dip jit-dip-word set
507 \ 2dip jit-2dip-word set
508 \ 3dip jit-3dip-word set
509 \ (execute) jit-execute-word set
510 \ inline-cache-miss \ pic-miss-word set
511 \ inline-cache-miss-tail \ pic-miss-tail-word set
512 \ mega-cache-lookup \ mega-lookup-word set
513 \ mega-cache-miss \ mega-miss-word set
514 \ declare jit-declare-word set
515 [ undefined ] undefined-quot set ;
517 : emit-userenvs ( -- )
518 userenvs get keys [ emit-userenv ] each ;
520 : fixup-header ( -- )
521 heap-size data-heap-size-offset fixup ;
523 : build-image ( -- image )
524 800000 <vector> image set
525 20000 <hashtable> objects set
526 emit-image-header t, 0, 1, -1,
527 "Building generic words..." print flush
529 "Serializing words..." print flush
531 "Serializing JIT data..." print flush
533 "Serializing global namespace..." print flush
535 "Serializing user environment..." print flush
537 "Performing word fixups..." print flush
539 "Performing header fixups..." print flush
541 "Image length: " write image get length .
542 "Object cache size: " write objects get assoc-size .
543 \ word global delete-at
548 : (write-image) ( image -- )
549 bootstrap-cell big-endian get
550 [ '[ _ >be write ] each ]
551 [ '[ _ >le write ] each ] if ;
553 : write-image ( image -- )
554 "Writing image to " write
555 architecture get boot-image-name resource-path
556 [ write "..." print flush ]
557 [ binary [ (write-image) ] with-file-writer ] bi ;
561 : make-image ( arch -- )
564 "resource:/core/bootstrap/stage1.factor" run-file
570 images [ make-image ] each ;