"Compiling base..." print flush
+ \ slot \ set-slot [ usage ] 2apply append
+ [ try-compile ] each
+
\ + compile
\ = compile
{ "kernel" "sequences" "assembler" } compile-vocabs
"cons?" "lists" create t "inline" set-word-prop
"cons" "lists" create 2 "cons?" "lists" create
-{ { 0 { "car" "lists" } f } { 1 { "cdr" "lists" } f } } define-builtin
+{
+ { 0 object { "car" "lists" } f }
+ { 1 object { "cdr" "lists" } f }
+} define-builtin
"ratio?" "math" create t "inline" set-word-prop
"ratio" "math" create 4 "ratio?" "math" create
-{ { 0 { "numerator" "math" } f } { 1 { "denominator" "math" } f } } define-builtin
+{
+ { 0 integer { "numerator" "math" } f }
+ { 1 integer { "denominator" "math" } f }
+} define-builtin
"ratio" "math" create 2 "math-priority" set-word-prop
"float?" "math" create t "inline" set-word-prop
"complex?" "math" create t "inline" set-word-prop
"complex" "math" create 6 "complex?" "math" create
-{ { 0 { "real" "math" } f } { 1 { "imaginary" "math" } f } } define-builtin
+{
+ { 0 real { "real" "math" } f }
+ { 1 real { "imaginary" "math" } f }
+} define-builtin
"complex" "math" create 4 "math-priority" set-word-prop
"alien" "alien" create 7 "alien?" "alien" create
-{ { 1 { "underlying-alien" "alien" } f } } define-builtin
+{ { 1 object { "underlying-alien" "alien" } f } } define-builtin
"array?" "arrays" create t "inline" set-word-prop
"array" "arrays" create 8 "array?" "arrays" create
"hashtable?" "hashtables" create t "inline" set-word-prop
"hashtable" "hashtables" create 10 "hashtable?" "hashtables" create
{
- { 1 { "hash-count" "hashtables" } { "set-hash-count" "hashtables-internals" } }
- { 2 { "hash-deleted" "hashtables" } { "set-hash-deleted" "hashtables-internals" } }
- { 3 { "hash-array" "hashtables-internals" } { "set-hash-array" "hashtables-internals" } }
+ {
+ 1
+ fixnum
+ { "hash-count" "hashtables" }
+ { "set-hash-count" "hashtables-internals" }
+ } {
+ 2
+ fixnum
+ { "hash-deleted" "hashtables" }
+ { "set-hash-deleted" "hashtables-internals" }
+ } {
+ 3
+ array
+ { "hash-array" "hashtables-internals" }
+ { "set-hash-array" "hashtables-internals" }
+ }
} define-builtin
"vector?" "vectors" create t "inline" set-word-prop
"vector" "vectors" create 11 "vector?" "vectors" create
{
- { 1 { "length" "sequences" } { "set-fill" "sequences-internals" } }
- { 2 { "underlying" "sequences-internals" } { "set-underlying" "sequences-internals" } }
+ {
+ 1
+ fixnum
+ { "length" "sequences" }
+ { "set-fill" "sequences-internals" }
+ } {
+ 2
+ array
+ { "underlying" "sequences-internals" }
+ { "set-underlying" "sequences-internals" }
+ }
} define-builtin
"string?" "strings" create t "inline" set-word-prop
"string" "strings" create 12 "string?" "strings" create
{
- { 1 { "length" "sequences" } f }
- { 2 { "string-hashcode" "kernel-internals" } { "set-string-hashcode" "kernel-internals" } }
+ {
+ 1
+ fixnum
+ { "length" "sequences" }
+ f
+ } {
+ 2
+ fixnum
+ { "string-hashcode" "kernel-internals" }
+ { "set-string-hashcode" "kernel-internals" }
+ }
} define-builtin
"sbuf?" "strings" create t "inline" set-word-prop
"sbuf" "strings" create 13 "sbuf?" "strings" create
{
- { 1 { "length" "sequences" } { "set-fill" "sequences-internals" } }
- { 2 { "underlying" "sequences-internals" } { "set-underlying" "sequences-internals" } }
+ {
+ 1
+ fixnum
+ { "length" "sequences" }
+ { "set-fill" "sequences-internals" }
+ }
+ {
+ 2
+ string
+ { "underlying" "sequences-internals" }
+ { "set-underlying" "sequences-internals" }
+ }
} define-builtin
"wrapper?" "kernel" create t "inline" set-word-prop
"wrapper" "kernel" create 14 "wrapper?" "kernel" create
-{ { 1 { "wrapped" "kernel" } f } } define-builtin
+{ { 1 object { "wrapped" "kernel" } f } } define-builtin
"dll?" "alien" create t "inline" set-word-prop
"dll" "alien" create 15 "dll?" "alien" create
-{ { 1 { "dll-path" "alien" } f } } define-builtin
+{ { 1 object { "dll-path" "alien" } f } } define-builtin
"word?" "words" create t "inline" set-word-prop
"word" "words" create 16 "word?" "words" create
{
- { 1 { "hashcode" "kernel" } f }
- { 2 { "word-name" "words" } f }
- { 3 { "word-vocabulary" "words" } { "set-word-vocabulary" "words" } }
- { 4 { "word-primitive" "words" } { "set-word-primitive" "words" } }
- { 5 { "word-def" "words" } { "set-word-def" "words" } }
- { 6 { "word-props" "words" } { "set-word-props" "words" } }
+ { 1 fixnum { "hashcode" "kernel" } f }
+ {
+ 2
+ object
+ { "word-name" "words" }
+ f
+ }
+ {
+ 3
+ object
+ { "word-vocabulary" "words" }
+ { "set-word-vocabulary" "words" }
+ }
+ {
+ 4
+ object
+ { "word-primitive" "words" }
+ { "set-word-primitive" "words" }
+ }
+ {
+ 5
+ object
+ { "word-def" "words" }
+ { "set-word-def" "words" }
+ }
+ {
+ 6
+ object
+ { "word-props" "words" }
+ { "set-word-props" "words" }
+ }
} define-builtin
"tuple?" "kernel" create t "inline" set-word-prop
: ((empty)) T{ tombstone f } ; inline
: ((tombstone)) T{ tombstone t } ; inline
-: hash@ ( key keys -- n ) >r hashcode r> length 2 /i rem 2 * ;
+: hash@ ( key keys -- n )
+ >r hashcode r> length 2 /i rem 2 * ; inline
-: probe ( heys i -- hash i ) 2 + over length mod ;
+: probe ( heys i -- hash i ) 2 + over length mod ; inline
: (key@) ( key keys i -- n )
3dup swap nth-unsafe {
{ [ t ] [ probe (key@) ] }
} cond ;
-: key@ ( key hash -- n ) hash-array 2dup hash@ (key@) ;
+: key@ ( key hash -- n )
+ hash-array 2dup hash@ (key@) ; inline
: if-key ( key hash true false -- | true: index key hash -- )
>r >r [ key@ ] 2keep pick -1 > r> r> if ; inline
-: <hash-array> ( n -- array ) 1+ 4 * ((empty)) <array> ;
+: <hash-array> ( n -- array )
+ 1+ 4 * ((empty)) <array> ; inline
: init-hash ( hash -- )
0 over set-hash-count 0 swap set-hash-deleted ;
2drop 2nip
] [
= [ 2nip ] [ probe (new-key@) ] if
- ] if ;
+ ] if ; inline
: new-key@ ( key hash -- n )
- hash-array 2dup hash@ (new-key@) ;
+ hash-array 2dup hash@ (new-key@) ; inline
: nth-pair ( n seq -- key value )
- [ nth-unsafe ] 2keep >r 1+ r> nth-unsafe ;
+ [ nth-unsafe ] 2keep >r 1+ r> nth-unsafe ; inline
: set-nth-pair ( value key n seq -- )
- [ set-nth-unsafe ] 2keep >r 1+ r> set-nth-unsafe ;
+ [ set-nth-unsafe ] 2keep >r 1+ r> set-nth-unsafe ; inline
-: hash-count+ dup hash-count 1+ swap set-hash-count ;
+: hash-count+
+ dup hash-count 1+ swap set-hash-count ; inline
-: hash-deleted+ dup hash-deleted 1+ swap set-hash-deleted ;
+: hash-deleted+
+ dup hash-deleted 1+ swap set-hash-deleted ; inline
-: hash-deleted- dup hash-deleted 1- swap set-hash-deleted ;
+: hash-deleted-
+ dup hash-deleted 1- swap set-hash-deleted ; inline
: change-size ( hash old -- )
dup ((tombstone)) eq? [
drop hash-deleted-
] [
((empty)) eq? [ hash-count+ ] [ drop ] if
- ] if ;
+ ] if ; inline
: (set-hash) ( value key hash -- )
2dup new-key@ swap
[ hash-array 2dup nth-unsafe ] keep
( value key n hash-array old hash )
- swap change-size set-nth-pair ;
+ swap change-size set-nth-pair ; inline
: (each-pair) ( quot array i -- | quot: k v -- )
over length over number= [
3drop
] if-key ;
-: hash-size ( hash -- n ) dup hash-count swap hash-deleted - ;
+: hash-size ( hash -- n )
+ dup hash-count swap hash-deleted - ; inline
: hash-empty? ( hash -- ? ) hash-size zero? ;
: ?grow-hash ( hash -- )
dup hash-count 3 * over hash-array length >
- [ dup grow-hash ] when drop ;
+ [ dup grow-hash ] when drop ; inline
: set-hash ( value key hash -- )
[ (set-hash) ] keep ?grow-hash ;
C: #terminate make-node ;
: #terminate ( -- node ) empty-node <#terminate> ;
+TUPLE: #declare ;
+C: #declare make-node ;
+: #declare ( classes -- node ) param-node <#declare> ;
+
: node-inputs ( d-count r-count node -- )
tuck
>r r-tail r> set-node-in-r
kernel-internals lists math math-internals memory parser
sequences strings vectors words prettyprint ;
-! We transform calls to these words into 'branched' forms;
-! eg, there is no VOP for fixnum<=, only fixnum<= followed
-! by an #if, so if we have a 'bare' fixnum<= we add
-! [ t ] [ f ] if at the end.
+\ declare [
+ pop-literal nip
+ dup length ensure-values
+ dup #declare [ >r length d-tail r> set-node-in-d ] keep
+ node,
+] "infer" set-word-prop
+\ declare [ [ object ] [ ] ] "infer-effect" set-word-prop
-! This transformation really belongs in the optimizer, but it
-! is simpler to do it here.
\ fixnum< [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
\ fixnum< t "flushable" set-word-prop
\ fixnum< t "foldable" set-word-prop
\ eq? t "flushable" set-word-prop
\ eq? t "foldable" set-word-prop
-: manual-branch ( word -- )
- dup "infer-effect" word-prop consume/produce
- [ [ t ] [ f ] if ] infer-quot ;
-
-! { fixnum<= fixnum< fixnum>= fixnum> eq? }
-! [ dup [ manual-branch ] curry "infer" set-word-prop ] each
-
! Primitive combinators
\ call [ [ general-list ] [ ] ] "infer-effect" set-word-prop
{ [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
} define-optimizers
+: useless-coerce? ( node -- )
+ dup node-in-d first over node-classes ?hash
+ swap node-param "infer-effect" word-prop second first eq? ;
+
+: call>no-op ( node -- node )
+ [ ] dataflow [ subst-node ] keep ;
+
+{ >fixnum >bignum >float } [
+ {
+ { [ dup useless-coerce? ] [ call>no-op ] }
+ } define-optimizers
+] each
+
! Arithmetic identities
SYMBOL: @
dup node-in-d first
swap node-children length [ <literal-tie> ] map-with ;
+M: #declare infer-classes* ( node -- )
+ dup node-param swap node-in-d [ set-value-class* ] 2each ;
+
DEFER: (infer-classes)
: infer-children ( node -- )
last-node 2dup swap post-inline set-node-successor ;
: inline-method ( node -- node )
- #! We set the #call node's param to f so that it gets killed
- #! later.
dup method-dataflow
[ >r node-param r> remember-node ] 2keep
[ subst-node ] keep ;
-: related? ( actual testing -- ? )
+: comparable? ( actual testing -- ? )
#! If actual is a subset of testing or if the two classes
#! are disjoint, return t.
2dup class< >r classes-intersect? not r> or ;
: optimize-predicate? ( #call -- ? )
dup node-param "predicating" word-prop dup [
- >r dup node-in-d node-classes* first r> related?
+ >r dup node-in-d node-classes* first r> comparable?
] [
2drop f
] if ;
: inline-literals ( node literals -- node )
- #! Make #push -> #return -> successor
+ #! Make #shuffle -> #push -> #return -> successor
over drop-inputs [
>r >list [ literalize ] map dataflow [ subst-node ] keep
r> set-node-successor
M: #return node>quot ( ? node -- )
dup node-param unparse "#return " swap append comment, ;
-M: #values node>quot ( ? node -- ) "#values" comment, ;
-
-M: #merge node>quot ( ? node -- ) "#merge" comment, ;
-
-M: #entry node>quot ( ? node -- ) "#entry" comment, ;
-
-M: #terminate node>quot ( ? node -- ) "#terminate" comment, ;
+M: object node>quot ( ? node -- ) dup class comment, ;
: (dataflow>quot) ( ? node -- )
dup [
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler
-USING: arrays generic kernel math namespaces sequences words ;
+USING: arrays generic hashtables kernel math namespaces
+sequences words ;
: make-specializer ( quot class picker -- quot )
over \ object eq? [
{ v+ v- v* v/ vmax vmin v. } [
{ array array } "specializer" set-word-prop
] each
+
+\ hash* { object hashtable } "specializer" set-word-prop
+\ remove-hash { object hashtable } "specializer" set-word-prop
+\ set-hash { object object hashtable } "specializer" set-word-prop
+
+{ first first2 first3 first4 }
+[ { array } "specializer" set-word-prop ] each
2drop object-method
] if ;
-: math-vtable ( picker quot -- )
+: math-vtable ( picker quot -- quot )
[
swap , \ tag ,
[ num-tags [ type>class ] map swap map % ] { } make ,
: math-class? ( object -- ? )
dup word? [ "math-priority" word-prop ] [ drop f ] if ;
-: math-combination ( word -- vtable )
+: math-combination ( word -- quot )
\ over [
dup math-class? [
\ dup [ >r 2dup r> math-method ] math-vtable
] if nip
] math-vtable nip ;
+: partial-math-dispatch ( word class left/right -- vtable )
+ dup \ dup \ over ? [
+ ( word class left/right class )
+ >r 3dup r> swap [ swap ] unless math-method
+ ] math-vtable >r 3drop r> ;
+
PREDICATE: generic 2generic ( word -- ? )
"combination" word-prop [ math-combination ] = ;
2drop 2drop
] if ;
-: define-reader ( class slot reader -- )
- [ slot ] define-slot-word ;
+: define-reader ( class slot decl reader -- )
+ [ slot ] rot dup object eq? [
+ drop
+ ] [
+ 1array [ declare ] curry append
+ ] if define-slot-word ;
: define-writer ( class slot writer -- )
[ set-slot ] define-slot-word ;
-: define-slot ( class slot reader writer -- )
- >r >r 2dup r> define-reader r> define-writer ;
+: define-slot ( class slot decl reader writer -- )
+ >r >r >r 2dup r> r> define-reader r> define-writer ;
: intern-slots ( spec -- spec )
- [ first3 [ dup [ first2 create ] when ] 2apply 3array ] map ;
+ [ [ dup array? [ first2 create ] when ] map ] map ;
: define-slots ( class spec -- )
- [ first3 define-slot ] each-with ;
+ [ first4 define-slot ] each-with ;
: reader-word ( class name -- word )
>r word-name "-" r> append3 in get 2array ;
: writer-word ( class name -- word )
[ swap "set-" % word-name % "-" % % ] "" make in get 2array ;
-: simple-slot ( class name -- reader writer )
- [ reader-word ] 2keep writer-word ;
+: simple-slot ( class name -- )
+ 2dup reader-word , writer-word , ;
: simple-slots ( class slots base -- spec )
over length [ + ] map-with
- [ >r dupd simple-slot r> -rot 3array ] 2map nip
- intern-slots ;
+ [ [ , object , dupd simple-slot ] { } make ] 2map nip intern-slots ;
IN: kernel-internals
! These words are unsafe. Don't use them.
+: declare ( types -- ) drop ;
: array-capacity 1 slot ; inline
: array-nth swap 2 fixnum+fast slot ; inline