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