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