From 0fda643ab1e35c43a9b94b67f0138e9499c3f72e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 11 Apr 2009 20:30:51 -0500 Subject: [PATCH] Optimizing string>number --- basis/hints/hints.factor | 4 +- .../transforms/transforms.factor | 86 ++++++++++++------- core/math/parser/parser-tests.factor | 10 +-- core/math/parser/parser.factor | 74 ++++++++-------- 4 files changed, 103 insertions(+), 71 deletions(-) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 2534e0121f..d44bf92bf4 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -3,7 +3,7 @@ USING: parser words definitions kernel sequences assocs arrays kernel.private fry combinators accessors vectors strings sbufs byte-arrays byte-vectors io.binary io.streams.string splitting -math generic generic.standard generic.standard.engines classes +math math.parser generic generic.standard generic.standard.engines classes hashtables ; IN: hints @@ -118,6 +118,8 @@ SYNTAX: HINTS: \ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop +\ base> { string fixnum } "specializer" set-word-prop + M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index c2b348f5f1..dfa46be7e2 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors arrays kernel kernel.private combinators.private -words sequences generic math math.order namespaces make quotations assocs -combinators combinators.short-circuit classes.tuple +words sequences generic math math.order namespaces make quotations +assocs combinators combinators.short-circuit classes.tuple classes.tuple.private effects summary hashtables classes generic sets definitions generic.standard slots.private continuations locals -generalizations stack-checker.backend stack-checker.state -stack-checker.visitor stack-checker.errors stack-checker.values -stack-checker.recursive-state ; +sequences.private generalizations stack-checker.backend +stack-checker.state stack-checker.visitor stack-checker.errors +stack-checker.values stack-checker.recursive-state ; IN: stack-checker.transforms : give-up-transform ( word -- ) @@ -106,40 +106,68 @@ IN: stack-checker.transforms ] [ drop f ] if ] 1 define-transform -! Membership testing -CONSTANT: bit-member-max 256 +! Fast at for integer maps +CONSTANT: lookup-table-at-max 256 -: bit-member? ( seq -- ? ) +: lookup-table-at? ( assoc -- ? ) #! Can we use a fast byte array test here? { - [ length 4 > ] - [ [ integer? ] all? ] - [ [ 0 bit-member-max between? ] any? ] + [ assoc-size 4 > ] + [ values [ ] all? ] + [ keys [ integer? ] all? ] + [ keys [ 0 lookup-table-at-max between? ] all? ] } 1&& ; -: bit-member-seq ( seq -- flags ) - [ supremum 1+ ] keep '[ _ member? 1 0 ? ] B{ } map-as ; +: lookup-table-seq ( assoc -- table ) + [ keys supremum 1+ ] keep '[ _ at ] { } map-as ; -: bit-member-quot ( seq -- newquot ) - bit-member-seq +: lookup-table-quot ( seq -- newquot ) + lookup-table-seq '[ - _ { - { [ over fixnum? ] [ ?nth 1 eq? ] } - { [ over bignum? ] [ ?nth 1 eq? ] } - [ 2drop f ] - } cond + _ over integer? [ + 2dup bounds-check? [ + nth-unsafe dup >boolean + ] [ 2drop f f ] if + ] [ 2drop f f ] if ] ; -: member-quot ( seq -- newquot ) - dup bit-member? [ - bit-member-quot - ] [ - dup length 4 <= [ - [ drop f ] swap - [ literalize [ t ] ] { } map>assoc linear-case-quot +: fast-lookup-table-at? ( assoc -- ? ) + values { + [ [ integer? ] all? ] + [ [ 0 254 between? ] all? ] + } 1&& ; + +: fast-lookup-table-seq ( assoc -- table ) + lookup-table-seq [ 255 or ] B{ } map-as ; + +: fast-lookup-table-quot ( seq -- newquot ) + fast-lookup-table-seq + '[ + _ over integer? [ + 2dup bounds-check? [ + nth-unsafe dup 255 eq? [ drop f f ] [ t ] if + ] [ 2drop f f ] if + ] [ 2drop f f ] if + ] ; + +: at-quot ( assoc -- quot ) + dup lookup-table-at? [ + dup fast-lookup-table-at? [ + fast-lookup-table-quot ] [ - unique [ key? ] curry + lookup-table-quot ] if + ] [ drop f ] if ; + +\ at* [ at-quot ] 1 define-transform + +! Membership testing +: member-quot ( seq -- newquot ) + dup length 4 <= [ + [ drop f ] swap + [ literalize [ t ] ] { } map>assoc linear-case-quot + ] [ + unique [ key? ] curry ] if ; \ member? [ @@ -170,4 +198,4 @@ CONSTANT: bit-member-max 256 \ shuffle [ shuffle-mapping nths-quot -] 1 define-transform \ No newline at end of file +] 1 define-transform diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 0fb2559854..c655965e35 100644 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -95,17 +95,17 @@ unit-test [ 1 0 >base ] must-fail [ 1 -1 >base ] must-fail -[ "0.0/0.0" ] [ 0.0 0.0 / number>string ] unit-test +[ "0/0." ] [ 0.0 0.0 / number>string ] unit-test -[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test +[ "1/0." ] [ 1.0 0.0 / number>string ] unit-test -[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test +[ "-1/0." ] [ -1.0 0.0 / number>string ] unit-test [ t ] [ "0/0." string>number fp-nan? ] unit-test -[ 1.0/0.0 ] [ "1/0." string>number ] unit-test +[ 1/0. ] [ "1/0." string>number ] unit-test -[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test +[ -1/0. ] [ "-1/0." string>number ] unit-test [ "-0.0" ] [ -0.0 number>string ] unit-test diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 0d8f0c0b08..0a637c2eab 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math.private namespaces sequences strings -arrays combinators splitting math assocs make ; +USING: kernel math.private namespaces sequences sequences.private +strings arrays combinators splitting math assocs make ; IN: math.parser : digit> ( ch -- n ) @@ -28,13 +28,19 @@ IN: math.parser { CHAR: d 13 } { CHAR: e 14 } { CHAR: f 15 } - } at ; + } at 255 or ; inline : string>digits ( str -- digits ) - [ digit> ] { } map-as ; + [ digit> ] B{ } map-as ; inline -: digits>integer ( seq radix -- n ) - 0 swap [ swapd * + ] curry reduce ; +: (digits>integer) ( valid? accum digit radix -- valid? accum ) + 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline + +: each-digit ( seq radix quot -- n/f ) + [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline + +: digits>integer ( seq radix -- n/f ) + [ (digits>integer) ] each-digit ; inline DEFER: base> @@ -43,6 +49,9 @@ DEFER: base> SYMBOL: radix SYMBOL: negative? +: string>natural ( seq radix -- n/f ) + [ [ digit> ] dip (digits>integer) ] each-digit ; inline + : sign ( -- str ) negative? get "-" "+" ? ; : with-radix ( radix quot -- ) @@ -54,37 +63,30 @@ SYMBOL: negative? sign split1 [ (base>) ] dip dup [ (base>) ] [ drop 0 swap ] if ; -: string>ratio ( str -- a/b ) - "-" ?head dup negative? set swap - "/" split1 (base>) [ whole-part ] dip - 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ; +: string>ratio ( str radix -- a/b ) + [ + "-" ?head dup negative? set swap + "/" split1 (base>) [ whole-part ] dip + 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if + ] with-radix ; -: valid-digits? ( seq -- ? ) - { - { [ dup empty? ] [ drop f ] } - { [ f over memq? ] [ drop f ] } - [ radix get [ < ] curry all? ] - } cond ; - -: string>integer ( str -- n/f ) - "-" ?head swap - string>digits dup valid-digits? - [ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ; +: string>integer ( str radix -- n/f ) + over first-unsafe CHAR: - = [ + [ rest-slice ] dip string>natural dup [ neg ] when + ] [ + string>natural + ] if ; inline PRIVATE> : base> ( str radix -- n/f ) - [ - CHAR: / over member? [ - string>ratio - ] [ - CHAR: . over member? [ - string>float - ] [ - string>integer - ] if - ] if - ] with-radix ; + over empty? [ 2drop f ] [ + over [ "/." member? ] find nip { + { CHAR: / [ string>ratio ] } + { CHAR: . [ drop string>float ] } + [ drop string>integer ] + } case + ] if ; : string>number ( str -- n/f ) 10 base> ; : bin> ( str -- n/f ) 2 base> ; @@ -147,9 +149,9 @@ M: ratio >base M: float >base drop { - { [ dup fp-nan? ] [ drop "0.0/0.0" ] } - { [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] } - { [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] } + { [ dup fp-nan? ] [ drop "0/0." ] } + { [ dup 1/0. = ] [ drop "1/0." ] } + { [ dup -1/0. = ] [ drop "-1/0." ] } { [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] } [ float>string fix-float ] } cond ;