 : (profile.) ( nodes depth -- )
     [ by-total-time ] dip '[ _ (profile-node.) ] assoc-each ;
 
+PRIVATE>
+
 : profile-heading. ( -- )
     "depth   time ms  GC %  JIT %  FFI %   FT %" print ;
    ! NNNN XXXXXXX.X XXXX.X XXXX.X XXXX.X XXXX.X | | foo

: trim-root ( root -- root' )
    dup redundant-root-node? [ children>> values first trim-root ] when ;

:: (top-down) ( profile-data depth -- tree )
    profile-data collect-threads
    [ [ depth collect-tops ] <profile-root-node> trim-root ] assoc-map ;

: top-down* ( profile-data -- tree )
    0 (top-down) ;

: top-down ( -- tree )
    most-recent-profile-data top-down* ;

:: counts+at ( key assoc sample -- )
    key assoc [ zero-counts or sample sample-counts-slice v+ ] change-at ;

: foreign-thread-time ( -- n )
    most-recent-profile-data foreign-thread-time* ;

TUPLE: profile-node
    total-time gc-time jit-time foreign-time foreign-thread-time children
    depth ;

<PRIVATE

: collect-threads ( samples -- by-thread )
    [ sample-thread ] collect-by ;

: time-per-thread ( -- n )
    most-recent-profile-data collect-threads [ total-time* ] assoc-map ;

: leaf-callstack? ( callstack -- ? )
    [ ignore-word? ] all? ;

CONSTANT: zero-counts { 0 0 0 0 0 }

: sum-counts ( samples -- times )
    zero-counts [ sample-counts-slice v+ ] reduce ;

: <profile-node> ( times children depth -- node )
    [ 5 firstn [ samples>time ] 5 napply ] 2dip profile-node boa ;

: <profile-root-node> ( samples collector-quot -- node )
    [ sum-counts ] swap bi 0 <profile-node> ; inline

:: (collect-subtrees) ( samples max-depth depth child-quot: ( samples -- child ) -- children )
    max-depth depth > [
        samples [ sample-callstack leaf-callstack? not ] filter
        [ f ] [ child-quot call ] if-empty
    ] [ f ] if ; inline

:: collect-tops ( samples max-depth depth -- node )
    samples [ unclip-callstack ] collect-pairs [
        [ sum-counts ]
        [ max-depth depth [ max-depth depth 1 + collect-tops ] (collect-subtrees) ] bi
        depth <profile-node>
    ] assoc-map ;

: redundant-root-node? ( assoc -- ? )
