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.private classes.builtin classes.tuple
9 classes.tuple.private vocabs vocabs.loader source-files
10 definitions debugger quotations.private combinators
11 combinators.short-circuit math.order math.private accessors
12 slots.private generic.single.private compiler.units
13 compiler.constants fry locals bootstrap.image.syntax
17 : arch ( os cpu -- arch )
18 [ dup "winnt" = "winnt" "unix" ? ] dip
20 { "ppc" [ drop "-ppc" append ] }
21 { "x86.32" [ nip "-x86.32" append ] }
22 { "x86.64" [ nip "-x86.64" append ] }
26 os name>> cpu name>> arch ;
28 : boot-image-name ( arch -- string )
29 "boot." ".image" surround ;
31 : my-boot-image-name ( -- string )
32 my-arch boot-image-name ;
36 "winnt-x86.32" "unix-x86.32"
37 "winnt-x86.64" "unix-x86.64"
38 "linux-ppc" "macosx-ppc"
43 ! Object cache; we only consider numbers equal if they have the
45 TUPLE: eql-wrapper { obj read-only } ;
47 C: <eql-wrapper> eql-wrapper
49 M: eql-wrapper hashcode* obj>> hashcode* ;
51 GENERIC: (eql?) ( obj1 obj2 -- ? )
53 : eql? ( obj1 obj2 -- ? )
54 { [ [ class ] bi@ = ] [ (eql?) ] } 2&& ;
56 M: fixnum (eql?) eq? ;
60 M: float (eql?) fp-bitwise= ;
62 M: sequence (eql?) 2dup [ length ] bi@ = [ [ eql? ] 2all? ] [ 2drop f ] if ;
67 over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
69 TUPLE: eq-wrapper { obj read-only } ;
71 C: <eq-wrapper> eq-wrapper
74 over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
76 M: eq-wrapper hashcode*
77 nip obj>> identity-hashcode ;
81 : cache-eql-object ( obj quot -- value )
82 [ <eql-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
84 : cache-eq-object ( obj quot -- value )
85 [ <eq-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
87 : lookup-object ( obj -- n/f ) <eq-wrapper> objects get at ;
89 : put-object ( n obj -- ) <eq-wrapper> objects get set-at ;
93 CONSTANT: image-magic HEX: 0f0e0d0c
94 CONSTANT: image-version 4
96 CONSTANT: data-base 1024
98 CONSTANT: special-objects-size 70
100 CONSTANT: header-size 10
102 CONSTANT: data-heap-size-offset 3
106 CONSTANT: -1-offset 9
108 SYMBOL: sub-primitives
110 SYMBOL: jit-relocations
114 : compute-offset ( -- offset )
115 building get length jit-offset get + ;
117 : jit-rel ( rc rt -- )
118 compute-offset 3array jit-relocations get push-all ;
120 SYMBOL: jit-parameters
122 : jit-parameter ( parameter -- )
123 jit-parameters get push ;
127 : jit-literal ( literal -- )
128 jit-literals get push ;
130 : jit-vm ( offset rc -- )
131 [ jit-parameter ] dip rt-vm jit-rel ;
133 : jit-dlsym ( name rc -- )
134 rt-dlsym jit-rel string>symbol jit-parameter f jit-parameter ;
136 :: jit-conditional ( test-quot false-quot -- )
137 [ 0 test-quot call ] B{ } make length :> len
138 building get length jit-offset get + len +
139 [ jit-offset set false-quot call ] B{ } make
140 [ length test-quot call ] [ % ] bi ; inline
142 : make-jit ( quot -- jit-parameters jit-literals jit-code )
145 V{ } clone jit-parameters set
146 V{ } clone jit-literals set
147 V{ } clone jit-relocations set
149 jit-parameters get >array
150 jit-literals get >array
151 jit-relocations get >array
154 : jit-define ( quot name -- )
155 [ make-jit 2nip ] dip set ;
157 : define-sub-primitive ( quot word -- )
158 [ make-jit 3array ] dip sub-primitives get set-at ;
160 : define-combinator-primitive ( quot non-tail-quot tail-quot word -- )
167 sub-primitives get set-at ;
169 ! The image being constructed; a vector of word-size integers
172 ! Image output format
175 ! Bootstrap architecture name
180 ! Boot quotation, set in stage1.factor
181 SPECIAL-OBJECT: bootstrap-startup-quot 20
183 ! Bootstrap global namesapce
184 SPECIAL-OBJECT: bootstrap-global 21
187 SPECIAL-OBJECT: jit-prolog 23
188 SPECIAL-OBJECT: jit-primitive-word 24
189 SPECIAL-OBJECT: jit-primitive 25
190 SPECIAL-OBJECT: jit-word-jump 26
191 SPECIAL-OBJECT: jit-word-call 27
192 SPECIAL-OBJECT: jit-if-word 28
193 SPECIAL-OBJECT: jit-if 29
194 SPECIAL-OBJECT: jit-epilog 30
195 SPECIAL-OBJECT: jit-return 31
196 SPECIAL-OBJECT: jit-profiling 32
197 SPECIAL-OBJECT: jit-push 33
198 SPECIAL-OBJECT: jit-dip-word 34
199 SPECIAL-OBJECT: jit-dip 35
200 SPECIAL-OBJECT: jit-2dip-word 36
201 SPECIAL-OBJECT: jit-2dip 37
202 SPECIAL-OBJECT: jit-3dip-word 38
203 SPECIAL-OBJECT: jit-3dip 39
204 SPECIAL-OBJECT: jit-execute 40
205 SPECIAL-OBJECT: jit-declare-word 41
207 SPECIAL-OBJECT: c-to-factor-word 42
208 SPECIAL-OBJECT: lazy-jit-compile-word 43
209 SPECIAL-OBJECT: unwind-native-frames-word 44
211 SPECIAL-OBJECT: callback-stub 48
214 SPECIAL-OBJECT: pic-load 49
215 SPECIAL-OBJECT: pic-tag 50
216 SPECIAL-OBJECT: pic-tuple 51
217 SPECIAL-OBJECT: pic-check-tag 52
218 SPECIAL-OBJECT: pic-check-tuple 53
219 SPECIAL-OBJECT: pic-hit 54
220 SPECIAL-OBJECT: pic-miss-word 55
221 SPECIAL-OBJECT: pic-miss-tail-word 56
223 ! Megamorphic dispatch
224 SPECIAL-OBJECT: mega-lookup 57
225 SPECIAL-OBJECT: mega-lookup-word 58
226 SPECIAL-OBJECT: mega-miss-word 59
228 ! Default definition for undefined words
229 SPECIAL-OBJECT: undefined-quot 60
231 : special-object-offset ( symbol -- n )
232 special-objects get at header-size + ;
234 : emit ( cell -- ) image get push ;
236 : emit-64 ( cell -- )
240 d>w/w big-endian get [ swap ] unless emit emit
243 : emit-seq ( seq -- ) image get push-all ;
245 : fixup ( value offset -- ) image get set-nth ;
247 : heap-size ( -- size )
248 image get length header-size - special-objects-size -
251 : here ( -- size ) heap-size data-base + ;
253 : here-as ( tag -- pointer ) here bitor ;
255 : (align-here) ( alignment -- )
257 [ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
260 data-alignment get (align-here) ;
262 : emit-fixnum ( n -- ) tag-fixnum emit ;
264 : emit-header ( n -- ) tag-header emit ;
266 : emit-object ( class quot -- addr )
267 [ type-number ] dip over here-as
268 [ swap emit-header call align-here ] dip ;
271 ! Write an object to the image.
272 GENERIC: ' ( obj -- ptr )
276 : emit-image-header ( -- )
279 data-base emit ! relocation base at end of header
280 0 emit ! size of data heap set later
281 0 emit ! reloc base of code heap is 0
282 0 emit ! size of code heap is 0
283 0 emit ! pointer to t object
284 0 emit ! pointer to bignum 0
285 0 emit ! pointer to bignum 1
286 0 emit ! pointer to bignum -1
287 special-objects-size [ f ' emit ] times ;
289 : emit-special-object ( symbol -- )
290 [ get ' ] [ special-object-offset ] bi fixup ;
294 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
296 : bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
298 : bignum>seq ( n -- seq )
299 #! n is positive or zero.
301 [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
304 : emit-bignum ( n -- )
305 dup dup 0 < [ neg ] when bignum>seq
306 [ nip length 1 + emit-fixnum ]
307 [ drop 0 < 1 0 ? emit ]
313 bignum [ emit-bignum ] emit-object
319 #! When generating a 32-bit image on a 64-bit system,
320 #! some fixnums should be bignums.
322 bootstrap-most-negative-fixnum
323 bootstrap-most-positive-fixnum between?
324 [ tag-fixnum ] [ >bignum ' ] if ;
326 TUPLE: fake-bignum n ;
328 C: <fake-bignum> fake-bignum
330 M: fake-bignum ' n>> tag-fixnum ;
337 8 (align-here) double>bits emit-64
343 ! Padded with fixnums for 8-byte alignment
345 : t, ( -- ) t t-offset fixup ;
347 M: f ' 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-def 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 ;