basis/bootstrap/image/image.factor

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