steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Clean up bootstrap code a bit

db4
Slava Pestov 2008-03-31 01:19:21 -05:00
parent 420e7dc57e
commit 2ebb7d2271
2 changed files with 84 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

102
core/bootstrap/image/image.factor
View File

@ -12,7 +12,7 @@ io.encodings.binary ;
IN: bootstrap.image IN: bootstrap.image
: my-arch ( -- arch ) : my-arch ( -- arch )
cpu dup "ppc" = [ os "-" rot 3append ] when ; cpu dup "ppc" = [ >r os "-" r> 3append ] when ;
: boot-image-name ( arch -- string ) : boot-image-name ( arch -- string )
"boot." swap ".image" 3append ; "boot." swap ".image" 3append ;
@ -55,7 +55,7 @@ IN: bootstrap.image
: quot-xt@ 3 bootstrap-cells object tag-number - ; : quot-xt@ 3 bootstrap-cells object tag-number - ;
: jit-define ( quot rc rt offset name -- ) : 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 ! The image being constructed; a vector of word-size integers
SYMBOL: image SYMBOL: image
@ -134,10 +134,10 @@ SYMBOL: undefined-quot
: here ( -- size ) heap-size data-base + ; : here ( -- size ) heap-size data-base + ;
: here-as ( tag -- pointer ) here swap bitor ; : here-as ( tag -- pointer ) here bitor ;
: align-here ( -- ) : 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 ; : emit-fixnum ( n -- ) tag-fixnum emit ;
@ -164,7 +164,7 @@ GENERIC: ' ( obj -- ptr )
userenv-size [ f ' emit ] times ; userenv-size [ f ' emit ] times ;
: emit-userenv ( symbol -- ) : emit-userenv ( symbol -- )
dup get ' swap userenv-offset fixup ; [ get ' ] [ userenv-offset ] bi fixup ;
! Bignums ! Bignums
@ -175,14 +175,15 @@ GENERIC: ' ( obj -- ptr )
: bignum>seq ( n -- seq ) : bignum>seq ( n -- seq )
#! n is positive or zero. #! n is positive or zero.
[ dup 0 > ] [ dup 0 > ]
[ dup bignum-bits neg shift swap bignum-radix bitand ] [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
[ ] unfold nip ; [ ] unfold nip ;
USE: continuations
: emit-bignum ( n -- ) : emit-bignum ( n -- )
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq dup dup 0 < [ neg ] when bignum>seq
dup length 1+ emit-fixnum [ nip length 1+ emit-fixnum ]
swap emit emit-seq ; [ drop 0 < 1 0 ? emit ]
[ nip emit-seq ]
2tri ;
M: bignum ' M: bignum '
bignum tag-number dup [ emit-bignum ] emit-object ; bignum tag-number dup [ emit-bignum ] emit-object ;
@ -221,28 +222,33 @@ M: f '
! Words ! Words
: emit-word ( word -- ) : emit-word ( word -- )
dup subwords [ emit-word ] each
[ [
dup hashcode ' , [ subwords [ emit-word ] each ]
dup word-name ' , [
dup word-vocabulary ' , [
dup word-def ' , {
dup word-props ' , [ hashcode , ]
f ' , [ word-name , ]
[ word-vocabulary , ]
[ word-def , ]
[ word-props , ]
} cleave
f ,
0 , ! count 0 , ! count
0 , ! xt 0 , ! xt
0 , ! code 0 , ! code
0 , ! profiling 0 , ! profiling
] { } make ] { } make [ ' ] map
] bi
\ word type-number object tag-number \ word type-number object tag-number
[ emit-seq ] emit-object [ emit-seq ] emit-object
swap objects get set-at ; ] keep objects get set-at ;
: word-error ( word msg -- * ) : word-error ( word msg -- * )
[ % dup word-vocabulary % " " % word-name % ] "" make throw ; [ % dup word-vocabulary % " " % word-name % ] "" make throw ;
: transfer-word ( word -- word ) : transfer-word ( word -- word )
dup target-word swap or ; [ target-word ] keep or ;
: fixup-word ( word -- offset ) : fixup-word ( word -- offset )
transfer-word dup objects get at transfer-word dup objects get at
@ -285,9 +291,10 @@ M: string '
length 0 assert= ; length 0 assert= ;
: emit-dummy-array ( obj type -- ptr ) : emit-dummy-array ( obj type -- ptr )
swap assert-empty [ assert-empty ] [
type-number object tag-number type-number object tag-number
[ 0 emit-fixnum ] emit-object ; [ 0 emit-fixnum ] emit-object
] bi* ;
M: byte-array ' byte-array emit-dummy-array ; 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 ; M: float-array ' float-array emit-dummy-array ;
! Tuples ! 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 ) : emit-tuple ( tuple -- pointer )
[ dup class word-name "tombstone" =
[ [ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ;
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 ;
M: tuple ' emit-tuple ; M: tuple ' emit-tuple ;
M: tuple-layout ' M: tuple-layout '
objects get [ objects get [
[ [
dup layout-hashcode ' , {
dup layout-class ' , [ layout-hashcode , ]
dup layout-size ' , [ layout-class , ]
dup layout-superclasses ' , [ layout-size , ]
layout-echelon ' , [ layout-superclasses , ]
] { } make [ layout-echelon , ]
} cleave
] { } make [ ' ] map
\ tuple-layout type-number \ tuple-layout type-number
object tag-number [ emit-seq ] emit-object object tag-number [ emit-seq ] emit-object
] cache ; ] cache ;
@ -329,14 +335,9 @@ M: tombstone '
word-def first objects get [ emit-tuple ] cache ; word-def first objects get [ emit-tuple ] cache ;
! Arrays ! Arrays
: emit-array ( list type tag -- pointer )
>r >r [ ' ] map r> r> [
dup length emit-fixnum
emit-seq
] emit-object ;
M: array ' 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 ! Quotations
@ -351,13 +352,6 @@ M: quotation '
] emit-object ] emit-object
] cache ; ] cache ;
! Curries
M: curry '
dup curry-quot ' swap curry-obj '
\ curry type-number object tag-number
[ emit emit ] emit-object ;
! End of the image ! End of the image
: emit-words ( -- ) : emit-words ( -- )
@ -437,8 +431,8 @@ M: curry '
: write-image ( image -- ) : write-image ( image -- )
"Writing image to " write "Writing image to " write
architecture get boot-image-name resource-path architecture get boot-image-name resource-path
dup write "..." print flush [ write "..." print flush ]
binary <file-writer> [ (write-image) ] with-stream ; [ binary <file-writer> [ (write-image) ] with-stream ] bi ;
PRIVATE> PRIVATE>

