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