1 ! Copyright (C) 2004, 2011 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs bootstrap.image.syntax
4 byte-arrays classes classes.builtin classes.private
5 classes.tuple classes.tuple.private combinators
6 combinators.short-circuit combinators.smart
7 compiler.codegen.relocation compiler.units fry generic
8 generic.single.private grouping hashtables hashtables.private io
9 io.binary io.encodings.binary io.files io.pathnames kernel
10 kernel.private layouts locals make math math.order namespaces
11 namespaces.private parser parser.notes prettyprint quotations
12 sequences sequences.private source-files strings system vectors
16 : arch-name ( os cpu -- arch )
17 2dup [ windows? ] [ ppc? ] bi* or [
20 [ name>> ] bi@ "-" glue ;
22 : my-arch-name ( -- arch )
25 : boot-image-name ( arch -- string )
26 "boot." ".image" surround ;
28 : my-boot-image-name ( -- string )
29 my-arch-name boot-image-name ;
33 "windows-x86.32" "unix-x86.32"
34 "windows-x86.64" "unix-x86.64"
39 ! Object cache; we only consider numbers equal if they have the
41 TUPLE: eql-wrapper { obj read-only } ;
43 C: <eql-wrapper> eql-wrapper
45 M: eql-wrapper hashcode* obj>> hashcode* ;
47 GENERIC: (eql?) ( obj1 obj2 -- ? )
49 : eql? ( obj1 obj2 -- ? )
50 { [ [ class-of ] same? ] [ (eql?) ] } 2&& ;
52 M: fixnum (eql?) eq? ;
54 M: bignum (eql?) { bignum bignum } declare = ;
56 M: float (eql?) fp-bitwise= ;
59 2dup [ length ] same? [ [ eql? ] 2all? ] [ 2drop f ] if ;
64 over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
66 TUPLE: eq-wrapper { obj read-only } ;
68 C: <eq-wrapper> eq-wrapper
71 over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
73 M: eq-wrapper hashcode*
74 nip obj>> identity-hashcode ;
78 : cache-eql-object ( obj quot -- value )
79 [ <eql-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
81 : cache-eq-object ( obj quot -- value )
82 [ <eq-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
84 : lookup-object ( obj -- n/f )
85 <eq-wrapper> objects get at ;
87 : put-object ( n obj -- )
88 <eq-wrapper> objects get set-at ;
92 CONSTANT: image-magic 0x0f0e0d0c
93 CONSTANT: image-version 4
95 CONSTANT: data-base 1024
97 CONSTANT: special-objects-size 80
99 CONSTANT: header-size 10
101 CONSTANT: data-heap-size-offset 3
105 CONSTANT: -1-offset 9
107 SYMBOL: sub-primitives
109 :: jit-conditional ( test-quot false-quot -- )
110 [ 0 test-quot call ] B{ } make length :> len
111 building get length extra-offset get + len +
112 [ extra-offset set false-quot call ] B{ } make
113 [ length test-quot call ] [ % ] bi ; inline
115 : make-jit ( quot -- parameters literals code )
116 #! code is a { relocation insns } pair
121 parameter-table get >array
122 literal-table get >array
123 relocation-table get >byte-array
126 : make-jit-no-params ( quot -- code )
129 : jit-define ( quot name -- )
130 [ make-jit-no-params ] dip set ;
132 : define-sub-primitive ( quot word -- )
133 [ make-jit 3array ] dip sub-primitives get set-at ;
135 : define-combinator-primitive ( quot non-tail-quot tail-quot word -- )
139 [ make-jit-no-params ]
140 [ make-jit-no-params ]
144 sub-primitives get set-at ;
146 ! The image being constructed; a vector of word-size integers
147 SYMBOL: bootstrapping-image
149 ! Image output format
156 ! Boot quotation, set in stage1.factor
157 SPECIAL-OBJECT: bootstrap-startup-quot 20
159 ! Bootstrap global namesapce
160 SPECIAL-OBJECT: bootstrap-global 21
163 SPECIAL-OBJECT: jit-prolog 23
164 SPECIAL-OBJECT: jit-primitive-word 24
165 SPECIAL-OBJECT: jit-primitive 25
166 SPECIAL-OBJECT: jit-word-jump 26
167 SPECIAL-OBJECT: jit-word-call 27
168 SPECIAL-OBJECT: jit-if-word 28
169 SPECIAL-OBJECT: jit-if 29
170 SPECIAL-OBJECT: jit-safepoint 30
171 SPECIAL-OBJECT: jit-epilog 31
172 SPECIAL-OBJECT: jit-return 32
173 SPECIAL-OBJECT: jit-profiling 33
174 SPECIAL-OBJECT: jit-push 34
175 SPECIAL-OBJECT: jit-dip-word 35
176 SPECIAL-OBJECT: jit-dip 36
177 SPECIAL-OBJECT: jit-2dip-word 37
178 SPECIAL-OBJECT: jit-2dip 38
179 SPECIAL-OBJECT: jit-3dip-word 39
180 SPECIAL-OBJECT: jit-3dip 40
181 SPECIAL-OBJECT: jit-execute 41
182 SPECIAL-OBJECT: jit-declare-word 42
184 SPECIAL-OBJECT: c-to-factor-word 43
185 SPECIAL-OBJECT: lazy-jit-compile-word 44
186 SPECIAL-OBJECT: unwind-native-frames-word 45
187 SPECIAL-OBJECT: fpu-state-word 46
188 SPECIAL-OBJECT: set-fpu-state-word 47
189 SPECIAL-OBJECT: signal-handler-word 48
190 SPECIAL-OBJECT: leaf-signal-handler-word 49
191 SPECIAL-OBJECT: ffi-signal-handler-word 50
192 SPECIAL-OBJECT: ffi-leaf-signal-handler-word 51
194 SPECIAL-OBJECT: callback-stub 53
197 SPECIAL-OBJECT: pic-load 54
198 SPECIAL-OBJECT: pic-tag 55
199 SPECIAL-OBJECT: pic-tuple 56
200 SPECIAL-OBJECT: pic-check-tag 57
201 SPECIAL-OBJECT: pic-check-tuple 58
202 SPECIAL-OBJECT: pic-hit 59
203 SPECIAL-OBJECT: pic-miss-word 60
204 SPECIAL-OBJECT: pic-miss-tail-word 61
206 ! Megamorphic dispatch
207 SPECIAL-OBJECT: mega-lookup 62
208 SPECIAL-OBJECT: mega-lookup-word 63
209 SPECIAL-OBJECT: mega-miss-word 64
211 ! Default definition for undefined words
212 SPECIAL-OBJECT: undefined-quot 65
214 : special-object-offset ( symbol -- n )
215 special-objects get at header-size + ;
217 : emit ( cell -- ) bootstrapping-image get push ;
219 : emit-64 ( cell -- )
223 d>w/w big-endian get [ swap ] unless emit emit
226 : emit-seq ( seq -- ) bootstrapping-image get push-all ;
228 : fixup ( value offset -- ) bootstrapping-image get set-nth ;
230 : heap-size ( -- size )
231 bootstrapping-image get length header-size - special-objects-size -
234 : here ( -- size ) heap-size data-base + ;
236 : here-as ( tag -- pointer ) here bitor ;
238 : (align-here) ( alignment -- )
240 [ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
243 data-alignment get (align-here) ;
245 : emit-fixnum ( n -- ) tag-fixnum emit ;
247 : emit-header ( n -- ) tag-header emit ;
249 : emit-object ( class quot -- addr )
250 [ type-number ] dip over here-as
251 [ swap emit-header call align-here ] dip ; inline
253 ! Write an object to the image.
254 GENERIC: ' ( obj -- ptr )
258 : emit-image-header ( -- )
261 data-base emit ! relocation base at end of header
262 0 emit ! size of data heap set later
263 0 emit ! reloc base of code heap is 0
264 0 emit ! size of code heap is 0
265 0 emit ! pointer to t object
266 0 emit ! pointer to bignum 0
267 0 emit ! pointer to bignum 1
268 0 emit ! pointer to bignum -1
269 special-objects-size [ f ' emit ] times ;
271 : emit-special-object ( symbol -- )
272 [ get ' ] [ special-object-offset ] bi fixup ;
276 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
278 : bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
280 : bignum>sequence ( n -- seq )
281 #! n is positive or zero.
283 [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
286 : emit-bignum ( n -- )
287 dup dup 0 < [ neg ] when bignum>sequence
288 [ nip length 1 + emit-fixnum ]
289 [ drop 0 < 1 0 ? emit ]
295 bignum [ emit-bignum ] emit-object
301 #! When generating a 32-bit image on a 64-bit system,
302 #! some fixnums should be bignums.
304 bootstrap-most-negative-fixnum
305 bootstrap-most-positive-fixnum between?
306 [ tag-fixnum ] [ >bignum ' ] if ;
308 TUPLE: fake-bignum n ;
310 C: <fake-bignum> fake-bignum
312 M: fake-bignum ' n>> tag-fixnum ;
319 8 (align-here) double>bits emit-64
325 ! Padded with fixnums for 8-byte alignment
327 : t, ( -- ) t t-offset fixup ;
329 M: f ' drop \ f type-number ;
331 : 0, ( -- ) 0 >bignum ' 0-offset fixup ;
332 : 1, ( -- ) 1 >bignum ' 1-offset fixup ;
333 : -1, ( -- ) -1 >bignum ' -1-offset fixup ;
337 : word-sub-primitive ( word -- obj )
338 [ target-word ] with-global sub-primitives get at ;
340 : emit-word ( word -- )
342 [ subwords [ emit-word ] each ]
346 [ hashcode <fake-bignum> ]
353 [ word-sub-primitive ]
354 [ drop 0 ] ! entry point
356 ] output>array [ ' ] map!
358 \ word [ emit-seq ] emit-object
361 ERROR: not-in-image vocabulary word ;
363 : transfer-word ( word -- word )
364 [ target-word ] keep or ;
366 : fixup-word ( word -- offset )
367 transfer-word dup lookup-object
368 [ ] [ [ vocabulary>> ] [ name>> ] bi throw-not-in-image ] ?if ;
371 bootstrapping-image get [ dup word? [ fixup-word ] when ] map! drop ;
378 [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
381 : native> ( object -- object )
382 big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
384 : emit-bytes ( seq -- )
385 bootstrap-cell <groups> native> emit-seq ;
387 : pad-bytes ( seq -- newseq )
388 dup length bootstrap-cell align 0 pad-tail ;
390 : extended-part ( str -- str' )
391 dup [ 128 < ] all? [ drop f ] [
392 [ -7 shift 1 bitxor ] { } map-as
394 [ [ 2 >be ] { } map-as ]
395 [ [ 2 >le ] { } map-as ] if
399 : ascii-part ( str -- str' )
401 [ 128 mod ] [ 128 >= ] bi
405 : emit-string ( string -- ptr )
406 [ length ] [ extended-part ' ] [ ] tri
410 [ f ' emit ascii-part pad-bytes emit-bytes ]
415 #! We pool strings so that each string is only written once
417 [ emit-string ] cache-eql-object ;
419 : assert-empty ( seq -- )
422 : emit-dummy-array ( obj type -- ptr )
424 [ 0 emit-fixnum ] emit-object
430 dup length emit-fixnum
431 bootstrap-cell 4 = [ 0 emit 0 emit ] when
437 ERROR: tuple-removed class ;
439 : require-tuple-layout ( word -- layout )
440 dup tuple-layout [ ] [ throw-tuple-removed ] ?if ;
442 : (emit-tuple) ( tuple -- pointer )
444 [ class-of transfer-word require-tuple-layout ] bi prefix [ ' ] map
445 tuple [ emit-seq ] emit-object ;
447 : emit-tuple ( tuple -- pointer )
448 dup class-of name>> "tombstone" =
449 [ [ (emit-tuple) ] cache-eql-object ]
450 [ [ (emit-tuple) ] cache-eq-object ]
453 M: tuple ' emit-tuple ;
456 state>> "((tombstone))" "((empty))" ?
457 "hashtables.private" lookup-word def>> first
458 [ emit-tuple ] cache-eql-object ;
461 : emit-array ( array -- offset )
462 [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
464 M: array ' [ emit-array ] cache-eq-object ;
466 ! This is a hack. We need to detect arrays which are tuple
467 ! layout arrays so that they can be internalized, but making
468 ! them a built-in type is not worth it.
469 PREDICATE: tuple-layout-array < array
472 [ first-unsafe tuple-class? ]
473 [ second-unsafe fixnum? ]
474 [ third-unsafe fixnum? ]
478 M: tuple-layout-array '
480 [ dup integer? [ <fake-bignum> ] when ] map
491 f ' emit ! cached-effect
492 f ' emit ! cache-counter
500 all-words [ emit-word ] each ;
504 dictionary source-files builtins
505 update-map implementors-map
506 } [ [ bootstrap-word ] [ get global-box boa ] bi ] H{ } map>assoc
508 class<=-cache class-not-cache classes-intersect-cache
509 class-and-cache class-or-cache next-method-quot-cache
510 } [ H{ } clone global-box boa ] H{ } map>assoc assoc-union
512 bootstrap-global set ;
514 : emit-jit-data ( -- )
516 \ do-primitive jit-primitive-word set
517 \ dip jit-dip-word set
518 \ 2dip jit-2dip-word set
519 \ 3dip jit-3dip-word set
520 \ inline-cache-miss pic-miss-word set
521 \ inline-cache-miss-tail pic-miss-tail-word set
522 \ mega-cache-lookup mega-lookup-word set
523 \ mega-cache-miss mega-miss-word set
524 \ declare jit-declare-word set
525 \ c-to-factor c-to-factor-word set
526 \ lazy-jit-compile lazy-jit-compile-word set
527 \ unwind-native-frames unwind-native-frames-word set
528 \ fpu-state fpu-state-word set
529 \ set-fpu-state set-fpu-state-word set
530 \ signal-handler signal-handler-word set
531 \ leaf-signal-handler leaf-signal-handler-word set
532 \ ffi-signal-handler ffi-signal-handler-word set
533 \ ffi-leaf-signal-handler ffi-leaf-signal-handler-word set
534 undefined-def undefined-quot set ;
536 : emit-special-objects ( -- )
537 special-objects get keys [ emit-special-object ] each ;
539 : fixup-header ( -- )
540 heap-size data-heap-size-offset fixup ;
542 : build-generics ( -- )
546 [ make-generic ] each
547 ] with-compilation-unit ;
549 : build-image ( -- image )
550 600,000 <vector> bootstrapping-image set
551 60,000 <hashtable> objects set
552 emit-image-header t, 0, 1, -1,
553 "Building generic words..." print flush
555 "Serializing words..." print flush
557 "Serializing JIT data..." print flush
559 "Serializing global namespace..." print flush
561 "Serializing special object table..." print flush
563 "Performing word fixups..." print flush
565 "Performing header fixups..." print flush
567 "Image length: " write bootstrapping-image get length .
568 "Object cache size: " write objects get assoc-size .
569 \ last-word global delete-at
570 bootstrapping-image get ;
574 : (write-image) ( image -- )
575 bootstrap-cell output-stream get
577 [ '[ _ >be _ stream-write ] each ]
578 [ '[ _ >le _ stream-write ] each ] if ;
580 : write-image ( image -- )
581 "Writing image to " write
582 architecture get boot-image-name resource-path
583 [ write "..." print flush ]
584 [ binary [ (write-image) ] with-file-writer ] bi ;
588 : make-image ( arch -- )
589 architecture associate H{
593 "resource:/core/bootstrap/stage1.factor" run-file
599 image-names [ make-image ] each ;
601 : make-my-image ( -- )
602 my-arch-name make-image ;