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