49
core/bootstrap/primitives.factor
View File

@ -5,7 +5,8 @@ hashtables.private io kernel math namespaces parser sequences
strings vectors words quotations assocs layouts classes strings vectors words quotations assocs layouts classes
classes.tuple classes.tuple.private kernel.private vocabs classes.tuple classes.tuple.private kernel.private vocabs
vocabs.loader source-files definitions slots.deprecated 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 IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush "Creating primitives and basic runtime structures..." print flush
@ -102,33 +103,36 @@ num-types get f <array> builtins set
! Builtin classes ! Builtin classes
: builtin-predicate-quot ( class -- quot ) : builtin-predicate-quot ( class -- quot )
[ [
"type" word-prop dup "type" word-prop
\ tag-mask get < \ tag \ type ? , , \ eq? , [ tag-mask get < \ tag \ type ? , ] [ , ] bi
\ eq? ,
] [ ] make ; ] [ ] make ;
: define-builtin-predicate ( class -- ) : define-builtin-predicate ( class -- )
dup [ dup builtin-predicate-quot define-predicate ]
dup builtin-predicate-quot define-predicate [ predicate-word make-inline ]
predicate-word make-inline ; bi ;
: lookup-type-number ( word -- n ) : lookup-type-number ( word -- n )
global [ target-word ] bind type-number ; global [ target-word ] bind type-number ;
: register-builtin ( class -- ) : register-builtin ( class -- )
dup [ dup lookup-type-number "type" set-word-prop ]
dup lookup-type-number "type" set-word-prop [ dup "type" word-prop builtins get set-nth ]
dup "type" word-prop builtins get set-nth ; bi ;
: define-builtin-slots ( symbol slotspec -- ) : define-builtin-slots ( symbol slotspec -- )
dupd 1 simple-slots [ drop ] [ 1 simple-slots ] 2bi
2dup "slots" set-word-prop [ "slots" set-word-prop ] [ define-slots ] 2bi ;
define-slots ;
: define-builtin ( symbol slotspec -- ) : define-builtin ( symbol slotspec -- )
>r >r
dup register-builtin {
dup f f builtin-class define-class [ register-builtin ]
dup define-builtin-predicate [ f f builtin-class define-class ]
[ define-builtin-predicate ]
[ ]
} cleave
r> define-builtin-slots ; r> define-builtin-slots ;
! Forward definitions ! Forward definitions
@ -335,7 +339,10 @@ define-builtin
{ "set-delegate" "kernel" } { "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 "tuple" "kernel" lookup define-tuple-layout
@ -495,8 +502,9 @@ f builtins get num-tags get tail union-class define-class
} define-tuple-class } define-tuple-class
"curry" "kernel" lookup "curry" "kernel" lookup
dup f "inline" set-word-prop [ f "inline" set-word-prop ]
dup tuple-layout [ <tuple-boa> ] curry define [ ]
[ tuple-layout [ <tuple-boa> ] curry ] tri define
"compose" "kernel" create "compose" "kernel" create
"tuple" "kernel" lookup "tuple" "kernel" lookup
@ -515,8 +523,9 @@ dup tuple-layout [ <tuple-boa> ] curry define
} define-tuple-class } define-tuple-class
"compose" "kernel" lookup "compose" "kernel" lookup
dup f "inline" set-word-prop [ f "inline" set-word-prop ]
dup tuple-layout [ <tuple-boa> ] curry define [ ]
[ tuple-layout [ <tuple-boa> ] curry ] tri define
! Primitive words ! Primitive words
: make-primitive ( word vocab n -- ) : make-primitive ( word vocab n -- )