Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-07-06 11:31:02 -05:00
commit 50df10dd33
10 changed files with 93 additions and 70 deletions

View File

@ -1,16 +1,16 @@
USING: assocs kernel namespaces quotations generic math
sequences combinators words classes.algebra ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel kernel.private namespaces quotations
generic math sequences combinators words classes.algebra arrays
;
IN: generic.standard.engines
SYMBOL: default
SYMBOL: assumed
SYMBOL: (dispatch#)
GENERIC: engine>quot ( engine -- quot )
M: quotation engine>quot ;
M: method-body engine>quot 1quotation ;
: engines>quots ( assoc -- assoc' )
[ engine>quot ] assoc-map ;
@ -36,8 +36,6 @@ M: method-body engine>quot 1quotation ;
r> execute r> pick set-at
] if ; inline
SYMBOL: (dispatch#)
: (picker) ( n -- quot )
{
{ 0 [ [ dup ] ] }

View File

@ -1,6 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: generic.standard.engines generic namespaces kernel
sequences classes.algebra accessors words combinators
assocs ;
kernel.private sequences classes.algebra accessors words
combinators assocs arrays ;
IN: generic.standard.engines.predicate
TUPLE: predicate-dispatch-engine methods ;
@ -24,8 +26,13 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
: sort-methods ( assoc -- assoc' )
>alist [ keys sort-classes ] keep extract-keys ;
: methods-with-default ( engine -- assoc )
methods>> clone default get object bootstrap-word pick set-at ;
M: predicate-dispatch-engine engine>quot
methods>> clone
default get object bootstrap-word pick set-at engines>quots
sort-methods prune-redundant-predicates
class-predicates alist>quot ;
methods-with-default
engines>quots
sort-methods
prune-redundant-predicates
class-predicates
alist>quot ;

View File

@ -10,7 +10,16 @@ IN: generic.standard
GENERIC: dispatch# ( word -- n )
M: word dispatch# "combination" word-prop dispatch# ;
M: generic dispatch#
"combination" word-prop dispatch# ;
GENERIC: method-declaration ( class generic -- quot )
M: generic method-declaration
"combination" word-prop method-declaration ;
M: quotation engine>quot
assumed get generic get method-declaration prepend ;
: unpickers
{
@ -135,6 +144,9 @@ M: standard-combination perform-combination
M: standard-combination dispatch# #>> ;
M: standard-combination method-declaration
dispatch# object <array> swap prefix [ declare ] curry [ ] like ;
M: standard-combination next-method-quot*
[
single-next-method-quot picker prepend
@ -157,6 +169,8 @@ PREDICATE: hook-generic < generic
M: hook-combination dispatch# drop 0 ;
M: hook-combination method-declaration 2drop [ ] ;
M: hook-generic extra-values drop 1 ;
M: hook-generic effective-method

View File

@ -191,6 +191,10 @@ DEFER: (flat-length)
: apply-identities ( node -- node/f )
dup find-identity f splice-quot ;
: splice-word-def ( #call word def -- node )
[ drop +inlined+ depends-on ] [ swap 1array ] 2bi
splice-quot ;
: optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [
>r node-input-classes r> specialized-length tail*
@ -199,22 +203,20 @@ DEFER: (flat-length)
2drop f
] if ;
: splice-word-def ( #call word -- node )
dup +inlined+ depends-on
dup def>> swap 1array splice-quot ;
: already-inlined? ( #call -- ? )
[ param>> ] [ history>> ] bi memq? ;
: optimistic-inline ( #call -- node )
dup node-param over node-history memq? [
drop t
] [
dup node-param splice-word-def
dup already-inlined? [ drop t ] [
dup param>> dup def>> splice-word-def
] if ;
: should-inline? ( word -- ? )
flat-length 11 <= ;
: method-body-inline? ( #call -- ? )
node-param dup method-body? [ should-inline? ] [ drop f ] if ;
param>> dup [ method-body? ] [ "default" word-prop not ] bi and
[ should-inline? ] [ drop f ] if ;
M: #call optimize-node*
{

View File

@ -18,13 +18,6 @@ IN: optimizer.specializers
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if ;
: tag-specializer ( quot -- newquot )
[
[ dup tag ] %
num-tags get swap <array> ,
\ dispatch ,
] [ ] make ;
: specializer-cases ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
@ -39,11 +32,7 @@ IN: optimizer.specializers
method-declaration [ declare ] curry prepend ;
: specialize-quot ( quot specializer -- quot' )
dup { number } = [
drop tag-specializer
] [
specializer-cases alist>quot
] if ;
specializer-cases alist>quot ;
: standard-method? ( method -- ? )
dup method-body? [

View File

@ -168,7 +168,7 @@ M: stdin dispose
: wait-for-stdin ( stdin -- n )
[ control>> CHAR: X over io:stream-write1 io:stream-flush ]
[ size>> "size_t" heap-size swap io:stream-read *uint ]
[ size>> "ssize_t" heap-size swap io:stream-read *int ]
bi ;
:: refill-stdin ( buffer stdin size -- )

View File

@ -27,10 +27,6 @@ HELP: >persistent-vector
HELP: persistent-vector
{ $class-description "The class of persistent vectors." } ;
HELP: pempty
{ $values { "pvec" persistent-vector } }
{ $description "Outputs an empty " { $link persistent-vector } "." } ;
ARTICLE: "persistent-vectors" "Persistent vectors"
"A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time."
$nl
@ -42,12 +38,12 @@ $nl
{ $subsection new-nth }
{ $subsection ppush }
{ $subsection ppop }
"The empty persistent vector, used for building up all other persistent vectors:"
{ $subsection pempty }
"Converting a sequence into a persistent vector:"
{ $subsection >persistent-vector }
"Persistent vectors have a literal syntax:"
{ $subsection POSTPONE: PV{ }
"The empty persistent vector, written " { $snippet "PV{ }" } ", is used for building up all other persistent vectors."
$nl
"This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ;
ABOUT: "persistent-vectors"

View File

@ -1,23 +1,23 @@
IN: persistent-vectors.tests
USING: tools.test persistent-vectors sequences kernel arrays
random namespaces vectors math math.order ;
USING: accessors tools.test persistent-vectors sequences kernel
arrays random namespaces vectors math math.order ;
\ new-nth must-infer
\ ppush must-infer
\ ppop must-infer
[ 0 ] [ pempty length ] unit-test
[ 0 ] [ PV{ } length ] unit-test
[ 1 ] [ 3 pempty ppush length ] unit-test
[ 1 ] [ 3 PV{ } ppush length ] unit-test
[ 3 ] [ 3 pempty ppush first ] unit-test
[ 3 ] [ 3 PV{ } ppush first ] unit-test
[ PV{ 3 1 3 3 7 } ] [
pempty { 3 1 3 3 7 } [ swap ppush ] each
PV{ } { 3 1 3 3 7 } [ swap ppush ] each
] unit-test
[ { 3 1 3 3 7 } ] [
pempty { 3 1 3 3 7 } [ swap ppush ] each >array
PV{ } { 3 1 3 3 7 } [ swap ppush ] each >array
] unit-test
{ 100 1060 2000 10000 100000 1000000 } [
@ -52,6 +52,16 @@ random namespaces vectors math math.order ;
[ ] [ PV{ } 10000 [ push/pop-test ] times drop ] unit-test
[ PV{ } ] [
PV{ }
10000 [ 1 swap ppush ] times
10000 [ ppop ] times
] unit-test
[ t ] [
10000 >persistent-vector 752 [ ppop ] times dup length sequence=
] unit-test
[ t ] [
100 [
drop

View File

@ -4,6 +4,12 @@ USING: math accessors kernel sequences.private sequences arrays
combinators combinators.short-circuit parser prettyprint.backend ;
IN: persistent-vectors
<PRIVATE
TUPLE: node { children array } { level fixnum } ;
PRIVATE>
ERROR: empty-error pvec ;
GENERIC: ppush ( val seq -- seq' )
@ -18,14 +24,13 @@ GENERIC: new-nth ( val i seq -- seq' )
M: sequence new-nth clone [ set-nth ] keep ;
TUPLE: persistent-vector count root tail ;
TUPLE: persistent-vector
{ count fixnum }
{ root node initial: T{ node f { } 1 } }
{ tail node initial: T{ node f { } 0 } } ;
M: persistent-vector length count>> ;
<PRIVATE
TUPLE: node children level ;
: node-size 32 ; inline
: node-mask node-size mod ; inline
@ -33,12 +38,12 @@ TUPLE: node children level ;
: node-shift -5 * shift ; inline
: node-nth ( i node -- obj )
[ node-mask ] [ children>> ] bi* nth ; inline
[ node-mask ] [ children>> ] bi* nth ;
: body-nth ( i node -- i node' )
dup level>> [
dupd [ level>> node-shift ] keep node-nth
] times ; inline
] times ;
: tail-offset ( pvec -- n )
[ count>> ] [ tail>> children>> length ] bi - ;
@ -58,9 +63,7 @@ M: persistent-vector nth-unsafe
children>> length node-size = ;
: 1node ( val level -- node )
node new
swap >>level
swap 1array >>children ;
[ 1array ] dip node boa ;
: 2node ( first second -- node )
[ 2array ] [ drop level>> 1+ ] 2bi node boa ;
@ -123,6 +126,10 @@ M: persistent-vector new-nth ( obj i pvec -- pvec' )
] if
] if ;
! The pop code is really convoluted. I don't understand Rich Hickey's
! original code. It uses a 'Box' out parameter which is passed around
! inside a recursive function, and gets mutated along the way to boot.
! Super-confusing.
: ppop-tail ( pvec -- pvec' )
[ clone [ ppop ] change-children ] change-tail ;
@ -137,10 +144,12 @@ M: persistent-vector new-nth ( obj i pvec -- pvec' )
: (ppop-new-tail) ( root -- root' tail' )
dup level>> 1 > [
dup children>> peek (ppop-new-tail) over
[ [ swap node-set-last ] dip ]
[ 2drop ppop-contraction ]
if
dup children>> peek (ppop-new-tail) [
dup
[ swap node-set-last ]
[ drop ppop-contraction drop ]
if
] dip
] [
ppop-contraction
] if ;
@ -159,13 +168,10 @@ M: persistent-vector new-nth ( obj i pvec -- pvec' )
PRIVATE>
: pempty ( -- pvec )
T{ persistent-vector f 0 T{ node f { } 1 } T{ node f { } 0 } } ; inline
M: persistent-vector ppop ( pvec -- pvec' )
dup count>> {
{ 0 [ empty-error ] }
{ 1 [ drop pempty ] }
{ 1 [ drop T{ persistent-vector } ] }
[
[
clone
@ -176,12 +182,13 @@ M: persistent-vector ppop ( pvec -- pvec' )
} case ;
M: persistent-vector like
drop pempty [ swap ppush ] reduce ;
drop T{ persistent-vector } [ swap ppush ] reduce ;
M: persistent-vector equal?
over persistent-vector? [ sequence= ] [ 2drop f ] if ;
: >persistent-vector ( seq -- pvec ) pempty like ; inline
: >persistent-vector ( seq -- pvec )
T{ persistent-vector } like ;
: PV{ \ } [ >persistent-vector ] parse-literal ; parsing

View File

@ -339,7 +339,7 @@ void *stdin_loop(void *arg)
for(;;)
{
size_t bytes = read(0,buf,sizeof(buf));
ssize_t bytes = read(0,buf,sizeof(buf));
if(bytes < 0)
{
if(errno == EINTR)