basis/bootstrap/image/image.factor

   1 ! Copyright (C) 2004, 2011 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs byte-arrays classes classes.builtin
   4 classes.private classes.tuple classes.tuple.private combinators
   5 combinators.short-circuit combinators.smart
   6 compiler.codegen.relocation compiler.units fry generic
   7 generic.single.private grouping hashtables hashtables.private io
   8 io.binary io.encodings.binary io.files io.pathnames kernel
   9 kernel.private layouts locals make math math.order namespaces
  10 namespaces.private parser parser.notes prettyprint quotations
  11 sequences sequences.private source-files strings system vectors
  12 vocabs words ;
  13 IN: bootstrap.image
  14
  15 : arch-name ( os cpu -- arch )
  16     2dup [ windows? ] [ ppc? ] bi* or [
  17       [ drop unix ] dip
  18     ] unless
  19     [ name>> ] bi@ "-" glue ;
  20
  21 : my-arch-name ( -- arch )
  22     os cpu arch-name ;
  23
  24 : boot-image-name ( arch -- string )
  25     "boot." ".image" surround ;
  26
  27 : my-boot-image-name ( -- string )
  28     my-arch-name boot-image-name ;
  29
  30 CONSTANT: image-names
  31     {
  32         "windows-x86.32" "unix-x86.32"
  33         "windows-x86.64" "unix-x86.64"
  34     }
  35
  36 <PRIVATE
  37
  38 ! Object cache; we only consider numbers equal if they have the
  39 ! same type
  40 TUPLE: eql-wrapper { obj read-only } ;
  41
  42 C: <eql-wrapper> eql-wrapper
  43
  44 M: eql-wrapper hashcode* obj>> hashcode* ;
  45
  46 GENERIC: (eql?) ( obj1 obj2 -- ? )
  47
  48 : eql? ( obj1 obj2 -- ? )
  49     { [ [ class-of ] same? ] [ (eql?) ] } 2&& ;
  50
  51 M: fixnum (eql?) eq? ;
  52
  53 M: bignum (eql?) { bignum bignum } declare = ;
  54
  55 M: float (eql?) fp-bitwise= ;
  56
  57 M: sequence (eql?)
  58     2dup [ length ] same? [ [ eql? ] 2all? ] [ 2drop f ] if ;
  59
  60 M: object (eql?) = ;
  61
  62 M: eql-wrapper equal?
  63     over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
  64
  65 TUPLE: eq-wrapper { obj read-only } ;
  66
  67 C: <eq-wrapper> eq-wrapper
  68
  69 M: eq-wrapper equal?
  70     over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
  71
  72 M: eq-wrapper hashcode*
  73     nip obj>> identity-hashcode ;
  74
  75 SYMBOL: objects
  76
  77 : cache-eql-object ( obj quot -- value )
  78     [ <eql-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
  79
  80 : cache-eq-object ( obj quot -- value )
  81     [ <eq-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
  82
  83 : lookup-object ( obj -- n/f )
  84     <eq-wrapper> objects get at ;
  85
  86 : put-object ( n obj -- )
  87     <eq-wrapper> objects get set-at ;
  88
  89 ! Constants
  90
  91 CONSTANT: image-magic 0x0f0e0d0c
  92 CONSTANT: image-version 4
  93
  94 CONSTANT: data-base 1024
  95
  96 CONSTANT: header-size 10
  97
  98 CONSTANT: data-heap-size-offset 3
  99 CONSTANT: t-offset              6
 100 CONSTANT: 0-offset              7
 101 CONSTANT: 1-offset              8
 102 CONSTANT: -1-offset             9
 103
 104 SYMBOL: sub-primitives
 105
 106 SYMBOL: special-objects
 107
 108 :: jit-conditional ( test-quot false-quot -- )
 109     [ 0 test-quot call ] B{ } make length :> len
 110     building get length extra-offset get + len +
 111     [ extra-offset set false-quot call ] B{ } make
 112     [ length test-quot call ] [ % ] bi ; inline
 113
 114 : make-jit ( quot -- parameters literals code )
 115     ! code is a { relocation insns } pair
 116     [
 117         0 extra-offset set
 118         init-relocation
 119         call( -- )
 120         parameter-table get >array
 121         literal-table get >array
 122         relocation-table get >byte-array
 123     ] B{ } make 2array ;
 124
 125 : make-jit-no-params ( quot -- code )
 126     make-jit 2nip ;
 127
 128 : jit-define ( quot n -- )
 129     [ make-jit-no-params ] dip special-objects get set-at ;
 130
 131 : define-sub-primitive ( quot word -- )
 132     [ make-jit 3array ] dip sub-primitives get set-at ;
 133
 134 : define-combinator-primitive ( quot non-tail-quot tail-quot word -- )
 135     [
 136         [
 137             [ make-jit ]
 138             [ make-jit-no-params ]
 139             [ make-jit-no-params ]
 140             tri*
 141         ] output>array
 142     ] dip
 143     sub-primitives get set-at ;
 144
 145 SYMBOL: bootstrapping-image
 146
 147 ! Image output format
 148 SYMBOL: big-endian
 149
 150 SYMBOL: architecture
 151
 152 H{ } clone special-objects set-global
 153
 154 : emit ( cell -- ) bootstrapping-image get push ;
 155
 156 : emit-64 ( cell -- )
 157     bootstrap-cell 8 = [
 158         emit
 159     ] [
 160         d>w/w big-endian get [ swap ] unless emit emit
 161     ] if ;
 162
 163 : emit-seq ( seq -- ) bootstrapping-image get push-all ;
 164
 165 : fixup ( value offset -- ) bootstrapping-image get set-nth ;
 166
 167 : heap-size ( -- size )
 168     bootstrapping-image get length header-size - special-object-count -
 169     bootstrap-cells ;
 170
 171 : here ( -- size ) heap-size data-base + ;
 172
 173 : here-as ( tag -- pointer ) here bitor ;
 174
 175 : (align-here) ( alignment -- )
 176     [ here neg ] dip rem
 177     [ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
 178
 179 : align-here ( -- )
 180     data-alignment get (align-here) ;
 181
 182 : emit-fixnum ( n -- ) tag-fixnum emit ;
 183
 184 : emit-header ( n -- ) tag-header emit ;
 185
 186 : emit-object ( class quot -- addr )
 187     [ type-number ] dip over here-as
 188     [ swap emit-header call align-here ] dip ; inline
 189
 190 ! Read any object for emitting.
 191 GENERIC: prepare-object ( obj -- ptr )
 192
 193 ! Image header
 194
 195 : emit-image-header ( -- )
 196     image-magic emit
 197     image-version emit
 198     data-base emit ! relocation base at end of header
 199     0 emit ! size of data heap set later
 200     0 emit ! reloc base of code heap is 0
 201     0 emit ! size of code heap is 0
 202     0 emit ! pointer to t object
 203     0 emit ! pointer to bignum 0
 204     0 emit ! pointer to bignum 1
 205     0 emit ! pointer to bignum -1
 206     special-object-count [ f prepare-object emit ] times ;
 207
 208 ! Bignums
 209
 210 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
 211
 212 : bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
 213
 214 : bignum>sequence ( 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>sequence
 222     [ nip length 1 + emit-fixnum ]
 223     [ drop 0 < 1 0 ? emit ]
 224     [ nip emit-seq ]
 225     2tri ;
 226
 227 M: bignum prepare-object
 228     [
 229         bignum [ emit-bignum ] emit-object
 230     ] cache-eql-object ;
 231
 232 ! Fixnums
 233
 234 M: fixnum prepare-object
 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 prepare-object ] if ;
 241
 242 TUPLE: fake-bignum n ;
 243
 244 C: <fake-bignum> fake-bignum
 245
 246 M: fake-bignum prepare-object n>> tag-fixnum ;
 247
 248 ! Floats
 249
 250 M: float prepare-object
 251     [
 252         float [
 253             8 (align-here) double>bits emit-64
 254         ] emit-object
 255     ] cache-eql-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 prepare-object drop \ f type-number ;
 264
 265 :  0, ( -- )  0 >bignum prepare-object  0-offset fixup ;
 266 :  1, ( -- )  1 >bignum prepare-object  1-offset fixup ;
 267 : -1, ( -- ) -1 >bignum prepare-object -1-offset fixup ;
 268
 269 ! Words
 270
 271 : word-sub-primitive ( word -- obj )
 272     [ target-word ] with-global sub-primitives get at ;
 273
 274 : emit-word ( word -- )
 275     [
 276         [ subwords [ emit-word ] each ]
 277         [
 278             [
 279                 {
 280                     [ hashcode <fake-bignum> ]
 281                     [ name>> ]
 282                     [ vocabulary>> ]
 283                     [ def>> ]
 284                     [ props>> ]
 285                     [ pic-def>> ]
 286                     [ pic-tail-def>> ]
 287                     [ word-sub-primitive ]
 288                     [ drop 0 ] ! entry point
 289                 } cleave
 290             ] output>array [ prepare-object ] map!
 291         ] bi
 292         \ word [ emit-seq ] emit-object
 293     ] keep put-object ;
 294
 295 ERROR: not-in-image vocabulary word ;
 296
 297 : transfer-word ( word -- word )
 298     [ target-word ] keep or ;
 299
 300 : fixup-word ( word -- offset )
 301     transfer-word dup lookup-object
 302     [ ] [ [ vocabulary>> ] [ name>> ] bi not-in-image ] ?if ;
 303
 304 : fixup-words ( -- )
 305     bootstrapping-image get [ dup word? [ fixup-word ] when ] map! drop ;
 306
 307 M: word prepare-object ;
 308
 309 ! Wrappers
 310
 311 M: wrapper prepare-object
 312     [ wrapped>> prepare-object wrapper [ emit ] emit-object ] cache-eql-object ;
 313
 314 ! Strings
 315 : native> ( object -- object )
 316     big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
 317
 318 : emit-bytes ( seq -- )
 319     bootstrap-cell <groups> native> emit-seq ;
 320
 321 : pad-bytes ( seq -- newseq )
 322     dup length bootstrap-cell align 0 pad-tail ;
 323
 324 : extended-part ( str -- str' )
 325     dup [ 128 < ] all? [ drop f ] [
 326         [ -7 shift 1 bitxor ] { } map-as
 327         big-endian get
 328         [ [ 2 >be ] { } map-as ]
 329         [ [ 2 >le ] { } map-as ] if
 330         B{ } join
 331     ] if ;
 332
 333 : ascii-part ( str -- str' )
 334     [
 335         [ 128 mod ] [ 128 >= ] bi
 336         [ 128 bitor ] when
 337     ] B{ } map-as ;
 338
 339 : emit-string ( string -- ptr )
 340     [ length ] [ extended-part prepare-object ] [ ] tri
 341     string [
 342         [ emit-fixnum ]
 343         [ emit ]
 344         [ f prepare-object emit ascii-part pad-bytes emit-bytes ]
 345         tri*
 346     ] emit-object ;
 347
 348 M: string prepare-object
 349     ! We pool strings so that each string is only written once
 350     ! to the image
 351     [ emit-string ] cache-eql-object ;
 352
 353 : assert-empty ( seq -- )
 354     length 0 assert= ;
 355
 356 : emit-dummy-array ( obj type -- ptr )
 357     [ assert-empty ] [
 358         [ 0 emit-fixnum ] emit-object
 359     ] bi* ;
 360
 361 M: byte-array prepare-object
 362     [
 363         byte-array [
 364             dup length emit-fixnum
 365             bootstrap-cell 4 = [ 0 emit 0 emit ] when
 366             pad-bytes emit-bytes
 367         ] emit-object
 368     ] cache-eq-object ;
 369
 370 ! Tuples
 371 ERROR: tuple-removed class ;
 372
 373 : require-tuple-layout ( word -- layout )
 374     dup tuple-layout [ ] [ tuple-removed ] ?if ;
 375
 376 : (emit-tuple) ( tuple -- pointer )
 377     [ tuple-slots ]
 378     [ class-of transfer-word require-tuple-layout ] bi prefix [ prepare-object ] map
 379     tuple [ emit-seq ] emit-object ;
 380
 381 : emit-tuple ( tuple -- pointer )
 382     dup class-of name>> "tombstone" =
 383     [ [ (emit-tuple) ] cache-eql-object ]
 384     [ [ (emit-tuple) ] cache-eq-object ]
 385     if ;
 386
 387 M: tuple prepare-object emit-tuple ;
 388
 389 M: tombstone prepare-object
 390     state>> "((tombstone))" "((empty))" ?
 391     "hashtables.private" lookup-word def>> first
 392     [ emit-tuple ] cache-eql-object ;
 393
 394 ! Arrays
 395 : emit-array ( array -- offset )
 396     [ prepare-object ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
 397
 398 M: array prepare-object [ emit-array ] cache-eq-object ;
 399
 400 ! This is a hack. We need to detect arrays which are tuple
 401 ! layout arrays so that they can be internalized, but making
 402 ! them a built-in type is not worth it.
 403 PREDICATE: tuple-layout-array < array
 404     dup length 5 >= [
 405         {
 406             [ first-unsafe tuple-class? ]
 407             [ second-unsafe fixnum? ]
 408             [ third-unsafe fixnum? ]
 409         } 1&&
 410     ] [ drop f ] if ;
 411
 412 M: tuple-layout-array prepare-object
 413     [
 414         [ dup integer? [ <fake-bignum> ] when ] map
 415         emit-array
 416     ] cache-eql-object ;
 417
 418 ! Quotations
 419
 420 M: quotation prepare-object
 421     [
 422         array>> prepare-object
 423         quotation [
 424             emit ! array
 425             f prepare-object emit ! cached-effect
 426             f prepare-object emit ! cache-counter
 427             0 emit ! entry point
 428         ] emit-object
 429     ] cache-eql-object ;
 430
 431 ! End of the image
 432
 433 : emit-words ( -- )
 434     all-words [ emit-word ] each ;
 435
 436 : emit-global ( -- )
 437     {
 438         dictionary source-files builtins
 439         update-map implementors-map
 440     } [ [ bootstrap-word ] [ get global-box boa ] bi ] H{ } map>assoc
 441     {
 442         class<=-cache class-not-cache classes-intersect-cache
 443         class-and-cache class-or-cache next-method-quot-cache
 444     } [ H{ } clone global-box boa ] H{ } map>assoc assoc-union
 445     global-hashtable boa
 446     OBJ-GLOBAL special-objects get set-at ;
 447
 448 : emit-jit-data ( -- )
 449     {
 450         { JIT-IF-WORD if }
 451         { JIT-PRIMITIVE-WORD do-primitive }
 452         { JIT-DIP-WORD dip }
 453         { JIT-2DIP-WORD 2dip }
 454         { JIT-3DIP-WORD 3dip }
 455         { PIC-MISS-WORD inline-cache-miss }
 456         { PIC-MISS-TAIL-WORD inline-cache-miss-tail }
 457         { MEGA-LOOKUP-WORD mega-cache-lookup }
 458         { MEGA-MISS-WORD mega-cache-miss }
 459         { JIT-DECLARE-WORD declare }
 460         { C-TO-FACTOR-WORD c-to-factor }
 461         { LAZY-JIT-COMPILE-WORD lazy-jit-compile }
 462         { UNWIND-NATIVE-FRAMES-WORD unwind-native-frames }
 463         { GET-FPU-STATE-WORD fpu-state }
 464         { SET-FPU-STATE-WORD set-fpu-state }
 465         { SIGNAL-HANDLER-WORD signal-handler }
 466         { LEAF-SIGNAL-HANDLER-WORD leaf-signal-handler }
 467     }
 468     \ OBJ-UNDEFINED undefined-def 2array suffix [
 469         swap execute( -- x ) special-objects get set-at
 470     ] assoc-each ;
 471
 472 : emit-special-object ( obj idx -- )
 473     [ prepare-object ] [ header-size + ] bi* fixup ;
 474
 475 : emit-special-objects ( -- )
 476     special-objects get [ swap emit-special-object ] assoc-each ;
 477
 478 : fixup-header ( -- )
 479     heap-size data-heap-size-offset fixup ;
 480
 481 : build-generics ( -- )
 482     [
 483         all-words
 484         [ generic? ] filter
 485         [ make-generic ] each
 486     ] with-compilation-unit ;
 487
 488 : build-image ( -- image )
 489     600,000 <vector> bootstrapping-image set
 490     60,000 <hashtable> objects set
 491     emit-image-header t, 0, 1, -1,
 492     "Building generic words..." print flush
 493     build-generics
 494     "Serializing words..." print flush
 495     emit-words
 496     "Serializing JIT data..." print flush
 497     emit-jit-data
 498     "Serializing global namespace..." print flush
 499     emit-global
 500     "Serializing special object table..." print flush
 501     emit-special-objects
 502     "Performing word fixups..." print flush
 503     fixup-words
 504     "Performing header fixups..." print flush
 505     fixup-header
 506     "Image length: " write bootstrapping-image get length .
 507     "Object cache size: " write objects get assoc-size .
 508     \ last-word global delete-at
 509     bootstrapping-image get ;
 510
 511 ! Image output
 512
 513 : (write-image) ( image -- )
 514     bootstrap-cell output-stream get
 515     big-endian get
 516     [ '[ _ >be _ stream-write ] each ]
 517     [ '[ _ >le _ stream-write ] each ] if ;
 518
 519 : write-image ( image -- )
 520     "Writing image to " write
 521     architecture get boot-image-name resource-path
 522     [ write "..." print flush ]
 523     [ binary [ (write-image) ] with-file-writer ] bi ;
 524
 525 PRIVATE>
 526
 527 : make-image ( arch -- )
 528     architecture associate H{
 529         { parser-quiet? f }
 530         { auto-use? f }
 531     } assoc-union! [
 532         "resource:/core/bootstrap/stage1.factor" run-file
 533         build-image
 534         write-image
 535     ] with-variables ;
 536
 537 : make-images ( -- )
 538     image-names [ make-image ] each ;
 539
 540 : make-my-image ( -- )
 541     my-arch-name make-image ;