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