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 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 fry ;
  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>> @ ] cache ; inline
  77
  78 ! Constants
  79
  80 CONSTANT: image-magic HEX: 0f0e0d0c
  81 CONSTANT: image-version 4
  82
  83 CONSTANT: data-base 1024
  84
  85 CONSTANT: userenv-size 70
  86
  87 CONSTANT: header-size 10
  88
  89 CONSTANT: data-heap-size-offset 3
  90 CONSTANT: t-offset              6
  91 CONSTANT: 0-offset              7
  92 CONSTANT: 1-offset              8
  93 CONSTANT: -1-offset             9
  94
  95 SYMBOL: sub-primitives
  96
  97 : make-jit ( quot rc rt offset -- quad )
  98     [ { } make ] 3dip 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 : native> ( object -- object )
 348     big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
 349
 350 : emit-bytes ( seq -- )
 351     bootstrap-cell <groups> native> emit-seq ;
 352
 353 : pad-bytes ( seq -- newseq )
 354     dup length bootstrap-cell align 0 pad-tail ;
 355
 356 : extended-part ( str -- str' )
 357     dup [ 128 < ] all? [ drop f ] [
 358         [ -7 shift 1 bitxor ] { } map-as
 359         big-endian get
 360         [ [ 2 >be ] { } map-as ]
 361         [ [ 2 >le ] { } map-as ] if
 362         B{ } join
 363     ] if ;
 364
 365 : ascii-part ( str -- str' )
 366     [
 367         [ 128 mod ] [ 128 >= ] bi
 368         [ 128 bitor ] when
 369     ] B{ } map-as ;
 370
 371 : emit-string ( string -- ptr )
 372     [ length ] [ extended-part ' ] [ ] tri
 373     string type-number object tag-number [
 374         [ emit-fixnum ]
 375         [ emit ]
 376         [ f ' emit ascii-part pad-bytes emit-bytes ]
 377         tri*
 378     ] emit-object ;
 379
 380 M: string '
 381     #! We pool strings so that each string is only written once
 382     #! to the image
 383     [ emit-string ] cache-object ;
 384
 385 : assert-empty ( seq -- )
 386     length 0 assert= ;
 387
 388 : emit-dummy-array ( obj type -- ptr )
 389     [ assert-empty ] [
 390         type-number object tag-number
 391         [ 0 emit-fixnum ] emit-object
 392     ] bi* ;
 393
 394 M: byte-array '
 395     byte-array type-number object tag-number [
 396         dup length emit-fixnum
 397         pad-bytes emit-bytes
 398     ] emit-object ;
 399
 400 ! Tuples
 401 : (emit-tuple) ( tuple -- pointer )
 402     [ tuple-slots ]
 403     [ class transfer-word tuple-layout ] bi prefix [ ' ] map
 404     tuple type-number dup [ emit-seq ] emit-object ;
 405
 406 : emit-tuple ( tuple -- pointer )
 407     dup class name>> "tombstone" =
 408     [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
 409
 410 M: tuple ' emit-tuple ;
 411
 412 M: tombstone '
 413     state>> "((tombstone))" "((empty))" ?
 414     "hashtables.private" lookup def>> first
 415     [ emit-tuple ] cache-object ;
 416
 417 ! Arrays
 418 : emit-array ( array -- offset )
 419     [ ' ] map array type-number object tag-number
 420     [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
 421
 422 M: array ' emit-array ;
 423
 424 ! This is a hack. We need to detect arrays which are tuple
 425 ! layout arrays so that they can be internalized, but making
 426 ! them a built-in type is not worth it.
 427 PREDICATE: tuple-layout-array < array
 428     dup length 5 >= [
 429         [ first tuple-class? ]
 430         [ second fixnum? ]
 431         [ third fixnum? ]
 432         tri and and
 433     ] [ drop f ] if ;
 434
 435 M: tuple-layout-array '
 436     [
 437         [ dup integer? [ <fake-bignum> ] when ] map
 438         emit-array
 439     ] cache-object ;
 440
 441 ! Quotations
 442
 443 M: quotation '
 444     [
 445         array>> '
 446         quotation type-number object tag-number [
 447             emit ! array
 448             f ' emit ! compiled
 449             f ' emit ! cached-effect
 450             f ' emit ! cache-counter
 451             0 emit ! xt
 452             0 emit ! code
 453         ] emit-object
 454     ] cache-object ;
 455
 456 ! End of the image
 457
 458 : emit-words ( -- )
 459     all-words [ emit-word ] each ;
 460
 461 : emit-global ( -- )
 462     {
 463         dictionary source-files builtins
 464         update-map implementors-map
 465     } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
 466     {
 467         class<=-cache class-not-cache classes-intersect-cache
 468         class-and-cache class-or-cache next-method-quot-cache
 469     } [ H{ } clone ] H{ } map>assoc assoc-union
 470     bootstrap-global set
 471     bootstrap-global emit-userenv ;
 472
 473 : emit-boot-quot ( -- )
 474     bootstrap-boot-quot emit-userenv ;
 475
 476 : emit-jit-data ( -- )
 477     \ if jit-if-word set
 478     \ dispatch jit-dispatch-word set
 479     \ do-primitive jit-primitive-word set
 480     \ declare jit-declare-word set
 481     \ dip jit-dip-word set
 482     \ 2dip jit-2dip-word set
 483     \ 3dip jit-3dip-word set
 484     [ undefined ] undefined-quot set
 485     {
 486         jit-code-format
 487         jit-prolog
 488         jit-primitive-word
 489         jit-primitive
 490         jit-word-jump
 491         jit-word-call
 492         jit-push-immediate
 493         jit-if-word
 494         jit-if-1
 495         jit-if-2
 496         jit-dispatch-word
 497         jit-dispatch
 498         jit-dip-word
 499         jit-dip
 500         jit-2dip-word
 501         jit-2dip
 502         jit-3dip-word
 503         jit-3dip
 504         jit-epilog
 505         jit-return
 506         jit-profiling
 507         jit-declare-word
 508         jit-save-stack
 509         undefined-quot
 510     } [ emit-userenv ] each ;
 511
 512 : fixup-header ( -- )
 513     heap-size data-heap-size-offset fixup ;
 514
 515 : build-image ( -- image )
 516     800000 <vector> image set
 517     20000 <hashtable> objects set
 518     emit-header t, 0, 1, -1,
 519     "Building generic words..." print flush
 520     remake-generics
 521     "Serializing words..." print flush
 522     emit-words
 523     "Serializing JIT data..." print flush
 524     emit-jit-data
 525     "Serializing global namespace..." print flush
 526     emit-global
 527     "Serializing boot quotation..." print flush
 528     emit-boot-quot
 529     "Performing word fixups..." print flush
 530     fixup-words
 531     "Performing header fixups..." print flush
 532     fixup-header
 533     "Image length: " write image get length .
 534     "Object cache size: " write objects get assoc-size .
 535     \ word global delete-at
 536     image get ;
 537
 538 ! Image output
 539
 540 : (write-image) ( image -- )
 541     bootstrap-cell big-endian get
 542     [ '[ _ >be write ] each ]
 543     [ '[ _ >le write ] each ] if ;
 544
 545 : write-image ( image -- )
 546     "Writing image to " write
 547     architecture get boot-image-name resource-path
 548     [ write "..." print flush ]
 549     [ binary [ (write-image) ] with-file-writer ] bi ;
 550
 551 PRIVATE>
 552
 553 : make-image ( arch -- )
 554     [
 555         architecture set
 556         "resource:/core/bootstrap/stage1.factor" run-file
 557         build-image
 558         write-image
 559     ] with-scope ;
 560
 561 : make-images ( -- )
 562     images [ make-image ] each ;