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