basis/bootstrap/image/image.factor

   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 ;
  15 IN: bootstrap.image
  16
  17 : arch ( os cpu -- arch )
  18     2dup [ windows? ] [ ppc? ] bi* or [
  19       [ drop unix ] dip
  20     ] unless
  21     [ name>> ] [ name>> ] bi* "-" glue ;
  22
  23 : my-arch ( -- arch )
  24     os cpu arch ;
  25
  26 : boot-image-name ( arch -- string )
  27     "boot." ".image" surround ;
  28
  29 : my-boot-image-name ( -- string )
  30     my-arch boot-image-name ;
  31
  32 : images ( -- seq )
  33     {
  34         "windows-x86.32" "unix-x86.32"
  35         "windows-x86.64" "unix-x86.64"
  36     } ;
  37
  38 <PRIVATE
  39
  40 ! Object cache; we only consider numbers equal if they have the
  41 ! same type
  42 TUPLE: eql-wrapper { obj read-only } ;
  43
  44 C: <eql-wrapper> eql-wrapper
  45
  46 M: eql-wrapper hashcode* obj>> hashcode* ;
  47
  48 GENERIC: (eql?) ( obj1 obj2 -- ? )
  49
  50 : eql? ( obj1 obj2 -- ? )
  51     { [ [ class-of ] bi@ = ] [ (eql?) ] } 2&& ;
  52
  53 M: fixnum (eql?) eq? ;
  54
  55 M: bignum (eql?) = ;
  56
  57 M: float (eql?) fp-bitwise= ;
  58
  59 M: sequence (eql?) 2dup [ length ] bi@ = [ [ eql? ] 2all? ] [ 2drop f ] if ;
  60
  61 M: object (eql?) = ;
  62
  63 M: eql-wrapper equal?
  64     over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
  65
  66 TUPLE: eq-wrapper { obj read-only } ;
  67
  68 C: <eq-wrapper> eq-wrapper
  69
  70 M: eq-wrapper equal?
  71     over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
  72
  73 M: eq-wrapper hashcode*
  74     nip obj>> identity-hashcode ;
  75
  76 SYMBOL: objects
  77
  78 : cache-eql-object ( obj quot -- value )
  79     [ <eql-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
  80
  81 : cache-eq-object ( obj quot -- value )
  82     [ <eq-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
  83
  84 : lookup-object ( obj -- n/f ) <eq-wrapper> objects get at ;
  85
  86 : put-object ( n obj -- ) <eq-wrapper> objects get set-at ;
  87
  88 ! Constants
  89
  90 CONSTANT: image-magic HEX: 0f0e0d0c
  91 CONSTANT: image-version 4
  92
  93 CONSTANT: data-base 1024
  94
  95 CONSTANT: special-objects-size 80
  96
  97 CONSTANT: header-size 10
  98
  99 CONSTANT: data-heap-size-offset 3
 100 CONSTANT: t-offset              6
 101 CONSTANT: 0-offset              7
 102 CONSTANT: 1-offset              8
 103 CONSTANT: -1-offset             9
 104
 105 SYMBOL: sub-primitives
 106
 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
 112
 113 : make-jit ( quot -- parameters literals code )
 114     #! code is a { relocation insns } pair
 115     [
 116         0 extra-offset set
 117         init-relocation
 118         call( -- )
 119         parameter-table get >array
 120         literal-table get >array
 121         relocation-table get >byte-array
 122     ] B{ } make 2array ;
 123
 124 : make-jit-no-params ( quot -- code )
 125     make-jit 2nip ;
 126
 127 : jit-define ( quot name -- )
 128     [ make-jit-no-params ] dip set ;
 129
 130 : define-sub-primitive ( quot word -- )
 131     [ make-jit 3array ] dip sub-primitives get set-at ;
 132
 133 : define-combinator-primitive ( quot non-tail-quot tail-quot word -- )
 134     [
 135         [
 136             [ make-jit ]
 137             [ make-jit-no-params ]
 138             [ make-jit-no-params ]
 139             tri*
 140         ] output>array
 141     ] dip
 142     sub-primitives get set-at ;
 143
 144 ! The image being constructed; a vector of word-size integers
 145 SYMBOL: image
 146
 147 ! Image output format
 148 SYMBOL: big-endian
 149
 150 ! Bootstrap architecture name
 151 SYMBOL: architecture
 152
 153 RESET
 154
 155 ! Boot quotation, set in stage1.factor
 156 SPECIAL-OBJECT: bootstrap-startup-quot 20
 157
 158 ! Bootstrap global namesapce
 159 SPECIAL-OBJECT: bootstrap-global 21
 160
 161 ! JIT parameters
 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
 181
 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
 187 SPECIAL-OBJECT: signal-handler-word 47
 188 SPECIAL-OBJECT: leaf-signal-handler-word 48
 189
 190 SPECIAL-OBJECT: callback-stub 50
 191
 192 ! PIC stubs
 193 SPECIAL-OBJECT: pic-load 51
 194 SPECIAL-OBJECT: pic-tag 52
 195 SPECIAL-OBJECT: pic-tuple 53
 196 SPECIAL-OBJECT: pic-check-tag 54
 197 SPECIAL-OBJECT: pic-check-tuple 55
 198 SPECIAL-OBJECT: pic-hit 56
 199 SPECIAL-OBJECT: pic-miss-word 57
 200 SPECIAL-OBJECT: pic-miss-tail-word 58
 201
 202 ! Megamorphic dispatch
 203 SPECIAL-OBJECT: mega-lookup 59
 204 SPECIAL-OBJECT: mega-lookup-word 60
 205 SPECIAL-OBJECT: mega-miss-word 61
 206
 207 ! Default definition for undefined words
 208 SPECIAL-OBJECT: undefined-quot 62
 209
 210 : special-object-offset ( symbol -- n )
 211     special-objects get at header-size + ;
 212
 213 : emit ( cell -- ) image get push ;
 214
 215 : emit-64 ( cell -- )
 216     bootstrap-cell 8 = [
 217         emit
 218     ] [
 219         d>w/w big-endian get [ swap ] unless emit emit
 220     ] if ;
 221
 222 : emit-seq ( seq -- ) image get push-all ;
 223
 224 : fixup ( value offset -- ) image get set-nth ;
 225
 226 : heap-size ( -- size )
 227     image get length header-size - special-objects-size -
 228     bootstrap-cells ;
 229
 230 : here ( -- size ) heap-size data-base + ;
 231
 232 : here-as ( tag -- pointer ) here bitor ;
 233
 234 : (align-here) ( alignment -- )
 235     [ here neg ] dip rem
 236     [ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
 237
 238 : align-here ( -- )
 239     data-alignment get (align-here) ;
 240
 241 : emit-fixnum ( n -- ) tag-fixnum emit ;
 242
 243 : emit-header ( n -- ) tag-header emit ;
 244
 245 : emit-object ( class quot -- addr )
 246     [ type-number ] dip over here-as
 247     [ swap emit-header call align-here ] dip ;
 248     inline
 249
 250 ! Write an object to the image.
 251 GENERIC: ' ( obj -- ptr )
 252
 253 ! Image header
 254
 255 : emit-image-header ( -- )
 256     image-magic emit
 257     image-version emit
 258     data-base emit ! relocation base at end of header
 259     0 emit ! size of data heap set later
 260     0 emit ! reloc base of code heap is 0
 261     0 emit ! size of code heap is 0
 262     0 emit ! pointer to t object
 263     0 emit ! pointer to bignum 0
 264     0 emit ! pointer to bignum 1
 265     0 emit ! pointer to bignum -1
 266     special-objects-size [ f ' emit ] times ;
 267
 268 : emit-special-object ( symbol -- )
 269     [ get ' ] [ special-object-offset ] bi fixup ;
 270
 271 ! Bignums
 272
 273 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
 274
 275 : bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
 276
 277 : bignum>seq ( n -- seq )
 278     #! n is positive or zero.
 279     [ dup 0 > ]
 280     [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
 281     produce nip ;
 282
 283 : emit-bignum ( n -- )
 284     dup dup 0 < [ neg ] when bignum>seq
 285     [ nip length 1 + emit-fixnum ]
 286     [ drop 0 < 1 0 ? emit ]
 287     [ nip emit-seq ]
 288     2tri ;
 289
 290 M: bignum '
 291     [
 292         bignum [ emit-bignum ] emit-object
 293     ] cache-eql-object ;
 294
 295 ! Fixnums
 296
 297 M: fixnum '
 298     #! When generating a 32-bit image on a 64-bit system,
 299     #! some fixnums should be bignums.
 300     dup
 301     bootstrap-most-negative-fixnum
 302     bootstrap-most-positive-fixnum between?
 303     [ tag-fixnum ] [ >bignum ' ] if ;
 304
 305 TUPLE: fake-bignum n ;
 306
 307 C: <fake-bignum> fake-bignum
 308
 309 M: fake-bignum ' n>> tag-fixnum ;
 310
 311 ! Floats
 312
 313 M: float '
 314     [
 315         float [
 316             8 (align-here) double>bits emit-64
 317         ] emit-object
 318     ] cache-eql-object ;
 319
 320 ! Special objects
 321
 322 ! Padded with fixnums for 8-byte alignment
 323
 324 : t, ( -- ) t t-offset fixup ;
 325
 326 M: f ' drop \ f type-number ;
 327
 328 :  0, ( -- )  0 >bignum '  0-offset fixup ;
 329 :  1, ( -- )  1 >bignum '  1-offset fixup ;
 330 : -1, ( -- ) -1 >bignum ' -1-offset fixup ;
 331
 332 ! Words
 333
 334 : word-sub-primitive ( word -- obj )
 335     [ target-word ] with-global sub-primitives get at ;
 336
 337 : emit-word ( word -- )
 338     [
 339         [ subwords [ emit-word ] each ]
 340         [
 341             [
 342                 {
 343                     [ hashcode <fake-bignum> , ]
 344                     [ name>> , ]
 345                     [ vocabulary>> , ]
 346                     [ def>> , ]
 347                     [ props>> , ]
 348                     [ pic-def>> , ]
 349                     [ pic-tail-def>> , ]
 350                     [ drop 0 , ] ! count
 351                     [ word-sub-primitive , ]
 352                     [ drop 0 , ] ! xt
 353                     [ drop 0 , ] ! code
 354                     [ drop 0 , ] ! profiling
 355                 } cleave
 356             ] { } make [ ' ] map
 357         ] bi
 358         \ word [ emit-seq ] emit-object
 359     ] keep put-object ;
 360
 361 : word-error ( word msg -- * )
 362     [ % dup vocabulary>> % " " % name>> % ] "" make throw ;
 363
 364 : transfer-word ( word -- word )
 365     [ target-word ] keep or ;
 366
 367 : fixup-word ( word -- offset )
 368     transfer-word dup lookup-object
 369     [ ] [ "Not in image: " word-error ] ?if ;
 370
 371 : fixup-words ( -- )
 372     image get [ dup word? [ fixup-word ] when ] map! drop ;
 373
 374 M: word ' ;
 375
 376 ! Wrappers
 377
 378 M: wrapper '
 379     [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
 380
 381 ! Strings
 382 : native> ( object -- object )
 383     big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
 384
 385 : emit-bytes ( seq -- )
 386     bootstrap-cell <groups> native> emit-seq ;
 387
 388 : pad-bytes ( seq -- newseq )
 389     dup length bootstrap-cell align 0 pad-tail ;
 390
 391 : extended-part ( str -- str' )
 392     dup [ 128 < ] all? [ drop f ] [
 393         [ -7 shift 1 bitxor ] { } map-as
 394         big-endian get
 395         [ [ 2 >be ] { } map-as ]
 396         [ [ 2 >le ] { } map-as ] if
 397         B{ } join
 398     ] if ;
 399
 400 : ascii-part ( str -- str' )
 401     [
 402         [ 128 mod ] [ 128 >= ] bi
 403         [ 128 bitor ] when
 404     ] B{ } map-as ;
 405
 406 : emit-string ( string -- ptr )
 407     [ length ] [ extended-part ' ] [ ] tri
 408     string [
 409         [ emit-fixnum ]
 410         [ emit ]
 411         [ f ' emit ascii-part pad-bytes emit-bytes ]
 412         tri*
 413     ] emit-object ;
 414
 415 M: string '
 416     #! We pool strings so that each string is only written once
 417     #! to the image
 418     [ emit-string ] cache-eql-object ;
 419
 420 : assert-empty ( seq -- )
 421     length 0 assert= ;
 422
 423 : emit-dummy-array ( obj type -- ptr )
 424     [ assert-empty ] [
 425         [ 0 emit-fixnum ] emit-object
 426     ] bi* ;
 427
 428 M: byte-array '
 429     [
 430         byte-array [
 431             dup length emit-fixnum
 432             bootstrap-cell 4 = [ 0 emit 0 emit ] when
 433             pad-bytes emit-bytes
 434         ] emit-object
 435     ] cache-eq-object ;
 436
 437 ! Tuples
 438 ERROR: tuple-removed class ;
 439
 440 : require-tuple-layout ( word -- layout )
 441     dup tuple-layout [ ] [ tuple-removed ] ?if ;
 442
 443 : (emit-tuple) ( tuple -- pointer )
 444     [ tuple-slots ]
 445     [ class-of transfer-word require-tuple-layout ] bi prefix [ ' ] map
 446     tuple [ emit-seq ] emit-object ;
 447
 448 : emit-tuple ( tuple -- pointer )
 449     dup class-of name>> "tombstone" =
 450     [ [ (emit-tuple) ] cache-eql-object ]
 451     [ [ (emit-tuple) ] cache-eq-object ]
 452     if ;
 453
 454 M: tuple ' emit-tuple ;
 455
 456 M: tombstone '
 457     state>> "((tombstone))" "((empty))" ?
 458     "hashtables.private" lookup def>> first
 459     [ emit-tuple ] cache-eql-object ;
 460
 461 ! Arrays
 462 : emit-array ( array -- offset )
 463     [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
 464
 465 M: array ' [ emit-array ] cache-eq-object ;
 466
 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
 471     dup length 5 >= [
 472         [ first tuple-class? ]
 473         [ second fixnum? ]
 474         [ third fixnum? ]
 475         tri and and
 476     ] [ drop f ] if ;
 477
 478 M: tuple-layout-array '
 479     [
 480         [ dup integer? [ <fake-bignum> ] when ] map
 481         emit-array
 482     ] cache-eql-object ;
 483
 484 ! Quotations
 485
 486 M: quotation '
 487     [
 488         array>> '
 489         quotation [
 490             emit ! array
 491             f ' emit ! cached-effect
 492             f ' emit ! cache-counter
 493             0 emit ! xt
 494             0 emit ! code
 495         ] emit-object
 496     ] cache-eql-object ;
 497
 498 ! End of the image
 499
 500 : emit-words ( -- )
 501     all-words [ emit-word ] each ;
 502
 503 : emit-global ( -- )
 504     {
 505         dictionary source-files builtins
 506         update-map implementors-map
 507     } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
 508     {
 509         class<=-cache class-not-cache classes-intersect-cache
 510         class-and-cache class-or-cache next-method-quot-cache
 511     } [ H{ } clone ] H{ } map>assoc assoc-union
 512     bootstrap-global set ;
 513
 514 : emit-jit-data ( -- )
 515     \ if jit-if-word set
 516     \ do-primitive jit-primitive-word set
 517     \ dip jit-dip-word set
 518     \ 2dip jit-2dip-word set
 519     \ 3dip jit-3dip-word set
 520     \ inline-cache-miss pic-miss-word set
 521     \ inline-cache-miss-tail pic-miss-tail-word set
 522     \ mega-cache-lookup mega-lookup-word set
 523     \ mega-cache-miss mega-miss-word set
 524     \ declare jit-declare-word set
 525     \ c-to-factor c-to-factor-word set
 526     \ lazy-jit-compile lazy-jit-compile-word set
 527     \ unwind-native-frames unwind-native-frames-word set
 528     \ fpu-state fpu-state-word set
 529     \ set-fpu-state set-fpu-state-word set
 530     \ signal-handler signal-handler-word set
 531     \ leaf-signal-handler leaf-signal-handler-word set
 532     undefined-def undefined-quot set ;
 533
 534 : emit-special-objects ( -- )
 535     special-objects get keys [ emit-special-object ] each ;
 536
 537 : fixup-header ( -- )
 538     heap-size data-heap-size-offset fixup ;
 539
 540 : build-generics ( -- )
 541     [
 542         all-words
 543         [ generic? ] filter
 544         [ make-generic ] each
 545     ] with-compilation-unit ;
 546
 547 : build-image ( -- image )
 548     800000 <vector> image set
 549     20000 <hashtable> objects set
 550     emit-image-header t, 0, 1, -1,
 551     "Building generic words..." print flush
 552     build-generics
 553     "Serializing words..." print flush
 554     emit-words
 555     "Serializing JIT data..." print flush
 556     emit-jit-data
 557     "Serializing global namespace..." print flush
 558     emit-global
 559     "Serializing special object table..." print flush
 560     emit-special-objects
 561     "Performing word fixups..." print flush
 562     fixup-words
 563     "Performing header fixups..." print flush
 564     fixup-header
 565     "Image length: " write image get length .
 566     "Object cache size: " write objects get assoc-size .
 567     \ word global delete-at
 568     image get ;
 569
 570 ! Image output
 571
 572 : (write-image) ( image -- )
 573     bootstrap-cell big-endian get
 574     [ '[ _ >be write ] each ]
 575     [ '[ _ >le write ] each ] if ;
 576
 577 : write-image ( image -- )
 578     "Writing image to " write
 579     architecture get boot-image-name resource-path
 580     [ write "..." print flush ]
 581     [ binary [ (write-image) ] with-file-writer ] bi ;
 582
 583 PRIVATE>
 584
 585 : make-image ( arch -- )
 586     [
 587         parser-quiet? off
 588         auto-use? off
 589         architecture set
 590         "resource:/core/bootstrap/stage1.factor" run-file
 591         build-image
 592         write-image
 593     ] with-scope ;
 594
 595 : make-images ( -- )
 596     images [ make-image ] each ;