basis/bootstrap/image/image.factor

   1 ! Copyright (C) 2004, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien arrays byte-arrays generic hashtables hashtables.private
   4 io io.binary io.files io.encodings.binary io.pathnames kernel
   5 kernel.private math namespaces make parser prettyprint sequences
   6 strings sbufs vectors words quotations assocs system layouts splitting
   7 grouping growable classes classes.builtin classes.tuple
   8 classes.tuple.private vocabs vocabs.loader source-files definitions
   9 debugger quotations.private combinators math.order math.private
  10 accessors slots.private generic.single.private compiler.units
  11 compiler.constants fry bootstrap.image.syntax ;
  12 IN: bootstrap.image
  13
  14 : arch ( os cpu -- arch )
  15     {
  16         { "ppc" [ "-ppc" append ] }
  17         { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
  18         [ nip ]
  19     } case ;
  20
  21 : my-arch ( -- arch )
  22     os name>> cpu name>> arch ;
  23
  24 : boot-image-name ( arch -- string )
  25     "boot." ".image" surround ;
  26
  27 : my-boot-image-name ( -- string )
  28     my-arch boot-image-name ;
  29
  30 : images ( -- seq )
  31     {
  32         "x86.32"
  33         "winnt-x86.64" "unix-x86.64"
  34         "linux-ppc" "macosx-ppc"
  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 ;
  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     [ (eql?) ] [ [ class ] bi@ = ] 2bi and ;
  51
  52 M: integer (eql?) = ;
  53
  54 M: float (eql?)
  55     over float? [ fp-bitwise= ] [ 2drop f ] if ;
  56
  57 M: sequence (eql?)
  58     over sequence? [
  59         2dup [ length ] bi@ =
  60         [ [ eql? ] 2all? ] [ 2drop f ] if
  61     ] [ 2drop f ] if ;
  62
  63 M: object (eql?) = ;
  64
  65 M: eql-wrapper equal?
  66     over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
  67
  68 TUPLE: eq-wrapper obj ;
  69
  70 C: <eq-wrapper> eq-wrapper
  71
  72 M: eq-wrapper equal?
  73     over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
  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 ) <eq-wrapper> objects get at ;
  84
  85 : put-object ( n obj -- ) <eq-wrapper> objects get set-at ;
  86
  87 ! Constants
  88
  89 CONSTANT: image-magic HEX: 0f0e0d0c
  90 CONSTANT: image-version 4
  91
  92 CONSTANT: data-base 1024
  93
  94 CONSTANT: userenv-size 70
  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: jit-relocations
 107
 108 : compute-offset ( rc -- offset )
 109     [ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
 110
 111 : jit-rel ( rc rt -- )
 112     over compute-offset 3array jit-relocations get push-all ;
 113
 114 SYMBOL: jit-literals
 115
 116 : jit-literal ( literal -- )
 117     jit-literals get push ;
 118
 119 : make-jit ( quot -- jit-literals jit-data )
 120     [
 121         V{ } clone jit-literals set
 122         V{ } clone jit-relocations set
 123         call( -- )
 124         jit-literals get >array
 125         jit-relocations get >array
 126     ] B{ } make prefix ;
 127
 128 : jit-define ( quot name -- )
 129     [ make-jit nip ] dip set ;
 130
 131 : define-sub-primitive ( quot word -- )
 132     [ make-jit 2array ] dip sub-primitives get set-at ;
 133
 134 ! The image being constructed; a vector of word-size integers
 135 SYMBOL: image
 136
 137 ! Image output format
 138 SYMBOL: big-endian
 139
 140 ! Bootstrap architecture name
 141 SYMBOL: architecture
 142
 143 RESET
 144
 145 ! Boot quotation, set in stage1.factor
 146 USERENV: bootstrap-boot-quot 20
 147
 148 ! Bootstrap global namesapce
 149 USERENV: bootstrap-global 21
 150
 151 ! JIT parameters
 152 USERENV: jit-prolog 23
 153 USERENV: jit-primitive-word 24
 154 USERENV: jit-primitive 25
 155 USERENV: jit-word-jump 26
 156 USERENV: jit-word-call 27
 157 USERENV: jit-word-special 28
 158 USERENV: jit-if-word 29
 159 USERENV: jit-if 30
 160 USERENV: jit-epilog 31
 161 USERENV: jit-return 32
 162 USERENV: jit-profiling 33
 163 USERENV: jit-push-immediate 34
 164 USERENV: jit-dip-word 35
 165 USERENV: jit-dip 36
 166 USERENV: jit-2dip-word 37
 167 USERENV: jit-2dip 38
 168 USERENV: jit-3dip-word 39
 169 USERENV: jit-3dip 40
 170 USERENV: jit-execute-word 41
 171 USERENV: jit-execute-jump 42
 172 USERENV: jit-execute-call 43
 173 USERENV: jit-declare-word 44
 174
 175 USERENV: callback-stub 45
 176
 177 ! PIC stubs
 178 USERENV: pic-load 47
 179 USERENV: pic-tag 48
 180 USERENV: pic-hi-tag 49
 181 USERENV: pic-tuple 50
 182 USERENV: pic-hi-tag-tuple 51
 183 USERENV: pic-check-tag 52
 184 USERENV: pic-check 53
 185 USERENV: pic-hit 54
 186 USERENV: pic-miss-word 55
 187 USERENV: pic-miss-tail-word 56
 188
 189 ! Megamorphic dispatch
 190 USERENV: mega-lookup 57
 191 USERENV: mega-lookup-word 58
 192 USERENV: mega-miss-word 59
 193
 194 ! Default definition for undefined words
 195 USERENV: undefined-quot 60
 196
 197 : userenv-offset ( symbol -- n )
 198     userenvs get at header-size + ;
 199
 200 : emit ( cell -- ) image get push ;
 201
 202 : emit-64 ( cell -- )
 203     bootstrap-cell 8 = [
 204         emit
 205     ] [
 206         d>w/w big-endian get [ swap ] unless emit emit
 207     ] if ;
 208
 209 : emit-seq ( seq -- ) image get push-all ;
 210
 211 : fixup ( value offset -- ) image get set-nth ;
 212
 213 : heap-size ( -- size )
 214     image get length header-size - userenv-size -
 215     bootstrap-cells ;
 216
 217 : here ( -- size ) heap-size data-base + ;
 218
 219 : here-as ( tag -- pointer ) here bitor ;
 220
 221 : (align-here) ( alignment -- )
 222     [ here neg ] dip rem
 223     [ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
 224
 225 : align-here ( -- )
 226     data-alignment get (align-here) ;
 227
 228 : emit-fixnum ( n -- ) tag-fixnum emit ;
 229
 230 : emit-object ( class quot -- addr )
 231     over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
 232     inline
 233
 234 ! Write an object to the image.
 235 GENERIC: ' ( obj -- ptr )
 236
 237 ! Image header
 238
 239 : emit-header ( -- )
 240     image-magic emit
 241     image-version emit
 242     data-base emit ! relocation base at end of header
 243     0 emit ! size of data heap set later
 244     0 emit ! reloc base of code heap is 0
 245     0 emit ! size of code heap is 0
 246     0 emit ! pointer to t object
 247     0 emit ! pointer to bignum 0
 248     0 emit ! pointer to bignum 1
 249     0 emit ! pointer to bignum -1
 250     userenv-size [ f ' emit ] times ;
 251
 252 : emit-userenv ( symbol -- )
 253     [ get ' ] [ userenv-offset ] bi fixup ;
 254
 255 ! Bignums
 256
 257 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
 258
 259 : bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
 260
 261 : bignum>seq ( n -- seq )
 262     #! n is positive or zero.
 263     [ dup 0 > ]
 264     [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
 265     produce nip ;
 266
 267 : emit-bignum ( n -- )
 268     dup dup 0 < [ neg ] when bignum>seq
 269     [ nip length 1 + emit-fixnum ]
 270     [ drop 0 < 1 0 ? emit ]
 271     [ nip emit-seq ]
 272     2tri ;
 273
 274 M: bignum '
 275     [
 276         bignum [ emit-bignum ] emit-object
 277     ] cache-eql-object ;
 278
 279 ! Fixnums
 280
 281 M: fixnum '
 282     #! When generating a 32-bit image on a 64-bit system,
 283     #! some fixnums should be bignums.
 284     dup
 285     bootstrap-most-negative-fixnum
 286     bootstrap-most-positive-fixnum between?
 287     [ tag-fixnum ] [ >bignum ' ] if ;
 288
 289 TUPLE: fake-bignum n ;
 290
 291 C: <fake-bignum> fake-bignum
 292
 293 M: fake-bignum ' n>> tag-fixnum ;
 294
 295 ! Floats
 296
 297 M: float '
 298     [
 299         float [
 300             8 (align-here) double>bits emit-64
 301         ] emit-object
 302     ] cache-eql-object ;
 303
 304 ! Special objects
 305
 306 ! Padded with fixnums for 8-byte alignment
 307
 308 : t, ( -- ) t t-offset fixup ;
 309
 310 M: f '
 311     #! f is #define F RETAG(0,F_TYPE)
 312     drop \ f tag-number ;
 313
 314 :  0, ( -- )  0 >bignum '  0-offset fixup ;
 315 :  1, ( -- )  1 >bignum '  1-offset fixup ;
 316 : -1, ( -- ) -1 >bignum ' -1-offset fixup ;
 317
 318 ! Words
 319
 320 : word-sub-primitive ( word -- obj )
 321     global [ target-word ] bind sub-primitives get at ;
 322
 323 : emit-word ( word -- )
 324     [
 325         [ subwords [ emit-word ] each ]
 326         [
 327             [
 328                 {
 329                     [ hashcode <fake-bignum> , ]
 330                     [ name>> , ]
 331                     [ vocabulary>> , ]
 332                     [ def>> , ]
 333                     [ props>> , ]
 334                     [ pic-def>> , ]
 335                     [ pic-tail-def>> , ]
 336                     [ drop 0 , ] ! count
 337                     [ word-sub-primitive , ]
 338                     [ drop 0 , ] ! xt
 339                     [ drop 0 , ] ! code
 340                     [ drop 0 , ] ! profiling
 341                 } cleave
 342             ] { } make [ ' ] map
 343         ] bi
 344         \ word [ emit-seq ] emit-object
 345     ] keep put-object ;
 346
 347 : word-error ( word msg -- * )
 348     [ % dup vocabulary>> % " " % name>> % ] "" make throw ;
 349
 350 : transfer-word ( word -- word )
 351     [ target-word ] keep or ;
 352
 353 : fixup-word ( word -- offset )
 354     transfer-word dup lookup-object
 355     [ ] [ "Not in image: " word-error ] ?if ;
 356
 357 : fixup-words ( -- )
 358     image get [ dup word? [ fixup-word ] when ] map! drop ;
 359
 360 M: word ' ;
 361
 362 ! Wrappers
 363
 364 M: wrapper '
 365     [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
 366
 367 ! Strings
 368 : native> ( object -- object )
 369     big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
 370
 371 : emit-bytes ( seq -- )
 372     bootstrap-cell <groups> native> emit-seq ;
 373
 374 : pad-bytes ( seq -- newseq )
 375     dup length bootstrap-cell align 0 pad-tail ;
 376
 377 : extended-part ( str -- str' )
 378     dup [ 128 < ] all? [ drop f ] [
 379         [ -7 shift 1 bitxor ] { } map-as
 380         big-endian get
 381         [ [ 2 >be ] { } map-as ]
 382         [ [ 2 >le ] { } map-as ] if
 383         B{ } join
 384     ] if ;
 385
 386 : ascii-part ( str -- str' )
 387     [
 388         [ 128 mod ] [ 128 >= ] bi
 389         [ 128 bitor ] when
 390     ] B{ } map-as ;
 391
 392 : emit-string ( string -- ptr )
 393     [ length ] [ extended-part ' ] [ ] tri
 394     string [
 395         [ emit-fixnum ]
 396         [ emit ]
 397         [ f ' emit ascii-part pad-bytes emit-bytes ]
 398         tri*
 399     ] emit-object ;
 400
 401 M: string '
 402     #! We pool strings so that each string is only written once
 403     #! to the image
 404     [ emit-string ] cache-eql-object ;
 405
 406 : assert-empty ( seq -- )
 407     length 0 assert= ;
 408
 409 : emit-dummy-array ( obj type -- ptr )
 410     [ assert-empty ] [
 411         [ 0 emit-fixnum ] emit-object
 412     ] bi* ;
 413
 414 M: byte-array '
 415     [
 416         byte-array [
 417             dup length emit-fixnum
 418             bootstrap-cell 4 = [ 0 emit 0 emit ] when
 419             pad-bytes emit-bytes
 420         ] emit-object
 421     ] cache-eq-object ;
 422
 423 ! Tuples
 424 ERROR: tuple-removed class ;
 425
 426 : require-tuple-layout ( word -- layout )
 427     dup tuple-layout [ ] [ tuple-removed ] ?if ;
 428
 429 : (emit-tuple) ( tuple -- pointer )
 430     [ tuple-slots ]
 431     [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
 432     tuple [ emit-seq ] emit-object ;
 433
 434 : emit-tuple ( tuple -- pointer )
 435     dup class name>> "tombstone" =
 436     [ [ (emit-tuple) ] cache-eql-object ]
 437     [ [ (emit-tuple) ] cache-eq-object ]
 438     if ;
 439
 440 M: tuple ' emit-tuple ;
 441
 442 M: tombstone '
 443     state>> "((tombstone))" "((empty))" ?
 444     "hashtables.private" lookup def>> first
 445     [ emit-tuple ] cache-eql-object ;
 446
 447 ! Arrays
 448 : emit-array ( array -- offset )
 449     [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
 450
 451 M: array ' [ emit-array ] cache-eq-object ;
 452
 453 ! This is a hack. We need to detect arrays which are tuple
 454 ! layout arrays so that they can be internalized, but making
 455 ! them a built-in type is not worth it.
 456 PREDICATE: tuple-layout-array < array
 457     dup length 5 >= [
 458         [ first tuple-class? ]
 459         [ second fixnum? ]
 460         [ third fixnum? ]
 461         tri and and
 462     ] [ drop f ] if ;
 463
 464 M: tuple-layout-array '
 465     [
 466         [ dup integer? [ <fake-bignum> ] when ] map
 467         emit-array
 468     ] cache-eql-object ;
 469
 470 ! Quotations
 471
 472 M: quotation '
 473     [
 474         array>> '
 475         quotation [
 476             emit ! array
 477             f ' emit ! cached-effect
 478             f ' emit ! cache-counter
 479             0 emit ! xt
 480             0 emit ! code
 481         ] emit-object
 482     ] cache-eql-object ;
 483
 484 ! End of the image
 485
 486 : emit-words ( -- )
 487     all-words [ emit-word ] each ;
 488
 489 : emit-global ( -- )
 490     {
 491         dictionary source-files builtins
 492         update-map implementors-map
 493     } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
 494     {
 495         class<=-cache class-not-cache classes-intersect-cache
 496         class-and-cache class-or-cache next-method-quot-cache
 497     } [ H{ } clone ] H{ } map>assoc assoc-union
 498     bootstrap-global set ;
 499
 500 : emit-jit-data ( -- )
 501     \ if jit-if-word set
 502     \ do-primitive jit-primitive-word set
 503     \ dip jit-dip-word set
 504     \ 2dip jit-2dip-word set
 505     \ 3dip jit-3dip-word set
 506     \ (execute) jit-execute-word set
 507     \ inline-cache-miss \ pic-miss-word set
 508     \ inline-cache-miss-tail \ pic-miss-tail-word set
 509     \ mega-cache-lookup \ mega-lookup-word set
 510     \ mega-cache-miss \ mega-miss-word set
 511     \ declare jit-declare-word set
 512     [ undefined ] undefined-quot set ;
 513
 514 : emit-userenvs ( -- )
 515     userenvs get keys [ emit-userenv ] each ;
 516
 517 : fixup-header ( -- )
 518     heap-size data-heap-size-offset fixup ;
 519
 520 : build-image ( -- image )
 521     800000 <vector> image set
 522     20000 <hashtable> objects set
 523     emit-header t, 0, 1, -1,
 524     "Building generic words..." print flush
 525     remake-generics
 526     "Serializing words..." print flush
 527     emit-words
 528     "Serializing JIT data..." print flush
 529     emit-jit-data
 530     "Serializing global namespace..." print flush
 531     emit-global
 532     "Serializing user environment..." print flush
 533     emit-userenvs
 534     "Performing word fixups..." print flush
 535     fixup-words
 536     "Performing header fixups..." print flush
 537     fixup-header
 538     "Image length: " write image get length .
 539     "Object cache size: " write objects get assoc-size .
 540     \ word global delete-at
 541     image get ;
 542
 543 ! Image output
 544
 545 : (write-image) ( image -- )
 546     bootstrap-cell big-endian get
 547     [ '[ _ >be write ] each ]
 548     [ '[ _ >le write ] each ] if ;
 549
 550 : write-image ( image -- )
 551     "Writing image to " write
 552     architecture get boot-image-name resource-path
 553     [ write "..." print flush ]
 554     [ binary [ (write-image) ] with-file-writer ] bi ;
 555
 556 PRIVATE>
 557
 558 : make-image ( arch -- )
 559     [
 560         architecture set
 561         "resource:/core/bootstrap/stage1.factor" run-file
 562         build-image
 563         write-image
 564     ] with-scope ;
 565
 566 : make-images ( -- )
 567     images [ make-image ] each ;