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
9 io 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 ( os cpu -- arch )
17 2dup [ windows? ] [ ppc? ] bi* or [
20 [ name>> ] [ name>> ] bi* "-" glue ;
25 : boot-image-name ( arch -- string )
26 "boot." ".image" surround ;
28 : my-boot-image-name ( -- string )
29 my-arch 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
149 ! Image output format
152 ! Bootstrap architecture name
157 ! Boot quotation, set in stage1.factor
158 SPECIAL-OBJECT: bootstrap-startup-quot 20
160 ! Bootstrap global namesapce
161 SPECIAL-OBJECT: bootstrap-global 21
164 SPECIAL-OBJECT: jit-prolog 23
165 SPECIAL-OBJECT: jit-primitive-word 24
166 SPECIAL-OBJECT: jit-primitive 25
167 SPECIAL-OBJECT: jit-word-jump 26
168 SPECIAL-OBJECT: jit-word-call 27
169 SPECIAL-OBJECT: jit-if-word 28
170 SPECIAL-OBJECT: jit-if 29
171 SPECIAL-OBJECT: jit-safepoint 30
172 SPECIAL-OBJECT: jit-epilog 31
173 SPECIAL-OBJECT: jit-return 32
174 SPECIAL-OBJECT: jit-profiling 33
175 SPECIAL-OBJECT: jit-push 34
176 SPECIAL-OBJECT: jit-dip-word 35
177 SPECIAL-OBJECT: jit-dip 36
178 SPECIAL-OBJECT: jit-2dip-word 37
179 SPECIAL-OBJECT: jit-2dip 38
180 SPECIAL-OBJECT: jit-3dip-word 39
181 SPECIAL-OBJECT: jit-3dip 40
182 SPECIAL-OBJECT: jit-execute 41
183 SPECIAL-OBJECT: jit-declare-word 42
185 SPECIAL-OBJECT: c-to-factor-word 43
186 SPECIAL-OBJECT: lazy-jit-compile-word 44
187 SPECIAL-OBJECT: unwind-native-frames-word 45
188 SPECIAL-OBJECT: fpu-state-word 46
189 SPECIAL-OBJECT: set-fpu-state-word 47
190 SPECIAL-OBJECT: signal-handler-word 48
191 SPECIAL-OBJECT: leaf-signal-handler-word 49
192 SPECIAL-OBJECT: ffi-signal-handler-word 50
193 SPECIAL-OBJECT: ffi-leaf-signal-handler-word 51
195 SPECIAL-OBJECT: callback-stub 53
198 SPECIAL-OBJECT: pic-load 54
199 SPECIAL-OBJECT: pic-tag 55
200 SPECIAL-OBJECT: pic-tuple 56
201 SPECIAL-OBJECT: pic-check-tag 57
202 SPECIAL-OBJECT: pic-check-tuple 58
203 SPECIAL-OBJECT: pic-hit 59
204 SPECIAL-OBJECT: pic-miss-word 60
205 SPECIAL-OBJECT: pic-miss-tail-word 61
207 ! Megamorphic dispatch
208 SPECIAL-OBJECT: mega-lookup 62
209 SPECIAL-OBJECT: mega-lookup-word 63
210 SPECIAL-OBJECT: mega-miss-word 64
212 ! Default definition for undefined words
213 SPECIAL-OBJECT: undefined-quot 65
215 : special-object-offset ( symbol -- n )
216 special-objects get at header-size + ;
218 : emit ( cell -- ) image get push ;
220 : emit-64 ( cell -- )
224 d>w/w big-endian get [ swap ] unless emit emit
227 : emit-seq ( seq -- ) image get push-all ;
229 : fixup ( value offset -- ) image get set-nth ;
231 : heap-size ( -- size )
232 image get length header-size - special-objects-size -
235 : here ( -- size ) heap-size data-base + ;
237 : here-as ( tag -- pointer ) here bitor ;
239 : (align-here) ( alignment -- )
241 [ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
244 data-alignment get (align-here) ;
246 : emit-fixnum ( n -- ) tag-fixnum emit ;
248 : emit-header ( n -- ) tag-header emit ;
250 : emit-object ( class quot -- addr )
251 [ type-number ] dip over here-as
252 [ swap emit-header call align-here ] dip ;
255 ! Write an object to the image.
256 GENERIC: ' ( obj -- ptr )
260 : emit-image-header ( -- )
263 data-base emit ! relocation base at end of header
264 0 emit ! size of data heap set later
265 0 emit ! reloc base of code heap is 0
266 0 emit ! size of code heap is 0
267 0 emit ! pointer to t object
268 0 emit ! pointer to bignum 0
269 0 emit ! pointer to bignum 1
270 0 emit ! pointer to bignum -1
271 special-objects-size [ f ' emit ] times ;
273 : emit-special-object ( symbol -- )
274 [ get ' ] [ special-object-offset ] bi fixup ;
278 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
280 : bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
282 : bignum>sequence ( n -- seq )
283 #! n is positive or zero.
285 [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
288 : emit-bignum ( n -- )
289 dup dup 0 < [ neg ] when bignum>sequence
290 [ nip length 1 + emit-fixnum ]
291 [ drop 0 < 1 0 ? emit ]
297 bignum [ emit-bignum ] emit-object
303 #! When generating a 32-bit image on a 64-bit system,
304 #! some fixnums should be bignums.
306 bootstrap-most-negative-fixnum
307 bootstrap-most-positive-fixnum between?
308 [ tag-fixnum ] [ >bignum ' ] if ;
310 TUPLE: fake-bignum n ;
312 C: <fake-bignum> fake-bignum
314 M: fake-bignum ' n>> tag-fixnum ;
321 8 (align-here) double>bits emit-64
327 ! Padded with fixnums for 8-byte alignment
329 : t, ( -- ) t t-offset fixup ;
331 M: f ' drop \ f type-number ;
333 : 0, ( -- ) 0 >bignum ' 0-offset fixup ;
334 : 1, ( -- ) 1 >bignum ' 1-offset fixup ;
335 : -1, ( -- ) -1 >bignum ' -1-offset fixup ;
339 : word-sub-primitive ( word -- obj )
340 [ target-word ] with-global sub-primitives get at ;
342 : emit-word ( word -- )
344 [ subwords [ emit-word ] each ]
348 [ hashcode <fake-bignum> ]
355 [ word-sub-primitive ]
356 [ drop 0 ] ! entry point
358 ] output>array [ ' ] map!
360 \ word [ emit-seq ] emit-object
363 ERROR: not-in-image vocabulary word ;
365 : transfer-word ( word -- word )
366 [ target-word ] keep or ;
368 : fixup-word ( word -- offset )
369 transfer-word dup lookup-object
370 [ ] [ [ vocabulary>> ] [ name>> ] bi not-in-image ] ?if ;
373 image get [ dup word? [ fixup-word ] when ] map! drop ;
380 [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
383 : native> ( object -- object )
384 big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
386 : emit-bytes ( seq -- )
387 bootstrap-cell <groups> native> emit-seq ;
389 : pad-bytes ( seq -- newseq )
390 dup length bootstrap-cell align 0 pad-tail ;
392 : extended-part ( str -- str' )
393 dup [ 128 < ] all? [ drop f ] [
394 [ -7 shift 1 bitxor ] { } map-as
396 [ [ 2 >be ] { } map-as ]
397 [ [ 2 >le ] { } map-as ] if
401 : ascii-part ( str -- str' )
403 [ 128 mod ] [ 128 >= ] bi
407 : emit-string ( string -- ptr )
408 [ length ] [ extended-part ' ] [ ] tri
412 [ f ' emit ascii-part pad-bytes emit-bytes ]
417 #! We pool strings so that each string is only written once
419 [ emit-string ] cache-eql-object ;
421 : assert-empty ( seq -- )
424 : emit-dummy-array ( obj type -- ptr )
426 [ 0 emit-fixnum ] emit-object
432 dup length emit-fixnum
433 bootstrap-cell 4 = [ 0 emit 0 emit ] when
439 ERROR: tuple-removed class ;
441 : require-tuple-layout ( word -- layout )
442 dup tuple-layout [ ] [ tuple-removed ] ?if ;
444 : (emit-tuple) ( tuple -- pointer )
446 [ class-of transfer-word require-tuple-layout ] bi prefix [ ' ] map
447 tuple [ emit-seq ] emit-object ;
449 : emit-tuple ( tuple -- pointer )
450 dup class-of name>> "tombstone" =
451 [ [ (emit-tuple) ] cache-eql-object ]
452 [ [ (emit-tuple) ] cache-eq-object ]
455 M: tuple ' emit-tuple ;
458 state>> "((tombstone))" "((empty))" ?
459 "hashtables.private" lookup-word def>> first
460 [ emit-tuple ] cache-eql-object ;
463 : emit-array ( array -- offset )
464 [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
466 M: array ' [ emit-array ] cache-eq-object ;
468 ! This is a hack. We need to detect arrays which are tuple
469 ! layout arrays so that they can be internalized, but making
470 ! them a built-in type is not worth it.
471 PREDICATE: tuple-layout-array < array
474 [ first-unsafe tuple-class? ]
475 [ second-unsafe fixnum? ]
476 [ third-unsafe fixnum? ]
480 M: tuple-layout-array '
482 [ dup integer? [ <fake-bignum> ] when ] map
493 f ' emit ! cached-effect
494 f ' emit ! cache-counter
502 all-words [ emit-word ] each ;
506 dictionary source-files builtins
507 update-map implementors-map
508 } [ [ bootstrap-word ] [ get global-box boa ] bi ] H{ } map>assoc
510 class<=-cache class-not-cache classes-intersect-cache
511 class-and-cache class-or-cache next-method-quot-cache
512 } [ H{ } clone global-box boa ] H{ } map>assoc assoc-union
514 bootstrap-global set ;
516 : emit-jit-data ( -- )
518 \ do-primitive jit-primitive-word set
519 \ dip jit-dip-word set
520 \ 2dip jit-2dip-word set
521 \ 3dip jit-3dip-word set
522 \ inline-cache-miss pic-miss-word set
523 \ inline-cache-miss-tail pic-miss-tail-word set
524 \ mega-cache-lookup mega-lookup-word set
525 \ mega-cache-miss mega-miss-word set
526 \ declare jit-declare-word set
527 \ c-to-factor c-to-factor-word set
528 \ lazy-jit-compile lazy-jit-compile-word set
529 \ unwind-native-frames unwind-native-frames-word set
530 \ fpu-state fpu-state-word set
531 \ set-fpu-state set-fpu-state-word set
532 \ signal-handler signal-handler-word set
533 \ leaf-signal-handler leaf-signal-handler-word set
534 \ ffi-signal-handler ffi-signal-handler-word set
535 \ ffi-leaf-signal-handler ffi-leaf-signal-handler-word set
536 undefined-def undefined-quot set ;
538 : emit-special-objects ( -- )
539 special-objects get keys [ emit-special-object ] each ;
541 : fixup-header ( -- )
542 heap-size data-heap-size-offset fixup ;
544 : build-generics ( -- )
548 [ make-generic ] each
549 ] with-compilation-unit ;
551 : build-image ( -- image )
552 600,000 <vector> image set
553 60,000 <hashtable> objects set
554 emit-image-header t, 0, 1, -1,
555 "Building generic words..." print flush
557 "Serializing words..." print flush
559 "Serializing JIT data..." print flush
561 "Serializing global namespace..." print flush
563 "Serializing special object table..." print flush
565 "Performing word fixups..." print flush
567 "Performing header fixups..." print flush
569 "Image length: " write image get length .
570 "Object cache size: " write objects get assoc-size .
571 \ last-word global delete-at
576 : (write-image) ( image -- )
577 bootstrap-cell output-stream get
579 [ '[ _ >be _ stream-write ] each ]
580 [ '[ _ >le _ stream-write ] each ] if ;
582 : write-image ( image -- )
583 "Writing image to " write
584 architecture get boot-image-name resource-path
585 [ write "..." print flush ]
586 [ binary [ (write-image) ] with-file-writer ] bi ;
590 : make-image ( arch -- )
591 architecture associate H{
595 "resource:/core/bootstrap/stage1.factor" run-file
601 images [ make-image ] each ;
603 : make-my-image ( -- )