1 ! Copyright (C) 2004, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien alien.strings 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 locals bootstrap.image.syntax generalizations ;
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: special-objects-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
112 : compute-offset ( -- offset )
113 building get length jit-offset get + ;
115 : jit-rel ( rc rt -- )
116 compute-offset 3array jit-relocations get push-all ;
118 SYMBOL: jit-parameters
120 : jit-parameter ( parameter -- )
121 jit-parameters get push ;
125 : jit-literal ( literal -- )
126 jit-literals get push ;
128 : jit-vm ( offset rc -- )
129 [ jit-parameter ] dip rt-vm jit-rel ;
131 : jit-dlsym ( name library rc -- )
132 rt-dlsym jit-rel [ string>symbol jit-parameter ] bi@ ;
134 :: jit-conditional ( test-quot false-quot -- )
135 [ 0 test-quot call ] B{ } make length :> len
136 building get length jit-offset get + len +
137 [ jit-offset set false-quot call ] B{ } make
138 [ length test-quot call ] [ % ] bi ; inline
140 : make-jit ( quot -- jit-parameters jit-literals jit-code )
143 V{ } clone jit-parameters set
144 V{ } clone jit-literals set
145 V{ } clone jit-relocations set
147 jit-parameters get >array
148 jit-literals get >array
149 jit-relocations get >array
152 : jit-define ( quot name -- )
153 [ make-jit 2nip ] dip set ;
155 : define-sub-primitive ( quot word -- )
156 [ make-jit 3array ] dip sub-primitives get set-at ;
158 : define-combinator-primitive ( quot non-tail-quot tail-quot word -- )
165 sub-primitives get set-at ;
167 ! The image being constructed; a vector of word-size integers
170 ! Image output format
173 ! Bootstrap architecture name
178 ! Boot quotation, set in stage1.factor
179 SPECIAL-OBJECT: bootstrap-startup-quot 20
181 ! Bootstrap global namesapce
182 SPECIAL-OBJECT: bootstrap-global 21
185 SPECIAL-OBJECT: jit-prolog 23
186 SPECIAL-OBJECT: jit-primitive-word 24
187 SPECIAL-OBJECT: jit-primitive 25
188 SPECIAL-OBJECT: jit-word-jump 26
189 SPECIAL-OBJECT: jit-word-call 27
190 SPECIAL-OBJECT: jit-if-word 28
191 SPECIAL-OBJECT: jit-if 29
192 SPECIAL-OBJECT: jit-epilog 30
193 SPECIAL-OBJECT: jit-return 31
194 SPECIAL-OBJECT: jit-profiling 32
195 SPECIAL-OBJECT: jit-push 33
196 SPECIAL-OBJECT: jit-dip-word 34
197 SPECIAL-OBJECT: jit-dip 35
198 SPECIAL-OBJECT: jit-2dip-word 36
199 SPECIAL-OBJECT: jit-2dip 37
200 SPECIAL-OBJECT: jit-3dip-word 38
201 SPECIAL-OBJECT: jit-3dip 39
202 SPECIAL-OBJECT: jit-execute 40
203 SPECIAL-OBJECT: jit-declare-word 41
205 SPECIAL-OBJECT: c-to-factor-word 42
206 SPECIAL-OBJECT: lazy-jit-compile-word 43
207 SPECIAL-OBJECT: unwind-native-frames-word 44
209 SPECIAL-OBJECT: callback-stub 48
212 SPECIAL-OBJECT: pic-load 49
213 SPECIAL-OBJECT: pic-tag 50
214 SPECIAL-OBJECT: pic-tuple 51
215 SPECIAL-OBJECT: pic-check-tag 52
216 SPECIAL-OBJECT: pic-check-tuple 53
217 SPECIAL-OBJECT: pic-hit 54
218 SPECIAL-OBJECT: pic-miss-word 55
219 SPECIAL-OBJECT: pic-miss-tail-word 56
221 ! Megamorphic dispatch
222 SPECIAL-OBJECT: mega-lookup 57
223 SPECIAL-OBJECT: mega-lookup-word 58
224 SPECIAL-OBJECT: mega-miss-word 59
226 ! Default definition for undefined words
227 SPECIAL-OBJECT: undefined-quot 60
229 : special-object-offset ( symbol -- n )
230 special-objects get at header-size + ;
232 : emit ( cell -- ) image get push ;
234 : emit-64 ( cell -- )
238 d>w/w big-endian get [ swap ] unless emit emit
241 : emit-seq ( seq -- ) image get push-all ;
243 : fixup ( value offset -- ) image get set-nth ;
245 : heap-size ( -- size )
246 image get length header-size - special-objects-size -
249 : here ( -- size ) heap-size data-base + ;
251 : here-as ( tag -- pointer ) here bitor ;
253 : (align-here) ( alignment -- )
255 [ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
258 data-alignment get (align-here) ;
260 : emit-fixnum ( n -- ) tag-fixnum emit ;
262 : emit-header ( n -- ) tag-header emit ;
264 : emit-object ( class quot -- addr )
265 [ type-number ] dip over here-as
266 [ swap emit-header call align-here ] dip ;
269 ! Write an object to the image.
270 GENERIC: ' ( obj -- ptr )
274 : emit-image-header ( -- )
277 data-base emit ! relocation base at end of header
278 0 emit ! size of data heap set later
279 0 emit ! reloc base of code heap is 0
280 0 emit ! size of code heap is 0
281 0 emit ! pointer to t object
282 0 emit ! pointer to bignum 0
283 0 emit ! pointer to bignum 1
284 0 emit ! pointer to bignum -1
285 special-objects-size [ f ' emit ] times ;
287 : emit-special-object ( symbol -- )
288 [ get ' ] [ special-object-offset ] bi fixup ;
292 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
294 : bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
296 : bignum>seq ( n -- seq )
297 #! n is positive or zero.
299 [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
302 : emit-bignum ( n -- )
303 dup dup 0 < [ neg ] when bignum>seq
304 [ nip length 1 + emit-fixnum ]
305 [ drop 0 < 1 0 ? emit ]
311 bignum [ emit-bignum ] emit-object
317 #! When generating a 32-bit image on a 64-bit system,
318 #! some fixnums should be bignums.
320 bootstrap-most-negative-fixnum
321 bootstrap-most-positive-fixnum between?
322 [ tag-fixnum ] [ >bignum ' ] if ;
324 TUPLE: fake-bignum n ;
326 C: <fake-bignum> fake-bignum
328 M: fake-bignum ' n>> tag-fixnum ;
335 8 (align-here) double>bits emit-64
341 ! Padded with fixnums for 8-byte alignment
343 : t, ( -- ) t t-offset fixup ;
346 #! f is #define F RETAG(0,F_TYPE)
347 drop \ f type-number ;
349 : 0, ( -- ) 0 >bignum ' 0-offset fixup ;
350 : 1, ( -- ) 1 >bignum ' 1-offset fixup ;
351 : -1, ( -- ) -1 >bignum ' -1-offset fixup ;
355 : word-sub-primitive ( word -- obj )
356 global [ target-word ] bind sub-primitives get at ;
358 : emit-word ( word -- )
360 [ subwords [ emit-word ] each ]
364 [ hashcode <fake-bignum> , ]
372 [ word-sub-primitive , ]
375 [ drop 0 , ] ! profiling
379 \ word [ emit-seq ] emit-object
382 : word-error ( word msg -- * )
383 [ % dup vocabulary>> % " " % name>> % ] "" make throw ;
385 : transfer-word ( word -- word )
386 [ target-word ] keep or ;
388 : fixup-word ( word -- offset )
389 transfer-word dup lookup-object
390 [ ] [ "Not in image: " word-error ] ?if ;
393 image get [ dup word? [ fixup-word ] when ] map! drop ;
400 [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
403 : native> ( object -- object )
404 big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
406 : emit-bytes ( seq -- )
407 bootstrap-cell <groups> native> emit-seq ;
409 : pad-bytes ( seq -- newseq )
410 dup length bootstrap-cell align 0 pad-tail ;
412 : extended-part ( str -- str' )
413 dup [ 128 < ] all? [ drop f ] [
414 [ -7 shift 1 bitxor ] { } map-as
416 [ [ 2 >be ] { } map-as ]
417 [ [ 2 >le ] { } map-as ] if
421 : ascii-part ( str -- str' )
423 [ 128 mod ] [ 128 >= ] bi
427 : emit-string ( string -- ptr )
428 [ length ] [ extended-part ' ] [ ] tri
432 [ f ' emit ascii-part pad-bytes emit-bytes ]
437 #! We pool strings so that each string is only written once
439 [ emit-string ] cache-eql-object ;
441 : assert-empty ( seq -- )
444 : emit-dummy-array ( obj type -- ptr )
446 [ 0 emit-fixnum ] emit-object
452 dup length emit-fixnum
453 bootstrap-cell 4 = [ 0 emit 0 emit ] when
459 ERROR: tuple-removed class ;
461 : require-tuple-layout ( word -- layout )
462 dup tuple-layout [ ] [ tuple-removed ] ?if ;
464 : (emit-tuple) ( tuple -- pointer )
466 [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
467 tuple [ emit-seq ] emit-object ;
469 : emit-tuple ( tuple -- pointer )
470 dup class name>> "tombstone" =
471 [ [ (emit-tuple) ] cache-eql-object ]
472 [ [ (emit-tuple) ] cache-eq-object ]
475 M: tuple ' emit-tuple ;
478 state>> "((tombstone))" "((empty))" ?
479 "hashtables.private" lookup def>> first
480 [ emit-tuple ] cache-eql-object ;
483 : emit-array ( array -- offset )
484 [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
486 M: array ' [ emit-array ] cache-eq-object ;
488 ! This is a hack. We need to detect arrays which are tuple
489 ! layout arrays so that they can be internalized, but making
490 ! them a built-in type is not worth it.
491 PREDICATE: tuple-layout-array < array
493 [ first tuple-class? ]
499 M: tuple-layout-array '
501 [ dup integer? [ <fake-bignum> ] when ] map
512 f ' emit ! cached-effect
513 f ' emit ! cache-counter
522 all-words [ emit-word ] each ;
526 dictionary source-files builtins
527 update-map implementors-map
528 } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
530 class<=-cache class-not-cache classes-intersect-cache
531 class-and-cache class-or-cache next-method-quot-cache
532 } [ H{ } clone ] H{ } map>assoc assoc-union
533 bootstrap-global set ;
535 : emit-jit-data ( -- )
537 \ do-primitive jit-primitive-word set
538 \ dip jit-dip-word set
539 \ 2dip jit-2dip-word set
540 \ 3dip jit-3dip-word set
541 \ inline-cache-miss pic-miss-word set
542 \ inline-cache-miss-tail pic-miss-tail-word set
543 \ mega-cache-lookup mega-lookup-word set
544 \ mega-cache-miss mega-miss-word set
545 \ declare jit-declare-word set
546 \ c-to-factor c-to-factor-word set
547 \ lazy-jit-compile lazy-jit-compile-word set
548 \ unwind-native-frames unwind-native-frames-word set
549 [ undefined ] undefined-quot set ;
551 : emit-special-objects ( -- )
552 special-objects get keys [ emit-special-object ] each ;
554 : fixup-header ( -- )
555 heap-size data-heap-size-offset fixup ;
557 : build-generics ( -- )
561 [ make-generic ] each
562 ] with-compilation-unit ;
564 : build-image ( -- image )
565 800000 <vector> image set
566 20000 <hashtable> objects set
567 emit-image-header t, 0, 1, -1,
568 "Building generic words..." print flush
570 "Serializing words..." print flush
572 "Serializing JIT data..." print flush
574 "Serializing global namespace..." print flush
576 "Serializing special object table..." print flush
578 "Performing word fixups..." print flush
580 "Performing header fixups..." print flush
582 "Image length: " write image get length .
583 "Object cache size: " write objects get assoc-size .
584 \ word global delete-at
589 : (write-image) ( image -- )
590 bootstrap-cell big-endian get
591 [ '[ _ >be write ] each ]
592 [ '[ _ >le write ] each ] if ;
594 : write-image ( image -- )
595 "Writing image to " write
596 architecture get boot-image-name resource-path
597 [ write "..." print flush ]
598 [ binary [ (write-image) ] with-file-writer ] bi ;
602 : make-image ( arch -- )
605 "resource:/core/bootstrap/stage1.factor" run-file
611 images [ make-image ] each ;