trees with pointers to parents & memory gobbling

[Colin Runciman]

This is a multi-part message in MIME format.
--------------050304090107090307050801
Content-Type: text/plain; charset=us-ascii; format=flowed
Content-Transfer-Encoding: 7bit

Hal Daume III wrote:

>I have a datatype which (simplified) looks like:
>
>data FBTree a = FBLeaf (Maybe (FBTree a)) a | FBBranch (Maybe (FBTree
>a)) (FBTree a) (FBTree a)
>
>is basically a tree with Maybe a parent node.  however, unlike the nice
>non-haskell equivalent, they tend to eat up memory as you traverse
>them.
>
Oh no they don't!  :-)

There is no space leak in the tree-traversal part of Hal's program, the 
problem
is that the program builds an iterated sequence of ever-deeper compositions
of findRoot and findLeftMostChild without demanding any of their results
until the very end of the sequence.

Quick plug: heap profiling showed me that the problem was with iterate;
the Hat tracing tools showed me that the tree traversal routines work fine.

I attach an amended version of Hal's program which does the 100000 down-up
traversals without leaking.

Regards
Colin R


--------------050304090107090307050801
Content-Type: text/plain;
 name="FBTree.hs"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
 filename="FBTree.hs"

data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving (Eq, Show)

data FBTree a =
    FBLeaf (Maybe (FBTree a)) a 
  | FBBranch (Maybe (FBTree a)) (FBTree a) (FBTree a)

normalFBTree (FBLeaf _ _) = True
normalFBTree (FBBranch _ _ _) = True

instance Show a => Show (FBTree a) where
  showsPrec i = showsPrec i . unFBTree

mkFBTree = mkFBTree' Nothing
    where
    mkFBTree' par (Leaf a) = FBLeaf par a
    mkFBTree' par (Branch l r) = this
	where
        this = FBBranch par (mkFBTree' (Just this) l) (mkFBTree' (Just this) r)

unFBTree (FBLeaf _ a) = Leaf a
unFBTree (FBBranch _ l r) = Branch (unFBTree l) (unFBTree r)

findRoot (FBLeaf (Just par) _) = findRoot par
findRoot (FBBranch (Just par) _ _) = findRoot par
findRoot t = t

findLeftMostChild (FBBranch _ l _) = findLeftMostChild l
findLeftMostChild t = t

tree =
  Branch
    (Branch 
      (Branch
        (Branch
	  (Branch (Leaf 'h') (Branch (Leaf 'a') (Leaf 's')))
          (Leaf 'k'))
        (Branch (Leaf 'e') (Leaf 'l')))
      (Leaf 'l'))
    (Leaf '!')

fbtree = mkFBTree tree

updown n t | normalFBTree t =
  if n > 0 then updown (n-1) (findLeftMostChild (findRoot t))
  else t

main = print (updown 100000 fbtree)

--------------050304090107090307050801--