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 sequences.generalizations strings sbufs
7 vectors words quotations assocs system layouts splitting
8 grouping growable classes classes.private classes.builtin
9 classes.tuple classes.tuple.private vocabs vocabs.loader
10 source-files 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 [ "winnt" = "winnt" "unix" ? ] dip "-" glue ;
21 os name>> cpu name>> arch ;
23 : boot-image-name ( arch -- string )
24 "boot." ".image" surround ;
26 : my-boot-image-name ( -- string )
27 my-arch boot-image-name ;
31 "winnt-x86.32" "unix-x86.32"
32 "winnt-x86.64" "unix-x86.64"
37 ! Object cache; we only consider numbers equal if they have the
39 TUPLE: eql-wrapper { obj read-only } ;
41 C: <eql-wrapper> eql-wrapper
43 M: eql-wrapper hashcode* obj>> hashcode* ;
45 GENERIC: (eql?) ( obj1 obj2 -- ? )
47 : eql? ( obj1 obj2 -- ? )
48 { [ [ class ] bi@ = ] [ (eql?) ] } 2&& ;
50 M: fixnum (eql?) eq? ;
54 M: float (eql?) fp-bitwise= ;
56 M: sequence (eql?) 2dup [ length ] bi@ = [ [ eql? ] 2all? ] [ 2drop f ] if ;
61 over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
63 TUPLE: eq-wrapper { obj read-only } ;
65 C: <eq-wrapper> eq-wrapper
68 over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
70 M: eq-wrapper hashcode*
71 nip obj>> identity-hashcode ;
75 : cache-eql-object ( obj quot -- value )
76 [ <eql-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
78 : cache-eq-object ( obj quot -- value )
79 [ <eq-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
81 : lookup-object ( obj -- n/f ) <eq-wrapper> objects get at ;
83 : put-object ( n obj -- ) <eq-wrapper> objects get set-at ;
87 CONSTANT: image-magic HEX: 0f0e0d0c
88 CONSTANT: image-version 4
90 CONSTANT: data-base 1024
92 CONSTANT: special-objects-size 70
94 CONSTANT: header-size 10
96 CONSTANT: data-heap-size-offset 3
100 CONSTANT: -1-offset 9
102 SYMBOL: sub-primitives
104 SYMBOL: jit-relocations
108 : compute-offset ( -- offset )
109 building get length jit-offset get + ;
111 : jit-rel ( rc rt -- )
112 compute-offset 3array jit-relocations get push-all ;
114 SYMBOL: jit-parameters
116 : jit-parameter ( parameter -- )
117 jit-parameters get push ;
121 : jit-literal ( literal -- )
122 jit-literals get push ;
124 : jit-vm ( offset rc -- )
125 [ jit-parameter ] dip rt-vm jit-rel ;
127 : jit-dlsym ( name rc -- )
128 rt-dlsym jit-rel string>symbol jit-parameter f jit-parameter ;
130 :: jit-conditional ( test-quot false-quot -- )
131 [ 0 test-quot call ] B{ } make length :> len
132 building get length jit-offset get + len +
133 [ jit-offset set false-quot call ] B{ } make
134 [ length test-quot call ] [ % ] bi ; inline
136 : make-jit ( quot -- jit-parameters jit-literals jit-code )
139 V{ } clone jit-parameters set
140 V{ } clone jit-literals set
141 V{ } clone jit-relocations set
143 jit-parameters get >array
144 jit-literals get >array
145 jit-relocations get >array
148 : jit-define ( quot name -- )
149 [ make-jit 2nip ] dip set ;
151 : define-sub-primitive ( quot word -- )
152 [ make-jit 3array ] dip sub-primitives get set-at ;
154 : define-combinator-primitive ( quot non-tail-quot tail-quot word -- )
161 sub-primitives get set-at ;
163 ! The image being constructed; a vector of word-size integers
166 ! Image output format
169 ! Bootstrap architecture name
174 ! Boot quotation, set in stage1.factor
175 SPECIAL-OBJECT: bootstrap-startup-quot 20
177 ! Bootstrap global namesapce
178 SPECIAL-OBJECT: bootstrap-global 21
181 SPECIAL-OBJECT: jit-prolog 23
182 SPECIAL-OBJECT: jit-primitive-word 24
183 SPECIAL-OBJECT: jit-primitive 25
184 SPECIAL-OBJECT: jit-word-jump 26
185 SPECIAL-OBJECT: jit-word-call 27
186 SPECIAL-OBJECT: jit-if-word 28
187 SPECIAL-OBJECT: jit-if 29
188 SPECIAL-OBJECT: jit-epilog 30
189 SPECIAL-OBJECT: jit-return 31
190 SPECIAL-OBJECT: jit-profiling 32
191 SPECIAL-OBJECT: jit-push 33
192 SPECIAL-OBJECT: jit-dip-word 34
193 SPECIAL-OBJECT: jit-dip 35
194 SPECIAL-OBJECT: jit-2dip-word 36
195 SPECIAL-OBJECT: jit-2dip 37
196 SPECIAL-OBJECT: jit-3dip-word 38
197 SPECIAL-OBJECT: jit-3dip 39
198 SPECIAL-OBJECT: jit-execute 40
199 SPECIAL-OBJECT: jit-declare-word 41
201 SPECIAL-OBJECT: c-to-factor-word 42
202 SPECIAL-OBJECT: lazy-jit-compile-word 43
203 SPECIAL-OBJECT: unwind-native-frames-word 44
204 SPECIAL-OBJECT: fpu-state-word 45
205 SPECIAL-OBJECT: set-fpu-state-word 46
207 SPECIAL-OBJECT: callback-stub 48
210 SPECIAL-OBJECT: pic-load 49
211 SPECIAL-OBJECT: pic-tag 50
212 SPECIAL-OBJECT: pic-tuple 51
213 SPECIAL-OBJECT: pic-check-tag 52
214 SPECIAL-OBJECT: pic-check-tuple 53
215 SPECIAL-OBJECT: pic-hit 54
216 SPECIAL-OBJECT: pic-miss-word 55
217 SPECIAL-OBJECT: pic-miss-tail-word 56
219 ! Megamorphic dispatch
220 SPECIAL-OBJECT: mega-lookup 57
221 SPECIAL-OBJECT: mega-lookup-word 58
222 SPECIAL-OBJECT: mega-miss-word 59
224 ! Default definition for undefined words
225 SPECIAL-OBJECT: undefined-quot 60
227 : special-object-offset ( symbol -- n )
228 special-objects get at header-size + ;
230 : emit ( cell -- ) image get push ;
232 : emit-64 ( cell -- )
236 d>w/w big-endian get [ swap ] unless emit emit
239 : emit-seq ( seq -- ) image get push-all ;
241 : fixup ( value offset -- ) image get set-nth ;
243 : heap-size ( -- size )
244 image get length header-size - special-objects-size -
247 : here ( -- size ) heap-size data-base + ;
249 : here-as ( tag -- pointer ) here bitor ;
251 : (align-here) ( alignment -- )
253 [ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
256 data-alignment get (align-here) ;
258 : emit-fixnum ( n -- ) tag-fixnum emit ;
260 : emit-header ( n -- ) tag-header emit ;
262 : emit-object ( class quot -- addr )
263 [ type-number ] dip over here-as
264 [ swap emit-header call align-here ] dip ;
267 ! Write an object to the image.
268 GENERIC: ' ( obj -- ptr )
272 : emit-image-header ( -- )
275 data-base emit ! relocation base at end of header
276 0 emit ! size of data heap set later
277 0 emit ! reloc base of code heap is 0
278 0 emit ! size of code heap is 0
279 0 emit ! pointer to t object
280 0 emit ! pointer to bignum 0
281 0 emit ! pointer to bignum 1
282 0 emit ! pointer to bignum -1
283 special-objects-size [ f ' emit ] times ;
285 : emit-special-object ( symbol -- )
286 [ get ' ] [ special-object-offset ] bi fixup ;
290 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
292 : bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
294 : bignum>seq ( n -- seq )
295 #! n is positive or zero.
297 [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
300 : emit-bignum ( n -- )
301 dup dup 0 < [ neg ] when bignum>seq
302 [ nip length 1 + emit-fixnum ]
303 [ drop 0 < 1 0 ? emit ]
309 bignum [ emit-bignum ] emit-object
315 #! When generating a 32-bit image on a 64-bit system,
316 #! some fixnums should be bignums.
318 bootstrap-most-negative-fixnum
319 bootstrap-most-positive-fixnum between?
320 [ tag-fixnum ] [ >bignum ' ] if ;
322 TUPLE: fake-bignum n ;
324 C: <fake-bignum> fake-bignum
326 M: fake-bignum ' n>> tag-fixnum ;
333 8 (align-here) double>bits emit-64
339 ! Padded with fixnums for 8-byte alignment
341 : t, ( -- ) t t-offset fixup ;
343 M: f ' drop \ f type-number ;
345 : 0, ( -- ) 0 >bignum ' 0-offset fixup ;
346 : 1, ( -- ) 1 >bignum ' 1-offset fixup ;
347 : -1, ( -- ) -1 >bignum ' -1-offset fixup ;
351 : word-sub-primitive ( word -- obj )
352 global [ target-word ] bind sub-primitives get at ;
354 : emit-word ( word -- )
356 [ subwords [ emit-word ] each ]
360 [ hashcode <fake-bignum> , ]
368 [ word-sub-primitive , ]
371 [ drop 0 , ] ! profiling
375 \ word [ emit-seq ] emit-object
378 : word-error ( word msg -- * )
379 [ % dup vocabulary>> % " " % name>> % ] "" make throw ;
381 : transfer-word ( word -- word )
382 [ target-word ] keep or ;
384 : fixup-word ( word -- offset )
385 transfer-word dup lookup-object
386 [ ] [ "Not in image: " word-error ] ?if ;
389 image get [ dup word? [ fixup-word ] when ] map! drop ;
396 [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
399 : native> ( object -- object )
400 big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
402 : emit-bytes ( seq -- )
403 bootstrap-cell <groups> native> emit-seq ;
405 : pad-bytes ( seq -- newseq )
406 dup length bootstrap-cell align 0 pad-tail ;
408 : extended-part ( str -- str' )
409 dup [ 128 < ] all? [ drop f ] [
410 [ -7 shift 1 bitxor ] { } map-as
412 [ [ 2 >be ] { } map-as ]
413 [ [ 2 >le ] { } map-as ] if
417 : ascii-part ( str -- str' )
419 [ 128 mod ] [ 128 >= ] bi
423 : emit-string ( string -- ptr )
424 [ length ] [ extended-part ' ] [ ] tri
428 [ f ' emit ascii-part pad-bytes emit-bytes ]
433 #! We pool strings so that each string is only written once
435 [ emit-string ] cache-eql-object ;
437 : assert-empty ( seq -- )
440 : emit-dummy-array ( obj type -- ptr )
442 [ 0 emit-fixnum ] emit-object
448 dup length emit-fixnum
449 bootstrap-cell 4 = [ 0 emit 0 emit ] when
455 ERROR: tuple-removed class ;
457 : require-tuple-layout ( word -- layout )
458 dup tuple-layout [ ] [ tuple-removed ] ?if ;
460 : (emit-tuple) ( tuple -- pointer )
462 [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
463 tuple [ emit-seq ] emit-object ;
465 : emit-tuple ( tuple -- pointer )
466 dup class name>> "tombstone" =
467 [ [ (emit-tuple) ] cache-eql-object ]
468 [ [ (emit-tuple) ] cache-eq-object ]
471 M: tuple ' emit-tuple ;
474 state>> "((tombstone))" "((empty))" ?
475 "hashtables.private" lookup def>> first
476 [ emit-tuple ] cache-eql-object ;
479 : emit-array ( array -- offset )
480 [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
482 M: array ' [ emit-array ] cache-eq-object ;
484 ! This is a hack. We need to detect arrays which are tuple
485 ! layout arrays so that they can be internalized, but making
486 ! them a built-in type is not worth it.
487 PREDICATE: tuple-layout-array < array
489 [ first tuple-class? ]
495 M: tuple-layout-array '
497 [ dup integer? [ <fake-bignum> ] when ] map
508 f ' emit ! cached-effect
509 f ' emit ! cache-counter
518 all-words [ emit-word ] each ;
522 dictionary source-files builtins
523 update-map implementors-map
524 } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
526 class<=-cache class-not-cache classes-intersect-cache
527 class-and-cache class-or-cache next-method-quot-cache
528 } [ H{ } clone ] H{ } map>assoc assoc-union
529 bootstrap-global set ;
531 : emit-jit-data ( -- )
533 \ do-primitive jit-primitive-word set
534 \ dip jit-dip-word set
535 \ 2dip jit-2dip-word set
536 \ 3dip jit-3dip-word set
537 \ inline-cache-miss pic-miss-word set
538 \ inline-cache-miss-tail pic-miss-tail-word set
539 \ mega-cache-lookup mega-lookup-word set
540 \ mega-cache-miss mega-miss-word set
541 \ declare jit-declare-word set
542 \ c-to-factor c-to-factor-word set
543 \ lazy-jit-compile lazy-jit-compile-word set
544 \ unwind-native-frames unwind-native-frames-word set
545 \ fpu-state fpu-state-word set
546 \ set-fpu-state set-fpu-state-word set
547 undefined-def undefined-quot set ;
549 : emit-special-objects ( -- )
550 special-objects get keys [ emit-special-object ] each ;
552 : fixup-header ( -- )
553 heap-size data-heap-size-offset fixup ;
555 : build-generics ( -- )
559 [ make-generic ] each
560 ] with-compilation-unit ;
562 : build-image ( -- image )
563 800000 <vector> image set
564 20000 <hashtable> objects set
565 emit-image-header t, 0, 1, -1,
566 "Building generic words..." print flush
568 "Serializing words..." print flush
570 "Serializing JIT data..." print flush
572 "Serializing global namespace..." print flush
574 "Serializing special object table..." print flush
576 "Performing word fixups..." print flush
578 "Performing header fixups..." print flush
580 "Image length: " write image get length .
581 "Object cache size: " write objects get assoc-size .
582 \ word global delete-at
587 : (write-image) ( image -- )
588 bootstrap-cell big-endian get
589 [ '[ _ >be write ] each ]
590 [ '[ _ >le write ] each ] if ;
592 : write-image ( image -- )
593 "Writing image to " write
594 architecture get boot-image-name resource-path
595 [ write "..." print flush ]
596 [ binary [ (write-image) ] with-file-writer ] bi ;
600 : make-image ( arch -- )
603 "resource:/core/bootstrap/stage1.factor" run-file
609 images [ make-image ] each ;