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