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> , ]
353 [ word-sub-primitive , ]
354 [ drop 0 , ] ! entry point
358 \ word [ emit-seq ] emit-object
361 : word-error ( word msg -- * )
362 [ % dup vocabulary>> % " " % name>> % ] "" make throw ;
364 : transfer-word ( word -- word )
365 [ target-word ] keep or ;
367 : fixup-word ( word -- offset )
368 transfer-word dup lookup-object
369 [ ] [ "Not in image: " word-error ] ?if ;
372 image get [ dup word? [ fixup-word ] when ] map! drop ;
379 [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
382 : native> ( object -- object )
383 big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
385 : emit-bytes ( seq -- )
386 bootstrap-cell <groups> native> emit-seq ;
388 : pad-bytes ( seq -- newseq )
389 dup length bootstrap-cell align 0 pad-tail ;
391 : extended-part ( str -- str' )
392 dup [ 128 < ] all? [ drop f ] [
393 [ -7 shift 1 bitxor ] { } map-as
395 [ [ 2 >be ] { } map-as ]
396 [ [ 2 >le ] { } map-as ] if
400 : ascii-part ( str -- str' )
402 [ 128 mod ] [ 128 >= ] bi
406 : emit-string ( string -- ptr )
407 [ length ] [ extended-part ' ] [ ] tri
411 [ f ' emit ascii-part pad-bytes emit-bytes ]
416 #! We pool strings so that each string is only written once
418 [ emit-string ] cache-eql-object ;
420 : assert-empty ( seq -- )
423 : emit-dummy-array ( obj type -- ptr )
425 [ 0 emit-fixnum ] emit-object
431 dup length emit-fixnum
432 bootstrap-cell 4 = [ 0 emit 0 emit ] when
438 ERROR: tuple-removed class ;
440 : require-tuple-layout ( word -- layout )
441 dup tuple-layout [ ] [ tuple-removed ] ?if ;
443 : (emit-tuple) ( tuple -- pointer )
445 [ class-of transfer-word require-tuple-layout ] bi prefix [ ' ] map
446 tuple [ emit-seq ] emit-object ;
448 : emit-tuple ( tuple -- pointer )
449 dup class-of name>> "tombstone" =
450 [ [ (emit-tuple) ] cache-eql-object ]
451 [ [ (emit-tuple) ] cache-eq-object ]
454 M: tuple ' emit-tuple ;
457 state>> "((tombstone))" "((empty))" ?
458 "hashtables.private" lookup-word def>> first
459 [ emit-tuple ] cache-eql-object ;
462 : emit-array ( array -- offset )
463 [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
465 M: array ' [ emit-array ] cache-eq-object ;
467 ! This is a hack. We need to detect arrays which are tuple
468 ! layout arrays so that they can be internalized, but making
469 ! them a built-in type is not worth it.
470 PREDICATE: tuple-layout-array < array
472 [ first tuple-class? ]
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 ] 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 ] H{ } map>assoc assoc-union
511 bootstrap-global set ;
513 : emit-jit-data ( -- )
515 \ do-primitive jit-primitive-word set
516 \ dip jit-dip-word set
517 \ 2dip jit-2dip-word set
518 \ 3dip jit-3dip-word set
519 \ inline-cache-miss pic-miss-word set
520 \ inline-cache-miss-tail pic-miss-tail-word set
521 \ mega-cache-lookup mega-lookup-word set
522 \ mega-cache-miss mega-miss-word set
523 \ declare jit-declare-word set
524 \ c-to-factor c-to-factor-word set
525 \ lazy-jit-compile lazy-jit-compile-word set
526 \ unwind-native-frames unwind-native-frames-word set
527 \ fpu-state fpu-state-word set
528 \ set-fpu-state set-fpu-state-word set
529 \ signal-handler signal-handler-word set
530 \ leaf-signal-handler leaf-signal-handler-word set
531 \ ffi-signal-handler ffi-signal-handler-word set
532 \ ffi-leaf-signal-handler ffi-leaf-signal-handler-word set
533 undefined-def undefined-quot set ;
535 : emit-special-objects ( -- )
536 special-objects get keys [ emit-special-object ] each ;
538 : fixup-header ( -- )
539 heap-size data-heap-size-offset fixup ;
541 : build-generics ( -- )
545 [ make-generic ] each
546 ] with-compilation-unit ;
548 : build-image ( -- image )
549 800000 <vector> image set
550 20000 <hashtable> objects set
551 emit-image-header t, 0, 1, -1,
552 "Building generic words..." print flush
554 "Serializing words..." print flush
556 "Serializing JIT data..." print flush
558 "Serializing global namespace..." print flush
560 "Serializing special object table..." print flush
562 "Performing word fixups..." print flush
564 "Performing header fixups..." print flush
566 "Image length: " write image get length .
567 "Object cache size: " write objects get assoc-size .
568 \ word global delete-at
573 : (write-image) ( image -- )
574 bootstrap-cell big-endian get
575 [ '[ _ >be write ] each ]
576 [ '[ _ >le write ] each ] if ;
578 : write-image ( image -- )
579 "Writing image to " write
580 architecture get boot-image-name resource-path
581 [ write "..." print flush ]
582 [ binary [ (write-image) ] with-file-writer ] bi ;
586 : make-image ( arch -- )
591 "resource:/core/bootstrap/stage1.factor" run-file
597 images [ make-image ] each ;