basis/bootstrap/image/image.factor

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