1 ! Copyright (C) 2004, 2009 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 strings sbufs vectors words quotations
7 assocs system layouts splitting grouping growable classes
8 classes.builtin classes.tuple classes.tuple.private vocabs
9 vocabs.loader source-files definitions debugger
10 quotations.private combinators combinators.short-circuit
11 math.order math.private accessors slots.private
12 generic.single.private compiler.units compiler.constants fry
13 locals bootstrap.image.syntax generalizations ;
16 : arch ( os cpu -- arch )
18 { "ppc" [ "-ppc" append ] }
19 { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
24 os name>> cpu name>> arch ;
26 : boot-image-name ( arch -- string )
27 "boot." ".image" surround ;
29 : my-boot-image-name ( -- string )
30 my-arch boot-image-name ;
35 "winnt-x86.64" "unix-x86.64"
36 "linux-ppc" "macosx-ppc"
41 ! Object cache; we only consider numbers equal if they have the
43 TUPLE: eql-wrapper { obj read-only } ;
45 C: <eql-wrapper> eql-wrapper
47 M: eql-wrapper hashcode* obj>> hashcode* ;
49 GENERIC: (eql?) ( obj1 obj2 -- ? )
51 : eql? ( obj1 obj2 -- ? )
52 { [ [ class ] bi@ = ] [ (eql?) ] } 2&& ;
54 M: fixnum (eql?) eq? ;
58 M: float (eql?) fp-bitwise= ;
60 M: sequence (eql?) 2dup [ length ] bi@ = [ [ eql? ] 2all? ] [ 2drop f ] if ;
65 over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
67 TUPLE: eq-wrapper { obj read-only } ;
69 C: <eq-wrapper> eq-wrapper
72 over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
74 M: eq-wrapper hashcode*
75 nip obj>> identity-hashcode ;
79 : cache-eql-object ( obj quot -- value )
80 [ <eql-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
82 : cache-eq-object ( obj quot -- value )
83 [ <eq-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
85 : lookup-object ( obj -- n/f ) <eq-wrapper> objects get at ;
87 : put-object ( n obj -- ) <eq-wrapper> objects get set-at ;
91 CONSTANT: image-magic HEX: 0f0e0d0c
92 CONSTANT: image-version 4
94 CONSTANT: data-base 1024
96 CONSTANT: userenv-size 70
98 CONSTANT: header-size 10
100 CONSTANT: data-heap-size-offset 3
104 CONSTANT: -1-offset 9
106 SYMBOL: sub-primitives
108 SYMBOL: jit-relocations
112 : compute-offset ( -- offset )
113 building get length jit-offset get + ;
115 : jit-rel ( rc rt -- )
116 compute-offset 3array jit-relocations get push-all ;
118 SYMBOL: jit-parameters
120 : jit-parameter ( parameter -- )
121 jit-parameters get push ;
125 : jit-literal ( literal -- )
126 jit-literals get push ;
128 : jit-vm ( offset rc -- )
129 [ jit-parameter ] dip rt-vm jit-rel ;
131 : jit-dlsym ( name library rc -- )
132 rt-dlsym jit-rel [ string>symbol jit-parameter ] bi@ ;
134 :: jit-conditional ( test-quot false-quot -- )
135 [ 0 test-quot call ] B{ } make length :> len
136 building get length jit-offset get + len +
137 [ jit-offset set false-quot call ] B{ } make
138 [ length test-quot call ] [ % ] bi ; inline
140 : make-jit ( quot -- jit-parameters jit-literals jit-code )
143 V{ } clone jit-parameters set
144 V{ } clone jit-literals set
145 V{ } clone jit-relocations set
147 jit-parameters get >array
148 jit-literals get >array
149 jit-relocations get >array
152 : jit-define ( quot name -- )
153 [ make-jit 2nip ] dip set ;
155 : define-sub-primitive ( quot word -- )
156 [ make-jit 3array ] dip sub-primitives get set-at ;
158 : define-sub-primitive* ( quot non-tail-quot tail-quot word -- )
165 sub-primitives get set-at ;
167 ! The image being constructed; a vector of word-size integers
170 ! Image output format
173 ! Bootstrap architecture name
178 ! Boot quotation, set in stage1.factor
179 USERENV: bootstrap-startup-quot 20
181 ! Bootstrap global namesapce
182 USERENV: bootstrap-global 21
185 USERENV: jit-prolog 23
186 USERENV: jit-primitive-word 24
187 USERENV: jit-primitive 25
188 USERENV: jit-word-jump 26
189 USERENV: jit-word-call 27
190 USERENV: jit-if-word 28
192 USERENV: jit-epilog 30
193 USERENV: jit-return 31
194 USERENV: jit-profiling 32
196 USERENV: jit-dip-word 34
198 USERENV: jit-2dip-word 36
200 USERENV: jit-3dip-word 38
202 USERENV: jit-execute 40
203 USERENV: jit-declare-word 41
205 USERENV: callback-stub 48
210 USERENV: pic-tuple 51
211 USERENV: pic-check-tag 52
212 USERENV: pic-check-tuple 53
214 USERENV: pic-miss-word 55
215 USERENV: pic-miss-tail-word 56
217 ! Megamorphic dispatch
218 USERENV: mega-lookup 57
219 USERENV: mega-lookup-word 58
220 USERENV: mega-miss-word 59
222 ! Default definition for undefined words
223 USERENV: undefined-quot 60
225 : userenv-offset ( symbol -- n )
226 userenvs get at header-size + ;
228 : emit ( cell -- ) image get push ;
230 : emit-64 ( cell -- )
234 d>w/w big-endian get [ swap ] unless emit emit
237 : emit-seq ( seq -- ) image get push-all ;
239 : fixup ( value offset -- ) image get set-nth ;
241 : heap-size ( -- size )
242 image get length header-size - userenv-size -
245 : here ( -- size ) heap-size data-base + ;
247 : here-as ( tag -- pointer ) here bitor ;
249 : (align-here) ( alignment -- )
251 [ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
254 data-alignment get (align-here) ;
256 : emit-fixnum ( n -- ) tag-fixnum emit ;
258 : emit-header ( n -- ) tag-header emit ;
260 : emit-object ( class quot -- addr )
261 [ type-number ] dip over here-as
262 [ swap emit-header call align-here ] dip ;
265 ! Write an object to the image.
266 GENERIC: ' ( obj -- ptr )
270 : emit-image-header ( -- )
273 data-base emit ! relocation base at end of header
274 0 emit ! size of data heap set later
275 0 emit ! reloc base of code heap is 0
276 0 emit ! size of code heap is 0
277 0 emit ! pointer to t object
278 0 emit ! pointer to bignum 0
279 0 emit ! pointer to bignum 1
280 0 emit ! pointer to bignum -1
281 userenv-size [ f ' emit ] times ;
283 : emit-userenv ( symbol -- )
284 [ get ' ] [ userenv-offset ] bi fixup ;
288 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
290 : bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
292 : bignum>seq ( n -- seq )
293 #! n is positive or zero.
295 [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
298 : emit-bignum ( n -- )
299 dup dup 0 < [ neg ] when bignum>seq
300 [ nip length 1 + emit-fixnum ]
301 [ drop 0 < 1 0 ? emit ]
307 bignum [ emit-bignum ] emit-object
313 #! When generating a 32-bit image on a 64-bit system,
314 #! some fixnums should be bignums.
316 bootstrap-most-negative-fixnum
317 bootstrap-most-positive-fixnum between?
318 [ tag-fixnum ] [ >bignum ' ] if ;
320 TUPLE: fake-bignum n ;
322 C: <fake-bignum> fake-bignum
324 M: fake-bignum ' n>> tag-fixnum ;
331 8 (align-here) double>bits emit-64
337 ! Padded with fixnums for 8-byte alignment
339 : t, ( -- ) t t-offset fixup ;
342 #! f is #define F RETAG(0,F_TYPE)
343 drop \ f type-number ;
345 : 0, ( -- ) 0 >bignum ' 0-offset fixup ;
346 : 1, ( -- ) 1 >bignum ' 1-offset fixup ;
347 : -1, ( -- ) -1 >bignum ' -1-offset fixup ;
351 : word-sub-primitive ( word -- obj )
352 global [ target-word ] bind sub-primitives get at ;
354 : emit-word ( word -- )
356 [ subwords [ emit-word ] each ]
360 [ hashcode <fake-bignum> , ]
368 [ word-sub-primitive , ]
371 [ drop 0 , ] ! profiling
375 \ word [ emit-seq ] emit-object
378 : word-error ( word msg -- * )
379 [ % dup vocabulary>> % " " % name>> % ] "" make throw ;
381 : transfer-word ( word -- word )
382 [ target-word ] keep or ;
384 : fixup-word ( word -- offset )
385 transfer-word dup lookup-object
386 [ ] [ "Not in image: " word-error ] ?if ;
389 image get [ dup word? [ fixup-word ] when ] map! drop ;
396 [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
399 : native> ( object -- object )
400 big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
402 : emit-bytes ( seq -- )
403 bootstrap-cell <groups> native> emit-seq ;
405 : pad-bytes ( seq -- newseq )
406 dup length bootstrap-cell align 0 pad-tail ;
408 : extended-part ( str -- str' )
409 dup [ 128 < ] all? [ drop f ] [
410 [ -7 shift 1 bitxor ] { } map-as
412 [ [ 2 >be ] { } map-as ]
413 [ [ 2 >le ] { } map-as ] if
417 : ascii-part ( str -- str' )
419 [ 128 mod ] [ 128 >= ] bi
423 : emit-string ( string -- ptr )
424 [ length ] [ extended-part ' ] [ ] tri
428 [ f ' emit ascii-part pad-bytes emit-bytes ]
433 #! We pool strings so that each string is only written once
435 [ emit-string ] cache-eql-object ;
437 : assert-empty ( seq -- )
440 : emit-dummy-array ( obj type -- ptr )
442 [ 0 emit-fixnum ] emit-object
448 dup length emit-fixnum
449 bootstrap-cell 4 = [ 0 emit 0 emit ] when
455 ERROR: tuple-removed class ;
457 : require-tuple-layout ( word -- layout )
458 dup tuple-layout [ ] [ tuple-removed ] ?if ;
460 : (emit-tuple) ( tuple -- pointer )
462 [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
463 tuple [ emit-seq ] emit-object ;
465 : emit-tuple ( tuple -- pointer )
466 dup class name>> "tombstone" =
467 [ [ (emit-tuple) ] cache-eql-object ]
468 [ [ (emit-tuple) ] cache-eq-object ]
471 M: tuple ' emit-tuple ;
474 state>> "((tombstone))" "((empty))" ?
475 "hashtables.private" lookup def>> first
476 [ emit-tuple ] cache-eql-object ;
479 : emit-array ( array -- offset )
480 [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
482 M: array ' [ emit-array ] cache-eq-object ;
484 ! This is a hack. We need to detect arrays which are tuple
485 ! layout arrays so that they can be internalized, but making
486 ! them a built-in type is not worth it.
487 PREDICATE: tuple-layout-array < array
489 [ first tuple-class? ]
495 M: tuple-layout-array '
497 [ dup integer? [ <fake-bignum> ] when ] map
508 f ' emit ! cached-effect
509 f ' emit ! cache-counter
518 all-words [ emit-word ] each ;
522 dictionary source-files builtins
523 update-map implementors-map
524 } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
526 class<=-cache class-not-cache classes-intersect-cache
527 class-and-cache class-or-cache next-method-quot-cache
528 } [ H{ } clone ] H{ } map>assoc assoc-union
529 bootstrap-global set ;
531 : emit-jit-data ( -- )
533 \ do-primitive jit-primitive-word set
534 \ dip jit-dip-word set
535 \ 2dip jit-2dip-word set
536 \ 3dip jit-3dip-word set
537 \ inline-cache-miss \ pic-miss-word set
538 \ inline-cache-miss-tail \ pic-miss-tail-word set
539 \ mega-cache-lookup \ mega-lookup-word set
540 \ mega-cache-miss \ mega-miss-word set
541 \ declare jit-declare-word set
542 [ undefined ] undefined-quot set ;
544 : emit-userenvs ( -- )
545 userenvs get keys [ emit-userenv ] each ;
547 : fixup-header ( -- )
548 heap-size data-heap-size-offset fixup ;
550 : build-image ( -- image )
551 800000 <vector> image set
552 20000 <hashtable> objects set
553 emit-image-header t, 0, 1, -1,
554 "Building generic words..." print flush
556 "Serializing words..." print flush
558 "Serializing JIT data..." print flush
560 "Serializing global namespace..." print flush
562 "Serializing user environment..." print flush
564 "Performing word fixups..." print flush
566 "Performing header fixups..." print flush
568 "Image length: " write image get length .
569 "Object cache size: " write objects get assoc-size .
570 \ word global delete-at
575 : (write-image) ( image -- )
576 bootstrap-cell big-endian get
577 [ '[ _ >be write ] each ]
578 [ '[ _ >le 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 -- )
591 "resource:/core/bootstrap/stage1.factor" run-file
597 images [ make-image ] each ;