Clean up bootstrap code a bit
Slava Pestov
parent
420e7dc57e
commit
2ebb7d2271
|
|
@ -12,7 +12,7 @@ io.encodings.binary ;
|
|||
IN: bootstrap.image
|
||||
|
||||
: my-arch ( -- arch )
|
||||
cpu dup "ppc" = [ os "-" rot 3append ] when ;
|
||||
cpu dup "ppc" = [ >r os "-" r> 3append ] when ;
|
||||
|
||||
: boot-image-name ( arch -- string )
|
||||
"boot." swap ".image" 3append ;
|
||||
|
|
@ -55,7 +55,7 @@ IN: bootstrap.image
|
|||
: quot-xt@ 3 bootstrap-cells object tag-number - ;
|
||||
|
||||
: jit-define ( quot rc rt offset name -- )
|
||||
>r >r >r >r { } make r> r> r> 4array r> set ;
|
||||
>r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ;
|
||||
|
||||
! The image being constructed; a vector of word-size integers
|
||||
SYMBOL: image
|
||||
|
|
@ -134,10 +134,10 @@ SYMBOL: undefined-quot
|
|||
|
||||
: here ( -- size ) heap-size data-base + ;
|
||||
|
||||
: here-as ( tag -- pointer ) here swap bitor ;
|
||||
: here-as ( tag -- pointer ) here bitor ;
|
||||
|
||||
: align-here ( -- )
|
||||
here 8 mod 4 = [ heap-size drop 0 emit ] when ;
|
||||
here 8 mod 4 = [ 0 emit ] when ;
|
||||
|
||||
: emit-fixnum ( n -- ) tag-fixnum emit ;
|
||||
|
||||
|
|
@ -164,7 +164,7 @@ GENERIC: ' ( obj -- ptr )
|
|||
userenv-size [ f ' emit ] times ;
|
||||
|
||||
: emit-userenv ( symbol -- )
|
||||
dup get ' swap userenv-offset fixup ;
|
||||
[ get ' ] [ userenv-offset ] bi fixup ;
|
||||
|
||||
! Bignums
|
||||
|
||||
|
|
@ -175,14 +175,15 @@ GENERIC: ' ( obj -- ptr )
|
|||
: bignum>seq ( n -- seq )
|
||||
#! n is positive or zero.
|
||||
[ dup 0 > ]
|
||||
[ dup bignum-bits neg shift swap bignum-radix bitand ]
|
||||
[ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
|
||||
[ ] unfold nip ;
|
||||
|
||||
USE: continuations
|
||||
: emit-bignum ( n -- )
|
||||
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
|
||||
dup length 1+ emit-fixnum
|
||||
swap emit emit-seq ;
|
||||
dup dup 0 < [ neg ] when bignum>seq
|
||||
[ nip length 1+ emit-fixnum ]
|
||||
[ drop 0 < 1 0 ? emit ]
|
||||
[ nip emit-seq ]
|
||||
2tri ;
|
||||
|
||||
M: bignum '
|
||||
bignum tag-number dup [ emit-bignum ] emit-object ;
|
||||
|
|
@ -221,28 +222,33 @@ M: f '
|
|||
! Words
|
||||
|
||||
: emit-word ( word -- )
|
||||
dup subwords [ emit-word ] each
|
||||
[
|
||||
dup hashcode ' ,
|
||||
dup word-name ' ,
|
||||
dup word-vocabulary ' ,
|
||||
dup word-def ' ,
|
||||
dup word-props ' ,
|
||||
f ' ,
|
||||
0 , ! count
|
||||
0 , ! xt
|
||||
0 , ! code
|
||||
0 , ! profiling
|
||||
] { } make
|
||||
\ word type-number object tag-number
|
||||
[ emit-seq ] emit-object
|
||||
swap objects get set-at ;
|
||||
[ subwords [ emit-word ] each ]
|
||||
[
|
||||
[
|
||||
{
|
||||
[ hashcode , ]
|
||||
[ word-name , ]
|
||||
[ word-vocabulary , ]
|
||||
[ word-def , ]
|
||||
[ word-props , ]
|
||||
} cleave
|
||||
f ,
|
||||
0 , ! count
|
||||
0 , ! xt
|
||||
0 , ! code
|
||||
0 , ! profiling
|
||||
] { } make [ ' ] map
|
||||
] bi
|
||||
\ word type-number object tag-number
|
||||
[ emit-seq ] emit-object
|
||||
] keep objects get set-at ;
|
||||
|
||||
: word-error ( word msg -- * )
|
||||
[ % dup word-vocabulary % " " % word-name % ] "" make throw ;
|
||||
|
||||
: transfer-word ( word -- word )
|
||||
dup target-word swap or ;
|
||||
[ target-word ] keep or ;
|
||||
|
||||
: fixup-word ( word -- offset )
|
||||
transfer-word dup objects get at
|
||||
|
|
@ -285,9 +291,10 @@ M: string '
|
|||
length 0 assert= ;
|
||||
|
||||
: emit-dummy-array ( obj type -- ptr )
|
||||
swap assert-empty
|
||||
type-number object tag-number
|
||||
[ 0 emit-fixnum ] emit-object ;
|
||||
[ assert-empty ] [
|
||||
type-number object tag-number
|
||||
[ 0 emit-fixnum ] emit-object
|
||||
] bi* ;
|
||||
|
||||
M: byte-array ' byte-array emit-dummy-array ;
|
||||
|
||||
|
|
@ -296,29 +303,28 @@ M: bit-array ' bit-array emit-dummy-array ;
|
|||
M: float-array ' float-array emit-dummy-array ;
|
||||
|
||||
! Tuples
|
||||
: (emit-tuple) ( tuple -- pointer )
|
||||
[ tuple>array 1 tail-slice ]
|
||||
[ class transfer-word tuple-layout ] bi add* [ ' ] map
|
||||
tuple type-number dup [ emit-seq ] emit-object ;
|
||||
|
||||
: emit-tuple ( tuple -- pointer )
|
||||
[
|
||||
[
|
||||
dup class transfer-word tuple-layout ' ,
|
||||
tuple>array 1 tail-slice [ ' ] map %
|
||||
] { } make
|
||||
tuple type-number dup [ emit-seq ] emit-object
|
||||
]
|
||||
! Hack
|
||||
over class word-name "tombstone" =
|
||||
[ objects get swap cache ] [ call ] if ;
|
||||
dup class word-name "tombstone" =
|
||||
[ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ;
|
||||
|
||||
M: tuple ' emit-tuple ;
|
||||
|
||||
M: tuple-layout '
|
||||
objects get [
|
||||
[
|
||||
dup layout-hashcode ' ,
|
||||
dup layout-class ' ,
|
||||
dup layout-size ' ,
|
||||
dup layout-superclasses ' ,
|
||||
layout-echelon ' ,
|
||||
] { } make
|
||||
{
|
||||
[ layout-hashcode , ]
|
||||
[ layout-class , ]
|
||||
[ layout-size , ]
|
||||
[ layout-superclasses , ]
|
||||
[ layout-echelon , ]
|
||||
} cleave
|
||||
] { } make [ ' ] map
|
||||
\ tuple-layout type-number
|
||||
object tag-number [ emit-seq ] emit-object
|
||||
] cache ;
|
||||
|
|
@ -329,14 +335,9 @@ M: tombstone '
|
|||
word-def first objects get [ emit-tuple ] cache ;
|
||||
|
||||
! Arrays
|
||||
: emit-array ( list type tag -- pointer )
|
||||
>r >r [ ' ] map r> r> [
|
||||
dup length emit-fixnum
|
||||
emit-seq
|
||||
] emit-object ;
|
||||
|
||||
M: array '
|
||||
array type-number object tag-number emit-array ;
|
||||
[ ' ] map array type-number object tag-number
|
||||
[ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
|
||||
|
||||
! Quotations
|
||||
|
||||
|
|
@ -351,13 +352,6 @@ M: quotation '
|
|||
] emit-object
|
||||
] cache ;
|
||||
|
||||
! Curries
|
||||
|
||||
M: curry '
|
||||
dup curry-quot ' swap curry-obj '
|
||||
\ curry type-number object tag-number
|
||||
[ emit emit ] emit-object ;
|
||||
|
||||
! End of the image
|
||||
|
||||
: emit-words ( -- )
|
||||
|
|
@ -437,8 +431,8 @@ M: curry '
|
|||
: write-image ( image -- )
|
||||
"Writing image to " write
|
||||
architecture get boot-image-name resource-path
|
||||
dup write "..." print flush
|
||||
binary <file-writer> [ (write-image) ] with-stream ;
|
||||
[ write "..." print flush ]
|
||||
[ binary <file-writer> [ (write-image) ] with-stream ] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,8 @@ hashtables.private io kernel math namespaces parser sequences
|
|||
strings vectors words quotations assocs layouts classes
|
||||
classes.tuple classes.tuple.private kernel.private vocabs
|
||||
vocabs.loader source-files definitions slots.deprecated
|
||||
classes.union compiler.units bootstrap.image.private io.files ;
|
||||
classes.union compiler.units bootstrap.image.private io.files
|
||||
accessors combinators ;
|
||||
IN: bootstrap.primitives
|
||||
|
||||
"Creating primitives and basic runtime structures..." print flush
|
||||
|
|
@ -102,33 +103,36 @@ num-types get f <array> builtins set
|
|||
! Builtin classes
|
||||
: builtin-predicate-quot ( class -- quot )
|
||||
[
|
||||
"type" word-prop dup
|
||||
\ tag-mask get < \ tag \ type ? , , \ eq? ,
|
||||
"type" word-prop
|
||||
[ tag-mask get < \ tag \ type ? , ] [ , ] bi
|
||||
\ eq? ,
|
||||
] [ ] make ;
|
||||
|
||||
: define-builtin-predicate ( class -- )
|
||||
dup
|
||||
dup builtin-predicate-quot define-predicate
|
||||
predicate-word make-inline ;
|
||||
[ dup builtin-predicate-quot define-predicate ]
|
||||
[ predicate-word make-inline ]
|
||||
bi ;
|
||||
|
||||
: lookup-type-number ( word -- n )
|
||||
global [ target-word ] bind type-number ;
|
||||
|
||||
: register-builtin ( class -- )
|
||||
dup
|
||||
dup lookup-type-number "type" set-word-prop
|
||||
dup "type" word-prop builtins get set-nth ;
|
||||
[ dup lookup-type-number "type" set-word-prop ]
|
||||
[ dup "type" word-prop builtins get set-nth ]
|
||||
bi ;
|
||||
|
||||
: define-builtin-slots ( symbol slotspec -- )
|
||||
dupd 1 simple-slots
|
||||
2dup "slots" set-word-prop
|
||||
define-slots ;
|
||||
[ drop ] [ 1 simple-slots ] 2bi
|
||||
[ "slots" set-word-prop ] [ define-slots ] 2bi ;
|
||||
|
||||
: define-builtin ( symbol slotspec -- )
|
||||
>r
|
||||
dup register-builtin
|
||||
dup f f builtin-class define-class
|
||||
dup define-builtin-predicate
|
||||
{
|
||||
[ register-builtin ]
|
||||
[ f f builtin-class define-class ]
|
||||
[ define-builtin-predicate ]
|
||||
[ ]
|
||||
} cleave
|
||||
r> define-builtin-slots ;
|
||||
|
||||
! Forward definitions
|
||||
|
|
@ -335,7 +339,10 @@ define-builtin
|
|||
{ "set-delegate" "kernel" }
|
||||
}
|
||||
}
|
||||
define-tuple-slots
|
||||
[ drop ] [ generate-tuple-slots ] 2bi
|
||||
[ [ name>> ] map "slot-names" set-word-prop ]
|
||||
[ "slots" set-word-prop ]
|
||||
[ define-slots ] 2tri
|
||||
|
||||
"tuple" "kernel" lookup define-tuple-layout
|
||||
|
||||
|
|
@ -495,8 +502,9 @@ f builtins get num-tags get tail union-class define-class
|
|||
} define-tuple-class
|
||||
|
||||
"curry" "kernel" lookup
|
||||
dup f "inline" set-word-prop
|
||||
dup tuple-layout [ <tuple-boa> ] curry define
|
||||
[ f "inline" set-word-prop ]
|
||||
[ ]
|
||||
[ tuple-layout [ <tuple-boa> ] curry ] tri define
|
||||
|
||||
"compose" "kernel" create
|
||||
"tuple" "kernel" lookup
|
||||
|
|
@ -515,8 +523,9 @@ dup tuple-layout [ <tuple-boa> ] curry define
|
|||
} define-tuple-class
|
||||
|
||||
"compose" "kernel" lookup
|
||||
dup f "inline" set-word-prop
|
||||
dup tuple-layout [ <tuple-boa> ] curry define
|
||||
[ f "inline" set-word-prop ]
|
||||
[ ]
|
||||
[ tuple-layout [ <tuple-boa> ] curry ] tri define
|
||||
|
||||
! Primitive words
|
||||
: make-primitive ( word vocab n -- )
|
||||
|
|
|
|||
Loading…
Reference in New Issue