1 ! Copyright (C) 2004, 2011 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 combinators.smart strings sbufs vectors
7 words quotations assocs system layouts splitting grouping
8 growable classes 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 compiler.codegen.relocation fry locals
14 bootstrap.image.syntax parser.notes ;
17 : arch ( os cpu -- arch )
18 2dup [ windows? ] [ ppc? ] bi* or [
21 [ name>> ] [ name>> ] bi* "-" glue ;
26 : boot-image-name ( arch -- string )
27 "boot." ".image" surround ;
29 : my-boot-image-name ( -- string )
30 my-arch boot-image-name ;
34 "windows-x86.32" "unix-x86.32"
35 "windows-x86.64" "unix-x86.64"
40 ! Object cache; we only consider numbers equal if they have the
42 TUPLE: eql-wrapper { obj read-only } ;
44 C: <eql-wrapper> eql-wrapper
46 M: eql-wrapper hashcode* obj>> hashcode* ;
48 GENERIC: (eql?) ( obj1 obj2 -- ? )
50 : eql? ( obj1 obj2 -- ? )
51 { [ [ class-of ] bi@ = ] [ (eql?) ] } 2&& ;
53 M: fixnum (eql?) eq? ;
57 M: float (eql?) fp-bitwise= ;
59 M: sequence (eql?) 2dup [ length ] bi@ = [ [ 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 ) <eq-wrapper> objects get at ;
86 : put-object ( n obj -- ) <eq-wrapper> objects get set-at ;
90 CONSTANT: image-magic HEX: 0f0e0d0c
91 CONSTANT: image-version 4
93 CONSTANT: data-base 1024
95 CONSTANT: special-objects-size 80
97 CONSTANT: header-size 10
99 CONSTANT: data-heap-size-offset 3
103 CONSTANT: -1-offset 9
105 SYMBOL: sub-primitives
107 :: jit-conditional ( test-quot false-quot -- )
108 [ 0 test-quot call ] B{ } make length :> len
109 building get length extra-offset get + len +
110 [ extra-offset set false-quot call ] B{ } make
111 [ length test-quot call ] [ % ] bi ; inline
113 : make-jit ( quot -- parameters literals code )
114 #! code is a { relocation insns } pair
119 parameter-table get >array
120 literal-table get >array
121 relocation-table get >byte-array
124 : make-jit-no-params ( quot -- code )
127 : jit-define ( quot name -- )
128 [ make-jit-no-params ] dip set ;
130 : define-sub-primitive ( quot word -- )
131 [ make-jit 3array ] dip sub-primitives get set-at ;
133 : define-combinator-primitive ( quot non-tail-quot tail-quot word -- )
137 [ make-jit-no-params ]
138 [ make-jit-no-params ]
142 sub-primitives get set-at ;
144 ! The image being constructed; a vector of word-size integers
147 ! Image output format
150 ! Bootstrap architecture name
155 ! Boot quotation, set in stage1.factor
156 SPECIAL-OBJECT: bootstrap-startup-quot 20
158 ! Bootstrap global namesapce
159 SPECIAL-OBJECT: bootstrap-global 21
162 SPECIAL-OBJECT: jit-prolog 23
163 SPECIAL-OBJECT: jit-primitive-word 24
164 SPECIAL-OBJECT: jit-primitive 25
165 SPECIAL-OBJECT: jit-word-jump 26
166 SPECIAL-OBJECT: jit-word-call 27
167 SPECIAL-OBJECT: jit-if-word 28
168 SPECIAL-OBJECT: jit-if 29
169 SPECIAL-OBJECT: jit-safepoint 30
170 SPECIAL-OBJECT: jit-epilog 31
171 SPECIAL-OBJECT: jit-return 32
172 SPECIAL-OBJECT: jit-profiling 33
173 SPECIAL-OBJECT: jit-push 34
174 SPECIAL-OBJECT: jit-dip-word 35
175 SPECIAL-OBJECT: jit-dip 36
176 SPECIAL-OBJECT: jit-2dip-word 37
177 SPECIAL-OBJECT: jit-2dip 38
178 SPECIAL-OBJECT: jit-3dip-word 39
179 SPECIAL-OBJECT: jit-3dip 40
180 SPECIAL-OBJECT: jit-execute 41
181 SPECIAL-OBJECT: jit-declare-word 42
183 SPECIAL-OBJECT: c-to-factor-word 43
184 SPECIAL-OBJECT: lazy-jit-compile-word 44
185 SPECIAL-OBJECT: unwind-native-frames-word 45
186 SPECIAL-OBJECT: fpu-state-word 46
187 SPECIAL-OBJECT: set-fpu-state-word 47
188 SPECIAL-OBJECT: signal-handler-word 48
189 SPECIAL-OBJECT: leaf-signal-handler-word 49
190 SPECIAL-OBJECT: ffi-signal-handler-word 50
191 SPECIAL-OBJECT: ffi-leaf-signal-handler-word 51
193 SPECIAL-OBJECT: callback-stub 53
196 SPECIAL-OBJECT: pic-load 54
197 SPECIAL-OBJECT: pic-tag 55
198 SPECIAL-OBJECT: pic-tuple 56
199 SPECIAL-OBJECT: pic-check-tag 57
200 SPECIAL-OBJECT: pic-check-tuple 58
201 SPECIAL-OBJECT: pic-hit 59
202 SPECIAL-OBJECT: pic-miss-word 60
203 SPECIAL-OBJECT: pic-miss-tail-word 61
205 ! Megamorphic dispatch
206 SPECIAL-OBJECT: mega-lookup 62
207 SPECIAL-OBJECT: mega-lookup-word 63
208 SPECIAL-OBJECT: mega-miss-word 64
210 ! Default definition for undefined words
211 SPECIAL-OBJECT: undefined-quot 65
213 : special-object-offset ( symbol -- n )
214 special-objects get at header-size + ;
216 : emit ( cell -- ) image get push ;
218 : emit-64 ( cell -- )
222 d>w/w big-endian get [ swap ] unless emit emit
225 : emit-seq ( seq -- ) image get push-all ;
227 : fixup ( value offset -- ) image get set-nth ;
229 : heap-size ( -- size )
230 image get length header-size - special-objects-size -
233 : here ( -- size ) heap-size data-base + ;
235 : here-as ( tag -- pointer ) here bitor ;
237 : (align-here) ( alignment -- )
239 [ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
242 data-alignment get (align-here) ;
244 : emit-fixnum ( n -- ) tag-fixnum emit ;
246 : emit-header ( n -- ) tag-header emit ;
248 : emit-object ( class quot -- addr )
249 [ type-number ] dip over here-as
250 [ swap emit-header call align-here ] dip ;
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>seq ( 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>seq
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> , ]
354 [ word-sub-primitive , ]
357 [ drop 0 , ] ! profiling
361 \ word [ emit-seq ] emit-object
364 : word-error ( word msg -- * )
365 [ % dup vocabulary>> % " " % name>> % ] "" make throw ;
367 : transfer-word ( word -- word )
368 [ target-word ] keep or ;
370 : fixup-word ( word -- offset )
371 transfer-word dup lookup-object
372 [ ] [ "Not in image: " word-error ] ?if ;
375 image get [ dup word? [ fixup-word ] when ] map! drop ;
382 [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
385 : native> ( object -- object )
386 big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
388 : emit-bytes ( seq -- )
389 bootstrap-cell <groups> native> emit-seq ;
391 : pad-bytes ( seq -- newseq )
392 dup length bootstrap-cell align 0 pad-tail ;
394 : extended-part ( str -- str' )
395 dup [ 128 < ] all? [ drop f ] [
396 [ -7 shift 1 bitxor ] { } map-as
398 [ [ 2 >be ] { } map-as ]
399 [ [ 2 >le ] { } map-as ] if
403 : ascii-part ( str -- str' )
405 [ 128 mod ] [ 128 >= ] bi
409 : emit-string ( string -- ptr )
410 [ length ] [ extended-part ' ] [ ] tri
414 [ f ' emit ascii-part pad-bytes emit-bytes ]
419 #! We pool strings so that each string is only written once
421 [ emit-string ] cache-eql-object ;
423 : assert-empty ( seq -- )
426 : emit-dummy-array ( obj type -- ptr )
428 [ 0 emit-fixnum ] emit-object
434 dup length emit-fixnum
435 bootstrap-cell 4 = [ 0 emit 0 emit ] when
441 ERROR: tuple-removed class ;
443 : require-tuple-layout ( word -- layout )
444 dup tuple-layout [ ] [ tuple-removed ] ?if ;
446 : (emit-tuple) ( tuple -- pointer )
448 [ class-of transfer-word require-tuple-layout ] bi prefix [ ' ] map
449 tuple [ emit-seq ] emit-object ;
451 : emit-tuple ( tuple -- pointer )
452 dup class-of name>> "tombstone" =
453 [ [ (emit-tuple) ] cache-eql-object ]
454 [ [ (emit-tuple) ] cache-eq-object ]
457 M: tuple ' emit-tuple ;
460 state>> "((tombstone))" "((empty))" ?
461 "hashtables.private" lookup-word def>> first
462 [ emit-tuple ] cache-eql-object ;
465 : emit-array ( array -- offset )
466 [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
468 M: array ' [ emit-array ] cache-eq-object ;
470 ! This is a hack. We need to detect arrays which are tuple
471 ! layout arrays so that they can be internalized, but making
472 ! them a built-in type is not worth it.
473 PREDICATE: tuple-layout-array < array
475 [ first tuple-class? ]
481 M: tuple-layout-array '
483 [ dup integer? [ <fake-bignum> ] when ] map
494 f ' emit ! cached-effect
495 f ' emit ! cache-counter
504 all-words [ emit-word ] each ;
508 dictionary source-files builtins
509 update-map implementors-map
510 } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
512 class<=-cache class-not-cache classes-intersect-cache
513 class-and-cache class-or-cache next-method-quot-cache
514 } [ H{ } clone ] H{ } map>assoc assoc-union
515 bootstrap-global set ;
517 : emit-jit-data ( -- )
519 \ do-primitive jit-primitive-word set
520 \ dip jit-dip-word set
521 \ 2dip jit-2dip-word set
522 \ 3dip jit-3dip-word set
523 \ inline-cache-miss pic-miss-word set
524 \ inline-cache-miss-tail pic-miss-tail-word set
525 \ mega-cache-lookup mega-lookup-word set
526 \ mega-cache-miss mega-miss-word set
527 \ declare jit-declare-word set
528 \ c-to-factor c-to-factor-word set
529 \ lazy-jit-compile lazy-jit-compile-word set
530 \ unwind-native-frames unwind-native-frames-word set
531 \ fpu-state fpu-state-word set
532 \ set-fpu-state set-fpu-state-word set
533 \ signal-handler signal-handler-word set
534 \ leaf-signal-handler leaf-signal-handler-word set
535 \ ffi-signal-handler ffi-signal-handler-word set
536 \ ffi-leaf-signal-handler ffi-leaf-signal-handler-word set
537 undefined-def undefined-quot set ;
539 : emit-special-objects ( -- )
540 special-objects get keys [ emit-special-object ] each ;
542 : fixup-header ( -- )
543 heap-size data-heap-size-offset fixup ;
545 : build-generics ( -- )
549 [ make-generic ] each
550 ] with-compilation-unit ;
552 : build-image ( -- image )
553 800000 <vector> image set
554 20000 <hashtable> objects set
555 emit-image-header t, 0, 1, -1,
556 "Building generic words..." print flush
558 "Serializing words..." print flush
560 "Serializing JIT data..." print flush
562 "Serializing global namespace..." print flush
564 "Serializing special object table..." print flush
566 "Performing word fixups..." print flush
568 "Performing header fixups..." print flush
570 "Image length: " write image get length .
571 "Object cache size: " write objects get assoc-size .
572 \ word global delete-at
577 : (write-image) ( image -- )
578 bootstrap-cell big-endian get
579 [ '[ _ >be write ] each ]
580 [ '[ _ >le 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 -- )
595 "resource:/core/bootstrap/stage1.factor" run-file
601 images [ make-image ] each ;