basis/bootstrap/image/image.factor

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