basis/bootstrap/image/image.factor

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