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 need to be synced with
  90 !   vm/image.hpp
  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
 100 SYMBOL: sub-primitives
 101
 102 SYMBOL: special-objects
 103
 104 :: jit-conditional ( test-quot false-quot -- )
 105     [ 0 test-quot call ] B{ } make length :> len
 106     building get length extra-offset get + len +
 107     [ extra-offset set false-quot call ] B{ } make
 108     [ length test-quot call ] [ % ] bi ; inline
 109
 110 : make-jit ( quot -- parameters literals code )
 111     [
 112         0 extra-offset set
 113         init-relocation
 114         call( -- )
 115         parameter-table get >array
 116         literal-table get >array
 117         relocation-table get >byte-array
 118     ] B{ } make 2array ;
 119
 120 : make-jit-no-params ( quot -- code )
 121     make-jit 2nip ;
 122
 123 : jit-define ( quot n -- )
 124     [ make-jit-no-params ] dip special-objects get set-at ;
 125
 126 : define-sub-primitive ( quot word -- )
 127     [ make-jit 3array ] dip sub-primitives get set-at ;
 128
 129 : define-sub-primitives ( assoc -- )
 130     [ swap define-sub-primitive ] assoc-each ;
 131
 132 : define-combinator-primitive ( quot non-tail-quot tail-quot word -- )
 133     [
 134         [
 135             [ make-jit ]
 136             [ make-jit-no-params ]
 137             [ make-jit-no-params ]
 138             tri*
 139         ] output>array
 140     ] dip
 141     sub-primitives get set-at ;
 142
 143 SYMBOL: bootstrapping-image
 144
 145 ! Image output format
 146 SYMBOL: big-endian
 147
 148 SYMBOL: architecture
 149
 150 : emit ( cell -- ) bootstrapping-image get push ;
 151
 152 : emit-64 ( cell -- )
 153     bootstrap-cell 8 = [
 154         emit
 155     ] [
 156         d>w/w big-endian get [ swap ] unless emit emit
 157     ] if ;
 158
 159 : emit-seq ( seq -- ) bootstrapping-image get push-all ;
 160
 161 : fixup ( value offset -- ) bootstrapping-image get set-nth ;
 162
 163 : heap-size ( -- size )
 164     bootstrapping-image get length header-size - special-object-count -
 165     bootstrap-cells ;
 166
 167 : here ( -- size ) heap-size data-base + ;
 168
 169 : here-as ( tag -- pointer ) here bitor ;
 170
 171 : (align-here) ( alignment -- )
 172     [ here neg ] dip rem
 173     [ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
 174
 175 : align-here ( -- )
 176     data-alignment get (align-here) ;
 177
 178 : emit-fixnum ( n -- ) tag-fixnum emit ;
 179
 180 : emit-header ( n -- ) tag-header emit ;
 181
 182 : emit-object ( class quot -- addr )
 183     [ type-number ] dip over here-as
 184     [ swap emit-header call align-here ] dip ; inline
 185
 186 ! Read any object for emitting.
 187 GENERIC: prepare-object ( obj -- ptr )
 188
 189 ! Image header
 190
 191 : emit-image-header ( -- )
 192     image-magic emit
 193     image-version emit
 194     data-base emit ! relocation base at end of header
 195     0 emit ! size of data heap set later
 196     0 emit ! reloc base of code heap is 0
 197     0 emit ! size of code heap is 0
 198     0 emit ! reserved
 199     0 emit ! reserved
 200     0 emit ! reserved
 201     0 emit ! reserved
 202     special-object-count [ f prepare-object emit ] times ;
 203
 204 ! Bignums
 205
 206 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
 207
 208 : bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
 209
 210 : bignum>sequence ( n -- seq )
 211     ! n is positive or zero.
 212     [ dup 0 > ]
 213     [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
 214     produce nip ;
 215
 216 : emit-bignum ( n -- )
 217     dup dup 0 < [ neg ] when bignum>sequence
 218     [ nip length 1 + emit-fixnum ]
 219     [ drop 0 < 1 0 ? emit ]
 220     [ nip emit-seq ]
 221     2tri ;
 222
 223 M: bignum prepare-object
 224     [
 225         bignum [ emit-bignum ] emit-object
 226     ] cache-eql-object ;
 227
 228 ! Fixnums
 229
 230 M: fixnum prepare-object
 231     ! When generating a 32-bit image on a 64-bit system,
 232     ! some fixnums should be bignums.
 233     dup
 234     bootstrap-most-negative-fixnum
 235     bootstrap-most-positive-fixnum between?
 236     [ tag-fixnum ] [ >bignum prepare-object ] if ;
 237
 238 TUPLE: fake-bignum n ;
 239
 240 C: <fake-bignum> fake-bignum
 241
 242 M: fake-bignum prepare-object n>> tag-fixnum ;
 243
 244 ! Floats
 245
 246 M: float prepare-object
 247     [
 248         float [
 249             8 (align-here) double>bits emit-64
 250         ] emit-object
 251     ] cache-eql-object ;
 252
 253 ! Special objects
 254
 255 ! Padded with fixnums for 8-byte alignment
 256 M: f prepare-object drop \ f type-number ;
 257
 258 ! Words
 259
 260 : word-sub-primitive ( word -- obj )
 261     [ target-word ] with-global sub-primitives get at ;
 262
 263 : emit-word ( word -- )
 264     [
 265         [ subwords [ emit-word ] each ]
 266         [
 267             [
 268                 {
 269                     [ hashcode <fake-bignum> ]
 270                     [ name>> ]
 271                     [ vocabulary>> ]
 272                     [ def>> ]
 273                     [ props>> ]
 274                     [ pic-def>> ]
 275                     [ pic-tail-def>> ]
 276                     [ word-sub-primitive ]
 277                     [ drop 0 ] ! entry point
 278                 } cleave
 279             ] output>array [ prepare-object ] map!
 280         ] bi
 281         \ word [ emit-seq ] emit-object
 282     ] keep put-object ;
 283
 284 ERROR: not-in-image vocabulary word ;
 285
 286 : transfer-word ( word -- word )
 287     [ target-word ] keep or ;
 288
 289 : fixup-word ( word -- offset )
 290     transfer-word dup lookup-object
 291     [ ] [ [ vocabulary>> ] [ name>> ] bi not-in-image ] ?if ;
 292
 293 : fixup-words ( -- )
 294     bootstrapping-image get [ dup word? [ fixup-word ] when ] map! drop ;
 295
 296 M: word prepare-object ;
 297
 298 ! Wrappers
 299
 300 M: wrapper prepare-object
 301     [ wrapped>> prepare-object wrapper [ emit ] emit-object ] cache-eql-object ;
 302
 303 ! Strings
 304 : native> ( object -- object )
 305     big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
 306
 307 : emit-bytes ( seq -- )
 308     bootstrap-cell <groups> native> emit-seq ;
 309
 310 : pad-bytes ( seq -- newseq )
 311     dup length bootstrap-cell align 0 pad-tail ;
 312
 313 : extended-part ( str -- str' )
 314     dup [ 128 < ] all? [ drop f ] [
 315         [ -7 shift 1 bitxor ] { } map-as
 316         big-endian get
 317         [ [ 2 >be ] { } map-as ]
 318         [ [ 2 >le ] { } map-as ] if
 319         B{ } join
 320     ] if ;
 321
 322 : ascii-part ( str -- str' )
 323     [
 324         [ 128 mod ] [ 128 >= ] bi
 325         [ 128 bitor ] when
 326     ] B{ } map-as ;
 327
 328 : emit-string ( string -- ptr )
 329     [ length ] [ extended-part prepare-object ] [ ] tri
 330     string [
 331         [ emit-fixnum ]
 332         [ emit ]
 333         [ f prepare-object emit ascii-part pad-bytes emit-bytes ]
 334         tri*
 335     ] emit-object ;
 336
 337 M: string prepare-object
 338     ! We pool strings so that each string is only written once
 339     ! to the image
 340     [ emit-string ] cache-eql-object ;
 341
 342 : assert-empty ( seq -- )
 343     length 0 assert= ;
 344
 345 : emit-dummy-array ( obj type -- ptr )
 346     [ assert-empty ] [
 347         [ 0 emit-fixnum ] emit-object
 348     ] bi* ;
 349
 350 M: byte-array prepare-object
 351     [
 352         byte-array [
 353             dup length emit-fixnum
 354             bootstrap-cell 4 = [ 0 emit 0 emit ] when
 355             pad-bytes emit-bytes
 356         ] emit-object
 357     ] cache-eq-object ;
 358
 359 ! Tuples
 360 ERROR: tuple-removed class ;
 361
 362 : require-tuple-layout ( word -- layout )
 363     dup tuple-layout [ ] [ tuple-removed ] ?if ;
 364
 365 : (emit-tuple) ( tuple -- pointer )
 366     [ tuple-slots ]
 367     [ class-of transfer-word require-tuple-layout ] bi prefix [ prepare-object ] map
 368     tuple [ emit-seq ] emit-object ;
 369
 370 : emit-tuple ( tuple -- pointer )
 371     dup class-of name>> "tombstone" =
 372     [ [ (emit-tuple) ] cache-eql-object ]
 373     [ [ (emit-tuple) ] cache-eq-object ]
 374     if ;
 375
 376 M: tuple prepare-object emit-tuple ;
 377
 378 M: tombstone prepare-object
 379     state>> "+tombstone+" "+empty+" ?
 380     "hashtables.private" lookup-word def>> first
 381     [ emit-tuple ] cache-eql-object ;
 382
 383 ! Arrays
 384 : emit-array ( array -- offset )
 385     [ prepare-object ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
 386
 387 M: array prepare-object [ emit-array ] cache-eq-object ;
 388
 389 ! This is a hack. We need to detect arrays which are tuple
 390 ! layout arrays so that they can be internalized, but making
 391 ! them a built-in type is not worth it.
 392 PREDICATE: tuple-layout-array < array
 393     dup length 5 >= [
 394         {
 395             [ first-unsafe tuple-class? ]
 396             [ second-unsafe fixnum? ]
 397             [ third-unsafe fixnum? ]
 398         } 1&&
 399     ] [ drop f ] if ;
 400
 401 M: tuple-layout-array prepare-object
 402     [
 403         [ dup integer? [ <fake-bignum> ] when ] map
 404         emit-array
 405     ] cache-eql-object ;
 406
 407 ! Quotations
 408
 409 M: quotation prepare-object
 410     [
 411         array>> prepare-object
 412         quotation [
 413             emit ! array
 414             f prepare-object emit ! cached-effect
 415             f prepare-object emit ! cache-counter
 416             0 emit ! entry point
 417         ] emit-object
 418     ] cache-eql-object ;
 419
 420 ! End of the image
 421
 422 : emit-words ( -- )
 423     all-words [ emit-word ] each ;
 424
 425 : emit-singletons ( -- )
 426     t OBJ-CANONICAL-TRUE special-objects get set-at
 427     0 >bignum OBJ-BIGNUM-ZERO special-objects get set-at
 428     1 >bignum OBJ-BIGNUM-POS-ONE special-objects get set-at
 429     -1 >bignum OBJ-BIGNUM-NEG-ONE special-objects get set-at ;
 430
 431 : create-global-hashtable ( -- global-hashtable )
 432     {
 433         dictionary source-files builtins
 434         update-map implementors-map
 435     } [ [ bootstrap-word ] [ get global-box boa ] bi ] H{ } map>assoc
 436     {
 437         class<=-cache class-not-cache classes-intersect-cache
 438         class-and-cache class-or-cache next-method-quot-cache
 439     } [ H{ } clone global-box boa ] H{ } map>assoc assoc-union
 440     global-hashtable boa ;
 441
 442 : emit-global ( -- )
 443     create-global-hashtable
 444     OBJ-GLOBAL special-objects get set-at ;
 445
 446 : emit-jit-data ( -- )
 447     {
 448         { JIT-IF-WORD if }
 449         { JIT-PRIMITIVE-WORD do-primitive }
 450         { JIT-DIP-WORD dip }
 451         { JIT-2DIP-WORD 2dip }
 452         { JIT-3DIP-WORD 3dip }
 453         { PIC-MISS-WORD inline-cache-miss }
 454         { PIC-MISS-TAIL-WORD inline-cache-miss-tail }
 455         { MEGA-LOOKUP-WORD mega-cache-lookup }
 456         { MEGA-MISS-WORD mega-cache-miss }
 457         { JIT-DECLARE-WORD declare }
 458         { C-TO-FACTOR-WORD c-to-factor }
 459         { LAZY-JIT-COMPILE-WORD lazy-jit-compile }
 460         { UNWIND-NATIVE-FRAMES-WORD unwind-native-frames }
 461         { GET-FPU-STATE-WORD fpu-state }
 462         { SET-FPU-STATE-WORD set-fpu-state }
 463         { SIGNAL-HANDLER-WORD signal-handler }
 464         { LEAF-SIGNAL-HANDLER-WORD leaf-signal-handler }
 465     }
 466     \ OBJ-UNDEFINED undefined-def 2array suffix [
 467         swap execute( -- x ) special-objects get set-at
 468     ] assoc-each ;
 469
 470 : emit-special-object ( obj idx -- )
 471     [ prepare-object ] [ header-size + ] bi* fixup ;
 472
 473 : emit-special-objects ( -- )
 474     special-objects get [ swap emit-special-object ] assoc-each ;
 475
 476 : fixup-header ( -- )
 477     heap-size data-heap-size-offset fixup ;
 478
 479 : build-generics ( -- )
 480     [
 481         all-words
 482         [ generic? ] filter
 483         [ make-generic ] each
 484     ] with-compilation-unit ;
 485
 486 : build-image ( -- image )
 487     600,000 <vector> bootstrapping-image set
 488     60,000 <hashtable> objects set
 489     emit-image-header
 490     "Building generic words..." print flush
 491     build-generics
 492     "Serializing words..." print flush
 493     emit-words
 494     "Serializing JIT data..." print flush
 495     emit-jit-data
 496     "Serializing global namespace..." print flush
 497     emit-global
 498     "Serializing singletons..." print flush
 499     emit-singletons
 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         H{ } clone special-objects set
 533         "resource:/core/bootstrap/stage1.factor" run-file
 534         build-image
 535         write-image
 536     ] with-variables ;
 537
 538 : make-images ( -- )
 539     image-names [ make-image ] each ;
 540
 541 : make-my-image ( -- )
 542     my-arch-name make-image ;