core/bootstrap/primitives.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien arrays byte-arrays generic hashtables
   4 hashtables.private io kernel math namespaces parser sequences
   5 strings vectors words quotations assocs layouts classes
   6 classes.builtin classes.tuple classes.tuple.private
   7 kernel.private vocabs vocabs.loader source-files definitions
   8 slots classes.union classes.intersection
   9 compiler.units bootstrap.image.private io.files accessors
  10 combinators ;
  11 IN: bootstrap.primitives
  12
  13 "Creating primitives and basic runtime structures..." print flush
  14
  15 crossref off
  16
  17 "resource:core/bootstrap/syntax.factor" parse-file
  18
  19 "resource:core/cpu/" architecture get {
  20     { "x86.32" "x86/32" }
  21     { "x86.64" "x86/64" }
  22     { "linux-ppc" "ppc/linux" }
  23     { "macosx-ppc" "ppc/macosx" }
  24     { "arm" "arm" }
  25 } at "/bootstrap.factor" 3append parse-file
  26
  27 "resource:core/bootstrap/layouts/layouts.factor" parse-file
  28
  29 ! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack
  30
  31 ! Bring up a bare cross-compiling vocabulary.
  32 "syntax" vocab vocab-words bootstrap-syntax set
  33 H{ } clone dictionary set
  34 H{ } clone new-classes set
  35 H{ } clone changed-definitions set
  36 H{ } clone forgotten-definitions set
  37 H{ } clone root-cache set
  38 H{ } clone source-files set
  39 H{ } clone update-map set
  40 H{ } clone implementors-map set
  41 init-caches
  42
  43 ! Vocabulary for slot accessors
  44 "accessors" create-vocab drop
  45
  46 ! Trivial recompile hook. We don't want to touch the code heap
  47 ! during stage1 bootstrap, it would just waste time.
  48 [ drop { } ] recompile-hook set
  49
  50 call
  51 call
  52 call
  53
  54 ! After we execute bootstrap/layouts
  55 num-types get f <array> builtins set
  56
  57 bootstrapping? on
  58
  59 ! Create some empty vocabs where the below primitives and
  60 ! classes will go
  61 {
  62     "alien"
  63     "alien.accessors"
  64     "arrays"
  65     "bit-arrays"
  66     "byte-arrays"
  67     "byte-vectors"
  68     "classes.private"
  69     "classes.tuple"
  70     "classes.tuple.private"
  71     "compiler.units"
  72     "continuations.private"
  73     "float-arrays"
  74     "generator"
  75     "growable"
  76     "hashtables"
  77     "hashtables.private"
  78     "io"
  79     "io.files"
  80     "io.files.private"
  81     "io.streams.c"
  82     "kernel"
  83     "kernel.private"
  84     "math"
  85     "math.private"
  86     "memory"
  87     "quotations"
  88     "quotations.private"
  89     "sbufs"
  90     "sbufs.private"
  91     "scratchpad"
  92     "sequences"
  93     "sequences.private"
  94     "slots.private"
  95     "strings"
  96     "strings.private"
  97     "system"
  98     "system.private"
  99     "threads.private"
 100     "tools.profiler.private"
 101     "words"
 102     "words.private"
 103     "vectors"
 104     "vectors.private"
 105 } [ create-vocab drop ] each
 106
 107 ! Builtin classes
 108 : lo-tag-eq-quot ( n -- quot )
 109     [ \ tag , , \ eq? , ] [ ] make ;
 110
 111 : hi-tag-eq-quot ( n -- quot )
 112     [
 113         [ dup tag ] % \ hi-tag tag-number , \ eq? ,
 114         [ [ hi-tag ] % , \ eq? , ] [ ] make ,
 115         [ drop f ] ,
 116         \ if ,
 117     ] [ ] make ;
 118
 119 : builtin-predicate-quot ( class -- quot )
 120     "type" word-prop
 121     dup tag-mask get <
 122     [ lo-tag-eq-quot ] [ hi-tag-eq-quot ] if ;
 123
 124 : define-builtin-predicate ( class -- )
 125     dup builtin-predicate-quot define-predicate ;
 126
 127 : lookup-type-number ( word -- n )
 128     global [ target-word ] bind type-number ;
 129
 130 : register-builtin ( class -- )
 131     [ dup lookup-type-number "type" set-word-prop ]
 132     [ dup "type" word-prop builtins get set-nth ]
 133     [ f f f builtin-class define-class ]
 134     tri ;
 135
 136 : prepare-slots ( slots -- slots' )
 137     [ [ dup array? [ first2 create ] when ] map ] map ;
 138
 139 : define-builtin-slots ( class slots -- )
 140     prepare-slots 1 make-slots
 141     [ "slots" set-word-prop ] [ define-accessors ] 2bi ;
 142
 143 : define-builtin ( symbol slotspec -- )
 144     >r [ define-builtin-predicate ] keep
 145     r> define-builtin-slots ;
 146
 147 "fixnum" "math" create register-builtin
 148 "bignum" "math" create register-builtin
 149 "tuple" "kernel" create register-builtin
 150 "ratio" "math" create register-builtin
 151 "float" "math" create register-builtin
 152 "complex" "math" create register-builtin
 153 "f" "syntax" lookup register-builtin
 154 "array" "arrays" create register-builtin
 155 "wrapper" "kernel" create register-builtin
 156 "float-array" "float-arrays" create register-builtin
 157 "callstack" "kernel" create register-builtin
 158 "string" "strings" create register-builtin
 159 "bit-array" "bit-arrays" create register-builtin
 160 "quotation" "quotations" create register-builtin
 161 "dll" "alien" create register-builtin
 162 "alien" "alien" create register-builtin
 163 "word" "words" create register-builtin
 164 "byte-array" "byte-arrays" create register-builtin
 165 "tuple-layout" "classes.tuple.private" create register-builtin
 166
 167 ! Catch-all class for providing a default method.
 168 "object" "kernel" create
 169 [ f f { } intersection-class define-class ]
 170 [ [ drop t ] "predicate" set-word-prop ]
 171 bi
 172
 173 "object?" "kernel" vocab-words delete-at
 174
 175 ! Class of objects with object tag
 176 "hi-tag" "kernel.private" create
 177 builtins get num-tags get tail define-union-class
 178
 179 ! Empty class with no instances
 180 "null" "kernel" create
 181 [ f { } f union-class define-class ]
 182 [ [ drop f ] "predicate" set-word-prop ]
 183 bi
 184
 185 "null?" "kernel" vocab-words delete-at
 186
 187 "fixnum" "math" create { } define-builtin
 188 "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
 189
 190 "bignum" "math" create { } define-builtin
 191 "bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
 192
 193 "ratio" "math" create {
 194     {
 195         "numerator"
 196         { "integer" "math" }
 197         read-only: t
 198     }
 199     {
 200         "denominator"
 201         { "integer" "math" }
 202         read-only: t
 203     }
 204 } define-builtin
 205
 206 "float" "math" create { } define-builtin
 207 "float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
 208
 209 "complex" "math" create {
 210     {
 211         "real"
 212         { "real" "math" }
 213         read-only: t
 214     }
 215     {
 216         "imaginary"
 217         { "real" "math" }
 218         read-only: t
 219     }
 220 } define-builtin
 221
 222 "f" "syntax" lookup { } define-builtin
 223
 224 "array" "arrays" create { } define-builtin
 225
 226 "wrapper" "kernel" create {
 227     {
 228         "wrapped"
 229         { "object" "kernel" }
 230         read-only: t
 231     }
 232 } define-builtin
 233
 234 "string" "strings" create {
 235     {
 236         "length"
 237         { "array-capacity" "sequences.private" }
 238         read-only: t
 239     } {
 240         "aux"
 241         { "object" "kernel" }
 242     }
 243 } define-builtin
 244
 245 "quotation" "quotations" create {
 246     {
 247         "array"
 248         { "object" "kernel" }
 249         read-only: t
 250     }
 251     {
 252         "compiled"
 253         { "object" "kernel" }
 254         read-only: t
 255     }
 256 } define-builtin
 257
 258 "dll" "alien" create {
 259     {
 260        "path"
 261          { "byte-array" "byte-arrays" }
 262         read-only: t
 263     }
 264 }
 265 define-builtin
 266
 267 "alien" "alien" create {
 268     {
 269         "underlying"
 270         { "c-ptr" "alien" }
 271         read-only: t
 272     } {
 273         "expired?"
 274         { "object" "kernel" }
 275         read-only: t
 276     }
 277 }
 278 define-builtin
 279
 280 "word" "words" create {
 281     {
 282         "hashcode"
 283         { "fixnum" "math" }
 284     }
 285     {
 286         "name"
 287         { "object" "kernel" }
 288     }
 289     {
 290         "vocabulary"
 291         { "object" "kernel" }
 292     }
 293     {
 294         "def"
 295         { "quotation" "quotations" }
 296     }
 297     {
 298         "props"
 299         { "object" "kernel" }
 300     }
 301     {
 302         "compiled"
 303         { "object" "kernel" }
 304         read-only: t
 305     }
 306     {
 307         "counter"
 308         { "fixnum" "math" }
 309     }
 310 } define-builtin
 311
 312 "byte-array" "byte-arrays" create { } define-builtin
 313
 314 "bit-array" "bit-arrays" create { } define-builtin
 315
 316 "float-array" "float-arrays" create { } define-builtin
 317
 318 "callstack" "kernel" create { } define-builtin
 319
 320 "tuple-layout" "classes.tuple.private" create {
 321     {
 322         "hashcode"
 323         { "fixnum" "math" }
 324         read-only: t
 325     }
 326     {
 327         "class"
 328         { "word" "words" }
 329         read-only: t
 330     }
 331     {
 332         "size"
 333         { "fixnum" "math" }
 334         read-only: t
 335     }
 336     {
 337         "superclasses"
 338         { "array" "arrays" }
 339         read-only: t
 340     }
 341     {
 342         "echelon"
 343         { "fixnum" "math" }
 344         read-only: t
 345     }
 346 } define-builtin
 347
 348 "tuple" "kernel" create {
 349     [ { } define-builtin ]
 350     [ { "delegate" } "slot-names" set-word-prop ]
 351     [ define-tuple-layout ]
 352     [
 353         {
 354             {
 355                 "delegate"
 356                 { "object" "kernel" }
 357             }
 358         } prepare-slots
 359         [ drop ] [ generate-tuple-slots ] 2bi
 360         [ "slots" set-word-prop ]
 361         [ define-accessors ]
 362         2bi
 363     ]
 364 } cleave
 365
 366 "f" "syntax" create [ not ] "predicate" set-word-prop
 367 "f?" "syntax" vocab-words delete-at
 368
 369 ! Create special tombstone values
 370 "tombstone" "hashtables.private" create
 371 tuple
 372 { } define-tuple-class
 373
 374 "((empty))" "hashtables.private" create
 375 "tombstone" "hashtables.private" lookup f
 376 2array >tuple 1quotation define-inline
 377
 378 "((tombstone))" "hashtables.private" create
 379 "tombstone" "hashtables.private" lookup t
 380 2array >tuple 1quotation define-inline
 381
 382 ! Some tuple classes
 383 "curry" "kernel" create
 384 tuple
 385 {
 386     {
 387         "obj"
 388         { "object" "kernel" }
 389         read-only: t
 390     } {
 391         "quot"
 392         { "object" "kernel" }
 393         read-only: t
 394     }
 395 } prepare-slots define-tuple-class
 396
 397 "curry" "kernel" lookup
 398 [ f "inline" set-word-prop ]
 399 [ ]
 400 [ tuple-layout [ <tuple-boa> ] curry ] tri
 401 (( obj quot -- curry )) define-declared
 402
 403 "compose" "kernel" create
 404 tuple
 405 {
 406     {
 407         "first"
 408         { "object" "kernel" }
 409         read-only: t
 410     } {
 411         "second"
 412         { "object" "kernel" }
 413         read-only: t
 414     }
 415 } prepare-slots define-tuple-class
 416
 417 "compose" "kernel" lookup
 418 [ f "inline" set-word-prop ]
 419 [ ]
 420 [ tuple-layout [ <tuple-boa> ] curry ] tri
 421 (( quot1 quot2 -- compose )) define-declared
 422
 423 ! Primitive words
 424 : make-primitive ( word vocab n -- )
 425     >r create dup reset-word r>
 426     [ do-primitive ] curry [ ] like define ;
 427
 428 {
 429     { "(execute)" "words.private" }
 430     { "(call)" "kernel.private" }
 431     { "bignum>fixnum" "math.private" }
 432     { "float>fixnum" "math.private" }
 433     { "fixnum>bignum" "math.private" }
 434     { "float>bignum" "math.private" }
 435     { "fixnum>float" "math.private" }
 436     { "bignum>float" "math.private" }
 437     { "<ratio>" "math.private" }
 438     { "string>float" "math.private" }
 439     { "float>string" "math.private" }
 440     { "float>bits" "math" }
 441     { "double>bits" "math" }
 442     { "bits>float" "math" }
 443     { "bits>double" "math" }
 444     { "<complex>" "math.private" }
 445     { "fixnum+" "math.private" }
 446     { "fixnum+fast" "math.private" }
 447     { "fixnum-" "math.private" }
 448     { "fixnum-fast" "math.private" }
 449     { "fixnum*" "math.private" }
 450     { "fixnum*fast" "math.private" }
 451     { "fixnum/i" "math.private" }
 452     { "fixnum-mod" "math.private" }
 453     { "fixnum/mod" "math.private" }
 454     { "fixnum-bitand" "math.private" }
 455     { "fixnum-bitor" "math.private" }
 456     { "fixnum-bitxor" "math.private" }
 457     { "fixnum-bitnot" "math.private" }
 458     { "fixnum-shift" "math.private" }
 459     { "fixnum-shift-fast" "math.private" }
 460     { "fixnum<" "math.private" }
 461     { "fixnum<=" "math.private" }
 462     { "fixnum>" "math.private" }
 463     { "fixnum>=" "math.private" }
 464     { "bignum=" "math.private" }
 465     { "bignum+" "math.private" }
 466     { "bignum-" "math.private" }
 467     { "bignum*" "math.private" }
 468     { "bignum/i" "math.private" }
 469     { "bignum-mod" "math.private" }
 470     { "bignum/mod" "math.private" }
 471     { "bignum-bitand" "math.private" }
 472     { "bignum-bitor" "math.private" }
 473     { "bignum-bitxor" "math.private" }
 474     { "bignum-bitnot" "math.private" }
 475     { "bignum-shift" "math.private" }
 476     { "bignum<" "math.private" }
 477     { "bignum<=" "math.private" }
 478     { "bignum>" "math.private" }
 479     { "bignum>=" "math.private" }
 480     { "bignum-bit?" "math.private" }
 481     { "bignum-log2" "math.private" }
 482     { "byte-array>bignum" "math" }
 483     { "float=" "math.private" }
 484     { "float+" "math.private" }
 485     { "float-" "math.private" }
 486     { "float*" "math.private" }
 487     { "float/f" "math.private" }
 488     { "float-mod" "math.private" }
 489     { "float<" "math.private" }
 490     { "float<=" "math.private" }
 491     { "float>" "math.private" }
 492     { "float>=" "math.private" }
 493     { "<word>" "words" }
 494     { "word-xt" "words" }
 495     { "drop" "kernel" }
 496     { "2drop" "kernel" }
 497     { "3drop" "kernel" }
 498     { "dup" "kernel" }
 499     { "2dup" "kernel" }
 500     { "3dup" "kernel" }
 501     { "rot" "kernel" }
 502     { "-rot" "kernel" }
 503     { "dupd" "kernel" }
 504     { "swapd" "kernel" }
 505     { "nip" "kernel" }
 506     { "2nip" "kernel" }
 507     { "tuck" "kernel" }
 508     { "over" "kernel" }
 509     { "pick" "kernel" }
 510     { "swap" "kernel" }
 511     { ">r" "kernel" }
 512     { "r>" "kernel" }
 513     { "eq?" "kernel" }
 514     { "getenv" "kernel.private" }
 515     { "setenv" "kernel.private" }
 516     { "(exists?)" "io.files.private" }
 517     { "(directory)" "io.files.private" }
 518     { "gc" "memory" }
 519     { "gc-stats" "memory" }
 520     { "save-image" "memory" }
 521     { "save-image-and-exit" "memory" }
 522     { "datastack" "kernel" }
 523     { "retainstack" "kernel" }
 524     { "callstack" "kernel" }
 525     { "set-datastack" "kernel" }
 526     { "set-retainstack" "kernel" }
 527     { "set-callstack" "kernel" }
 528     { "exit" "system" }
 529     { "data-room" "memory" }
 530     { "code-room" "memory" }
 531     { "os-env" "system" }
 532     { "millis" "system" }
 533     { "tag" "kernel.private" }
 534     { "modify-code-heap" "compiler.units" }
 535     { "dlopen" "alien" }
 536     { "dlsym" "alien" }
 537     { "dlclose" "alien" }
 538     { "<byte-array>" "byte-arrays" }
 539     { "<bit-array>" "bit-arrays" }
 540     { "<displaced-alien>" "alien" }
 541     { "alien-signed-cell" "alien.accessors" }
 542     { "set-alien-signed-cell" "alien.accessors" }
 543     { "alien-unsigned-cell" "alien.accessors" }
 544     { "set-alien-unsigned-cell" "alien.accessors" }
 545     { "alien-signed-8" "alien.accessors" }
 546     { "set-alien-signed-8" "alien.accessors" }
 547     { "alien-unsigned-8" "alien.accessors" }
 548     { "set-alien-unsigned-8" "alien.accessors" }
 549     { "alien-signed-4" "alien.accessors" }
 550     { "set-alien-signed-4" "alien.accessors" }
 551     { "alien-unsigned-4" "alien.accessors" }
 552     { "set-alien-unsigned-4" "alien.accessors" }
 553     { "alien-signed-2" "alien.accessors" }
 554     { "set-alien-signed-2" "alien.accessors" }
 555     { "alien-unsigned-2" "alien.accessors" }
 556     { "set-alien-unsigned-2" "alien.accessors" }
 557     { "alien-signed-1" "alien.accessors" }
 558     { "set-alien-signed-1" "alien.accessors" }
 559     { "alien-unsigned-1" "alien.accessors" }
 560     { "set-alien-unsigned-1" "alien.accessors" }
 561     { "alien-float" "alien.accessors" }
 562     { "set-alien-float" "alien.accessors" }
 563     { "alien-double" "alien.accessors" }
 564     { "set-alien-double" "alien.accessors" }
 565     { "alien-cell" "alien.accessors" }
 566     { "set-alien-cell" "alien.accessors" }
 567     { "(throw)" "kernel.private" }
 568     { "alien-address" "alien" }
 569     { "slot" "slots.private" }
 570     { "set-slot" "slots.private" }
 571     { "string-nth" "strings.private" }
 572     { "set-string-nth" "strings.private" }
 573     { "resize-array" "arrays" }
 574     { "resize-string" "strings" }
 575     { "<array>" "arrays" }
 576     { "begin-scan" "memory" }
 577     { "next-object" "memory" }
 578     { "end-scan" "memory" }
 579     { "size" "memory" }
 580     { "die" "kernel" }
 581     { "fopen" "io.streams.c" }
 582     { "fgetc" "io.streams.c" }
 583     { "fread" "io.streams.c" }
 584     { "fputc" "io.streams.c" }
 585     { "fwrite" "io.streams.c" }
 586     { "fflush" "io.streams.c" }
 587     { "fclose" "io.streams.c" }
 588     { "<wrapper>" "kernel" }
 589     { "(clone)" "kernel" }
 590     { "<string>" "strings" }
 591     { "array>quotation" "quotations.private" }
 592     { "quotation-xt" "quotations" }
 593     { "<tuple>" "classes.tuple.private" }
 594     { "<tuple-layout>" "classes.tuple.private" }
 595     { "profiling" "tools.profiler.private" }
 596     { "become" "kernel.private" }
 597     { "(sleep)" "threads.private" }
 598     { "<float-array>" "float-arrays" }
 599     { "<tuple-boa>" "classes.tuple.private" }
 600     { "callstack>array" "kernel" }
 601     { "innermost-frame-quot" "kernel.private" }
 602     { "innermost-frame-scan" "kernel.private" }
 603     { "set-innermost-frame-quot" "kernel.private" }
 604     { "call-clear" "kernel" }
 605     { "(os-envs)" "system.private" }
 606     { "set-os-env" "system" }
 607     { "unset-os-env" "system" }
 608     { "(set-os-envs)" "system.private" }
 609     { "resize-byte-array" "byte-arrays" }
 610     { "resize-bit-array" "bit-arrays" }
 611     { "resize-float-array" "float-arrays" }
 612     { "dll-valid?" "alien" }
 613     { "unimplemented" "kernel.private" }
 614     { "gc-reset" "memory" }
 615 }
 616 dup length [ >r first2 r> make-primitive ] 2each
 617
 618 ! Bump build number
 619 "build" "kernel" create build 1+ 1quotation define