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