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