basis: Try to fix the build. My profiler is hanging, but I can't figure out why. See if the build farm has the same is

sue.
db4
Doug Coleman 2012-11-27 12:47:05 -06:00
parent 5b5ee71a6a
commit 516549b52c
3 changed files with 15 additions and 16 deletions

View File

@ -134,42 +134,41 @@ HELP: sorted-histogram
HELP: sequence>assoc
{ $values
{ "seq" sequence } { "map-quot" { $quotation "( x -- ..y )" } } { "insert-quot" { $quotation "( ..y assoc -- )" } } { "exemplar" "an exemplar assoc" }
{ "seq" sequence } { "map-quot" $quotation } { "insert-quot" quotation } { "exemplar" "an exemplar assoc" }
{ "assoc" assoc }
}
{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a newly created " { $snippet "assoc" } ". The " { $snippet "map-quot" } " gets passed each element from the sequence. Its outputs are passed along with the assoc being constructed to the " { $snippet "insert-quot" } ", which can modify the assoc in response." }
{ $examples
{ $example "! Iterate over a sequence and increment the count at each element"
"! The first quotation has stack effect ( key -- key ), a no-op"
"USING: assocs prettyprint math.statistics ;"
"\"aaabc\" [ ] [ inc-at ] H{ } sequence>assoc ."
"USING: assocs prettyprint kernel math.statistics ;"
"\"aaabc\" [ ] [ nip inc-at ] H{ } sequence>assoc ."
"H{ { 97 3 } { 98 1 } { 99 1 } }"
}
} ;
HELP: sequence>assoc!
{ $values
{ "assoc" assoc } { "seq" sequence } { "map-quot" { $quotation "( x -- ..y )" } } { "insert-quot" { $quotation "( ..y assoc -- )" } }
}
{ "assoc" assoc } { "seq" sequence } { "map-quot" quotation } { "insert-quot" quotation } }
{ $description "Iterates over a sequence, allowing elements of the sequence to be added to an existing " { $snippet "assoc" } ". The " { $snippet "map-quot" } " gets passed each element from the sequence. Its outputs are passed along with the assoc being constructed to the " { $snippet "insert-quot" } ", which can modify the assoc in response." }
{ $examples
{ $example "! Iterate over a sequence and add the counts to an existing assoc"
"USING: assocs prettyprint math.statistics kernel ;"
"H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ ] [ inc-at ] sequence>assoc! ."
"H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ ] [ nip inc-at ] sequence>assoc! ."
"H{ { 97 5 } { 98 2 } { 99 1 } }"
}
} ;
HELP: sequence>hashtable
{ $values
{ "seq" sequence } { "map-quot" { $quotation "( x -- ..y )" } } { "insert-quot" { $quotation "( ..y assoc -- )" } }
{ "seq" sequence } { "map-quot" quotation } { "insert-quot" quotation }
{ "hashtable" hashtable }
}
{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a newly created hashtable. The " { $snippet "map-quot" } " gets passed each element from the sequence. Its outputs are passed along with the assoc being constructed to the " { $snippet "insert-quot" } ", which can modify the assoc in response." }
{ $examples
{ $example "! Count the number of times an element occurs in a sequence"
"USING: assocs prettyprint math.statistics ;"
"\"aaabc\" [ ] [ inc-at ] sequence>hashtable ."
"USING: assocs kernel prettyprint math.statistics ;"
"\"aaabc\" [ ] [ nip inc-at ] sequence>hashtable ."
"H{ { 97 3 } { 98 1 } { 99 1 } }"
}
} ;

View File

@ -241,14 +241,14 @@ PRIVATE>
: normalized-histogram ( seq -- alist )
[ histogram ] [ length ] bi '[ _ / ] assoc-map ;
: collect-pairs ( seq quot: ( x y -- v k y ) -- hashtable )
[ [ nip ] dip push-at ] sequence>hashtable ; inline
: collect-at ( seq quot -- hashtable )
[ push-at ] sequence>hashtable ; inline
: collect-index-by ( seq quot: ( x -- x' ) -- hashtable )
[ swap dup ] prepose collect-pairs ; inline
: collect-index-by ( seq quot -- hashtable )
[ swap ] prepose collect-at ; inline
: collect-by ( seq quot: ( x -- x' ) -- hashtable )
[ dup ] prepose collect-pairs ; inline
: collect-by ( seq quot -- hashtable )
[ drop dup ] prepose collect-at ; inline
: equal-probabilities ( n -- array )
dup recip <array> ; inline

View File

@ -98,7 +98,7 @@ CONSTANT: zero-counts { 0 0 0 0 0 }
] [ f ] if ; inline
:: collect-tops ( samples max-depth depth -- node )
samples [ unclip-callstack ] collect-pairs [
samples [ drop unclip-callstack ] collect-at [
[ sum-counts ]
[ max-depth depth [ max-depth depth 1 + collect-tops ] (collect-subtrees) ] bi
depth <profile-node>