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 ] 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 70
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-epilog 30
170 SPECIAL-OBJECT: jit-return 31
171 SPECIAL-OBJECT: jit-profiling 32
172 SPECIAL-OBJECT: jit-push 33
173 SPECIAL-OBJECT: jit-dip-word 34
174 SPECIAL-OBJECT: jit-dip 35
175 SPECIAL-OBJECT: jit-2dip-word 36
176 SPECIAL-OBJECT: jit-2dip 37
177 SPECIAL-OBJECT: jit-3dip-word 38
178 SPECIAL-OBJECT: jit-3dip 39
179 SPECIAL-OBJECT: jit-execute 40
180 SPECIAL-OBJECT: jit-declare-word 41
182 SPECIAL-OBJECT: c-to-factor-word 42
183 SPECIAL-OBJECT: lazy-jit-compile-word 43
184 SPECIAL-OBJECT: unwind-native-frames-word 44
185 SPECIAL-OBJECT: fpu-state-word 45
186 SPECIAL-OBJECT: set-fpu-state-word 46
188 SPECIAL-OBJECT: callback-stub 48
191 SPECIAL-OBJECT: pic-load 49
192 SPECIAL-OBJECT: pic-tag 50
193 SPECIAL-OBJECT: pic-tuple 51
194 SPECIAL-OBJECT: pic-check-tag 52
195 SPECIAL-OBJECT: pic-check-tuple 53
196 SPECIAL-OBJECT: pic-hit 54
197 SPECIAL-OBJECT: pic-miss-word 55
198 SPECIAL-OBJECT: pic-miss-tail-word 56
200 ! Megamorphic dispatch
201 SPECIAL-OBJECT: mega-lookup 57
202 SPECIAL-OBJECT: mega-lookup-word 58
203 SPECIAL-OBJECT: mega-miss-word 59
205 ! Default definition for undefined words
206 SPECIAL-OBJECT: undefined-quot 60
208 : special-object-offset ( symbol -- n )
209 special-objects get at header-size + ;
211 : emit ( cell -- ) image get push ;
213 : emit-64 ( cell -- )
217 d>w/w big-endian get [ swap ] unless emit emit
220 : emit-seq ( seq -- ) image get push-all ;
222 : fixup ( value offset -- ) image get set-nth ;
224 : heap-size ( -- size )
225 image get length header-size - special-objects-size -
228 : here ( -- size ) heap-size data-base + ;
230 : here-as ( tag -- pointer ) here bitor ;
232 : (align-here) ( alignment -- )
234 [ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
237 data-alignment get (align-here) ;
239 : emit-fixnum ( n -- ) tag-fixnum emit ;
241 : emit-header ( n -- ) tag-header emit ;
243 : emit-object ( class quot -- addr )
244 [ type-number ] dip over here-as
245 [ swap emit-header call align-here ] dip ;
248 ! Write an object to the image.
249 GENERIC: ' ( obj -- ptr )
253 : emit-image-header ( -- )
256 data-base emit ! relocation base at end of header
257 0 emit ! size of data heap set later
258 0 emit ! reloc base of code heap is 0
259 0 emit ! size of code heap is 0
260 0 emit ! pointer to t object
261 0 emit ! pointer to bignum 0
262 0 emit ! pointer to bignum 1
263 0 emit ! pointer to bignum -1
264 special-objects-size [ f ' emit ] times ;
266 : emit-special-object ( symbol -- )
267 [ get ' ] [ special-object-offset ] bi fixup ;
271 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
273 : bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
275 : bignum>seq ( n -- seq )
276 #! n is positive or zero.
278 [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
281 : emit-bignum ( n -- )
282 dup dup 0 < [ neg ] when bignum>seq
283 [ nip length 1 + emit-fixnum ]
284 [ drop 0 < 1 0 ? emit ]
290 bignum [ emit-bignum ] emit-object
296 #! When generating a 32-bit image on a 64-bit system,
297 #! some fixnums should be bignums.
299 bootstrap-most-negative-fixnum
300 bootstrap-most-positive-fixnum between?
301 [ tag-fixnum ] [ >bignum ' ] if ;
303 TUPLE: fake-bignum n ;
305 C: <fake-bignum> fake-bignum
307 M: fake-bignum ' n>> tag-fixnum ;
314 8 (align-here) double>bits emit-64
320 ! Padded with fixnums for 8-byte alignment
322 : t, ( -- ) t t-offset fixup ;
324 M: f ' drop \ f type-number ;
326 : 0, ( -- ) 0 >bignum ' 0-offset fixup ;
327 : 1, ( -- ) 1 >bignum ' 1-offset fixup ;
328 : -1, ( -- ) -1 >bignum ' -1-offset fixup ;
332 : word-sub-primitive ( word -- obj )
333 global [ target-word ] bind sub-primitives get at ;
335 : emit-word ( word -- )
337 [ subwords [ emit-word ] each ]
341 [ hashcode <fake-bignum> , ]
349 [ word-sub-primitive , ]
352 [ drop 0 , ] ! profiling
356 \ word [ emit-seq ] emit-object
359 : word-error ( word msg -- * )
360 [ % dup vocabulary>> % " " % name>> % ] "" make throw ;
362 : transfer-word ( word -- word )
363 [ target-word ] keep or ;
365 : fixup-word ( word -- offset )
366 transfer-word dup lookup-object
367 [ ] [ "Not in image: " word-error ] ?if ;
370 image get [ dup word? [ fixup-word ] when ] map! drop ;
377 [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
380 : native> ( object -- object )
381 big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
383 : emit-bytes ( seq -- )
384 bootstrap-cell <groups> native> emit-seq ;
386 : pad-bytes ( seq -- newseq )
387 dup length bootstrap-cell align 0 pad-tail ;
389 : extended-part ( str -- str' )
390 dup [ 128 < ] all? [ drop f ] [
391 [ -7 shift 1 bitxor ] { } map-as
393 [ [ 2 >be ] { } map-as ]
394 [ [ 2 >le ] { } map-as ] if
398 : ascii-part ( str -- str' )
400 [ 128 mod ] [ 128 >= ] bi
404 : emit-string ( string -- ptr )
405 [ length ] [ extended-part ' ] [ ] tri
409 [ f ' emit ascii-part pad-bytes emit-bytes ]
414 #! We pool strings so that each string is only written once
416 [ emit-string ] cache-eql-object ;
418 : assert-empty ( seq -- )
421 : emit-dummy-array ( obj type -- ptr )
423 [ 0 emit-fixnum ] emit-object
429 dup length emit-fixnum
430 bootstrap-cell 4 = [ 0 emit 0 emit ] when
436 ERROR: tuple-removed class ;
438 : require-tuple-layout ( word -- layout )
439 dup tuple-layout [ ] [ tuple-removed ] ?if ;
441 : (emit-tuple) ( tuple -- pointer )
443 [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
444 tuple [ emit-seq ] emit-object ;
446 : emit-tuple ( tuple -- pointer )
447 dup class name>> "tombstone" =
448 [ [ (emit-tuple) ] cache-eql-object ]
449 [ [ (emit-tuple) ] cache-eq-object ]
452 M: tuple ' emit-tuple ;
455 state>> "((tombstone))" "((empty))" ?
456 "hashtables.private" lookup def>> first
457 [ emit-tuple ] cache-eql-object ;
460 : emit-array ( array -- offset )
461 [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
463 M: array ' [ emit-array ] cache-eq-object ;
465 ! This is a hack. We need to detect arrays which are tuple
466 ! layout arrays so that they can be internalized, but making
467 ! them a built-in type is not worth it.
468 PREDICATE: tuple-layout-array < array
470 [ first tuple-class? ]
476 M: tuple-layout-array '
478 [ dup integer? [ <fake-bignum> ] when ] map
489 f ' emit ! cached-effect
490 f ' emit ! cache-counter
499 all-words [ emit-word ] each ;
503 dictionary source-files builtins
504 update-map implementors-map
505 } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
507 class<=-cache class-not-cache classes-intersect-cache
508 class-and-cache class-or-cache next-method-quot-cache
509 } [ H{ } clone ] H{ } map>assoc assoc-union
510 bootstrap-global set ;
512 : emit-jit-data ( -- )
514 \ do-primitive jit-primitive-word set
515 \ dip jit-dip-word set
516 \ 2dip jit-2dip-word set
517 \ 3dip jit-3dip-word set
518 \ inline-cache-miss pic-miss-word set
519 \ inline-cache-miss-tail pic-miss-tail-word set
520 \ mega-cache-lookup mega-lookup-word set
521 \ mega-cache-miss mega-miss-word set
522 \ declare jit-declare-word set
523 \ c-to-factor c-to-factor-word set
524 \ lazy-jit-compile lazy-jit-compile-word set
525 \ unwind-native-frames unwind-native-frames-word set
526 \ fpu-state fpu-state-word set
527 \ set-fpu-state set-fpu-state-word set
528 undefined-def undefined-quot set ;
530 : emit-special-objects ( -- )
531 special-objects get keys [ emit-special-object ] each ;
533 : fixup-header ( -- )
534 heap-size data-heap-size-offset fixup ;
536 : build-generics ( -- )
540 [ make-generic ] each
541 ] with-compilation-unit ;
543 : build-image ( -- image )
544 800000 <vector> image set
545 20000 <hashtable> objects set
546 emit-image-header t, 0, 1, -1,
547 "Building generic words..." print flush
549 "Serializing words..." print flush
551 "Serializing JIT data..." print flush
553 "Serializing global namespace..." print flush
555 "Serializing special object table..." print flush
557 "Performing word fixups..." print flush
559 "Performing header fixups..." print flush
561 "Image length: " write image get length .
562 "Object cache size: " write objects get assoc-size .
563 \ word global delete-at
568 : (write-image) ( image -- )
569 bootstrap-cell big-endian get
570 [ '[ _ >be write ] each ]
571 [ '[ _ >le write ] each ] if ;
573 : write-image ( image -- )
574 "Writing image to " write
575 architecture get boot-image-name resource-path
576 [ write "..." print flush ]
577 [ binary [ (write-image) ] with-file-writer ] bi ;
581 : make-image ( arch -- )
585 "resource:/core/bootstrap/stage1.factor" run-file
591 images [ make-image ] each ;