basis/bootstrap/image/image.factor

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