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

Speeding up xml.literals by 3x using code generation

db4
Daniel Ehrenberg 2009-02-04 17:29:35 -06:00
parent c7a070ba8e
commit fa0d5de2e4
2 changed files with 75 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/xml/literals/literals-tests.factor
View File

@ -55,7 +55,7 @@ IN: xml.literals.tests
[ "<x></x>" ] [ f [XML <x><-></x> XML] xml>string ] unit-test [ "<x></x>" ] [ f [XML <x><-></x> XML] xml>string ] unit-test
\ <XML must-infer \ <XML must-infer
[ { } "" interpolate-xml ] must-infer [ [XML <-> XML] ] must-infer
[ [XML <foo><-></foo> <bar val=<->/> XML] ] must-infer [ [XML <foo><-></foo> <bar val=<->/> XML] ] must-infer
[ xml-chunk ] [ [ [XML <foo/> XML] ] first class ] unit-test [ xml-chunk ] [ [ [XML <foo/> XML] ] first class ] unit-test

113
basis/xml/literals/literals.factor
View File

@ -3,11 +3,34 @@
USING: xml xml.state kernel sequences fry assocs xml.data USING: xml xml.state kernel sequences fry assocs xml.data
accessors strings make multiline parser namespaces macros accessors strings make multiline parser namespaces macros
sequences.deep generalizations words combinators sequences.deep generalizations words combinators
math present arrays unicode.categories ; math present arrays unicode.categories locals.backend
quotations ;
IN: xml.literals IN: xml.literals
<PRIVATE <PRIVATE
: each-attrs ( attrs quot -- )
[ values [ interpolated? ] filter ] dip each ; inline
: (each-interpolated) ( item quot: ( interpolated -- ) -- )
{
{ [ over interpolated? ] [ call ] }
{ [ over tag? ] [ [ attrs>> ] dip each-attrs ] }
{ [ over attrs? ] [ each-attrs ] }
{ [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
[ 2drop ]
} cond ; inline recursive
: each-interpolated ( xml quot -- )
'[ _ (each-interpolated) ] deep-each ; inline
: has-interpolated? ( xml -- ? )
! If this becomes a performance problem, it can be improved
f swap [ 2drop t ] each-interpolated ;
: when-interpolated ( xml quot -- genquot )
[ dup has-interpolated? ] dip [ '[ _ swap ] ] if ; inline
: string>chunk ( string -- chunk ) : string>chunk ( string -- chunk )
t interpolating? [ string>xml-chunk ] with-variable ; t interpolating? [ string>xml-chunk ] with-variable ;
@ -16,17 +39,34 @@ IN: xml.literals
DEFER: interpolate-sequence DEFER: interpolate-sequence
: interpolate-attrs ( table attrs -- attrs ) : get-interpolated ( interpolated -- quot )
swap '[ var>> '[ [ _ swap at ] keep ] ;
dup interpolated?
[ var>> _ at dup [ present ] when ] when
] assoc-map [ nip ] assoc-filter ;
: interpolate-tag ( table tag -- tag ) : ?present ( object -- string )
[ nip name>> ] dup [ present ] when ;
[ attrs>> interpolate-attrs ]
[ children>> [ interpolate-sequence ] [ drop f ] if* ] 2tri : interpolate-attr ( key value -- quot )
<tag> ; dup interpolated?
[ get-interpolated '[ _ swap @ [ ?present 2array ] dip ] ]
[ 2array '[ _ swap ] ] if ;
: filter-nulls ( assoc -- newassoc )
[ nip ] assoc-filter ;
: interpolate-attrs ( attrs -- quot )
[
[ [ interpolate-attr ] { } assoc>map [ ] join ]
[ assoc-size ] bi
'[ @ _ swap [ narray filter-nulls <attrs> ] dip ]
] when-interpolated ;
: interpolate-tag ( tag -- quot )
[
[ name>> ]
[ attrs>> interpolate-attrs ]
[ children>> interpolate-sequence ] tri
'[ _ swap @ @ [ <tag> ] dip ]
] when-interpolated ;
GENERIC: push-item ( item -- ) GENERIC: push-item ( item -- )
M: string push-item , ; M: string push-item , ;
@ -37,30 +77,33 @@ M: sequence push-item
M: number push-item present , ; M: number push-item present , ;
M: xml-chunk push-item % ; M: xml-chunk push-item % ;
GENERIC: interpolate-item ( table item -- ) : concat-interpolate ( array -- newarray )
M: object interpolate-item nip , ; [ [ push-item ] each ] { } make ;
M: tag interpolate-item interpolate-tag , ;
M: interpolated interpolate-item
var>> swap at push-item ;
: interpolate-sequence ( table seq -- seq ) GENERIC: interpolate-item ( item -- quot )
[ [ interpolate-item ] with each ] { } make ; M: object interpolate-item [ swap ] curry ;
M: tag interpolate-item interpolate-tag ;
M: interpolated interpolate-item get-interpolated ;
: interpolate-xml-doc ( table xml -- xml ) : interpolate-sequence ( seq -- quot )
(clone) [ interpolate-tag ] change-body ; [
[ [ interpolate-item ] map concat ]
[ length ] bi
'[ @ _ swap [ narray concat-interpolate ] dip ]
] when-interpolated ;
: (each-interpolated) ( item quot: ( interpolated -- ) -- ) GENERIC: [interpolate-xml] ( xml -- quot )
{
{ [ over interpolated? ] [ call ] }
{ [ over tag? ] [
[ attrs>> values [ interpolated? ] filter ] dip each
] }
{ [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
[ 2drop ]
} cond ; inline recursive
: each-interpolated ( xml quot -- ) M: xml [interpolate-xml]
'[ _ (each-interpolated) ] deep-each ; inline dup body>> interpolate-tag
'[ _ (clone) swap @ drop >>body ] ;
M: xml-chunk [interpolate-xml]
interpolate-sequence
'[ @ drop <xml-chunk> ] ;
MACRO: interpolate-xml ( xml -- quot )
[interpolate-xml] ;
: number<-> ( doc -- dup ) : number<-> ( doc -- dup )
0 over [ 0 over [
@ -69,14 +112,6 @@ M: interpolated interpolate-item
] unless drop ] unless drop
] each-interpolated drop ; ] each-interpolated drop ;
GENERIC: interpolate-xml ( table xml -- xml )
M: xml interpolate-xml
interpolate-xml-doc ;
M: xml-chunk interpolate-xml
interpolate-sequence <xml-chunk> ;
: >search-hash ( seq -- hash ) : >search-hash ( seq -- hash )
[ dup search ] H{ } map>assoc ; [ dup search ] H{ } map>assoc ;