path: root/testsuite/tests/programs/seward-space-leak/Main.lhs

{-

This test runs for a Long Time (10mins for the registerised version)
and allocates 3.4Gbytes.  It also hammers the GC; with -H16M it spend
40% of the time in the GC.



Date: Sun, 25 Oct 92 16:38:12 GMT
From: Julian Seward (DRL PhD) <sewardj@uk.ac.man.cs>
Message-Id: <9210251638.AA21153@r6b.cs.man.ac.uk>
To: partain@uk.ac.glasgow.dcs
Subject: Space consumption in 0.09 produced binary
Cc: sewardj@uk.ac.man.cs, simonpj@uk.ac.glasgow.dcs

Folks,

At the risk of wasting even more of your valuable time, here is
a small problem I ran into:

The program (XXXX.lhs) listed below runs in constant space (about 4k)
in both Gofer and hbc 0.998.5.  When compiled with 0.09, it runs out
of heap in seconds (4 meg heap).

The program builds a gigantic list of things (CDSs, in fact), I believe
at least 100,000 long, and searches to find out if a particular CDS is
present.  The CDS list is generated lazily, and should be thrown away
as it goes, until apply_cds is found (see the bottom of the listing).
Gofer and hbc behave as expected, but I suspect ghc is holding onto 
the complete list unnecessarily.

I include XXXX.stat as supporting evidence.

Jules

(compiled hence:
ghc9 -v -O -gc-ap -flet-float -Rgc-stats -Rmax-heapsize 14M -o XXXX XXXX.lhs
)

-----------------------------------------------------------------------

XXXX +RTS -S 

Collector: APPEL  HeapSize: 4,194,304 (bytes)

  Alloc   Live   Live   Astk   Bstk OldGen   GC    GC     TOT     TOT  Page Flts  Collec  Resid
  bytes   bytes    %   bytes  bytes  roots  user  elap    user    elap   GC  TOT   tion   %heap
2097108 1119672  53.4     52    132 1119616  0.33  0.35    1.01    1.15    0    0   Minor
1537300  918200  59.7     48    128 918188  0.26  0.31    1.76    1.95    0    0   Minor
1078216  654212  60.7     56    160 652612  0.19  0.18    2.29    2.46    0    0   Minor
 751108  442140  58.9     52    108 442140  0.12  0.12    2.64    2.84    0    0   Minor
3134224 2935044  93.6     52    108         1.49  1.50    4.13    4.34    0    0  *MAJOR* 70.0%
 629612  376848  59.9     52    132 376836  0.11  0.11    4.44    4.64    0    0   Minor
 441184  265100  60.1     96    200 264416  0.08  0.07    4.66    4.86    0    0   Minor
 308640  204072  66.1     56    160 199476  0.06  0.05    4.81    5.01    0    0   Minor
3781064 3687092  97.5     56    160         1.81  1.85    6.62    6.86    0    0  *MAJOR* 87.9%
 253600  160584  63.3     52    108 160584  0.05  0.04    6.75    6.98    0    0   Minor
 173312  112344  64.8     56    160 110304  0.03  0.03    6.83    7.07    0    0   Minor
 117128   77260  66.0     36    140  74112  0.01  0.02    6.88    7.13    0    0   Minor
4037280 3985284  98.7     36    140         1.96  1.98    8.85    9.11    0    0  *MAJOR* 95.0%

-------------------------------------------------------------------------
-}

> module Main where

> import Prelude hiding (traverse)

%============================================================
%============================================================

\section{A CDS interpreter}

\subsection{Declarations}

Second attempt at a CDS interpreter.  Should do
loop detection correctly in the presence of higher order functions.

The types allowed are very restrictive at the mo.

> data Type = Two
>           | Fn [Type]

Now, we also have to define CDSs and selectors.
\begin{itemize}
\item
@Empty@ is a non-legitimate CDS, denoting no value at all.  We use
it as an argument in calls to other CDSs denoting that 
the particular argument is not really supplied.
\item
@Par@ is similarly a non-legit CDS, but useful for constructing
selectors.  It simply denotes the parameter specified (note
parameter numbering starts at 1).
\item
@Zero@ and @One@ are constant valued CDSs.
\item 
@Call@.
Calls to other functions are done with @Call@, which expects
the callee to return @Zero@ or @One@, and selects the relevant
branch.  The @Tag@s identify calls in the dependency list.
Although a @Call@ is a glorified @Case@ statement, the only allowed
return values are @Zero@ and @One@.  Hence the @CDS CDS@ continuations
rather than the more comprehensive @(AList Return CDS)@.
We require arguments to be fully disassembled.
\item @Case@
Case selectors can only be of the following form:
\begin{itemize}
\item
   @[Par n]@  if the n'th parameter is not a function space.
\item
   @[Par n, v1 ... vn]@ if the n'th parameter is a function space of
                      arity n.  The v's may be only @Empty@, @Zero@,
                      @One@, or @Par n@.
\end{itemize}
\end{itemize}
We also have a @Magic@ CDS which is a load of mumbo-jumbo for use
in enumeration of and compilation to CDSs.  Of no significance 
whatever here.

> data CDS = Empty
>          | Par Int
>          | Zero
>          | One
>          | Case [CDS] (AList Return CDS)
>          | Call String Tag [CDS] CDS CDS
>          | Magic
>
> type AList a b = [(a, b)]
>
> type Tag = Int

> instance Eq CDS where
>    (Par n1) == (Par n2) = n1 == n2
>    Zero == Zero = True
>    One == One = True
>    (Case sels1 rets1) == (Case sels2 rets2) = sels1 == sels2 && 
>                                               rets1 == rets2
>    (Call f1 t1 sels1 a1 b1) == (Call f2 t2 sels2 a2 b2)
>       = f1 == f2 && t1 == t2 && sels1 == sels2 && a1 == a2 && b1 == b2
>    Magic == Magic = True
>    _ == _ = False


A @Return@ is a temporary thing used to decide which way to go at
a @Case@ statement.

> data Return = RZero
>             | ROne
>             | RP Int

> instance Eq Return where
>    RZero == RZero  = True
>    ROne == ROne = True
>    (RP p1) == (RP p2) = p1 == p2
>    _ == _ = False

We need a code store, which gives out a fresh instance of a CDS
as necessary.  ToDo: Need to rename call sites?  I don't think so.

> type Code = AList String CDS

%============================================================
%============================================================

\subsection{The evaluator}
Main CDS evaluator takes
\begin{itemize}
\item the code store
\item the dependency list, a list of @Tag@s of calls which are
      currently in progress
\item the current arguments
\item the CDS fragment currently being worked on
\end{itemize}

> type Depends = [Tag]
>
> eval :: Code -> Depends -> [CDS] -> CDS -> CDS

Evaluating a constant valued CDS is trivial.  There may be arguments
present -- this is not a mistake.

> eval co de args Zero = Zero
> eval co de args One  = One

Making a call is also pretty simple, because we assume
that all non-functional arguments are presented as literals,
and all functional values have already been dismantled (unless
they are being passed unchanged in the same position in a recursive call
to the same function, something for the compiler to detect).

Two other issues are at work here.  Guided by the selectors,
we copy the args to make a set of args for the call.  However, if an
copied arg is Empty, the call cannot proceed, so we return the CDS as-is.
Note that an Empty *selector* is not allowed in a Call (although it is
in a Case).

The second issue arises if the call can go ahead.  We need to check the
tag on the call just about to be made with the tags of calls already in 
progress (in de) to see if we are looping.  If the tag has already been
encountered, the result of the call is Zero, so the Zero alternative is
immediately selected.

> eval co de args cds@(Call fname tag params alt0 alt1)
>   = let (copied_an_empty, callee_args) = copy_args args params
>         augmented_de      = tag : de
>         callee_code       = lkup co fname
>         callee_result     = eval co augmented_de callee_args callee_code
>         been_here_before  = tag `elem` de
>     in
>         if    copied_an_empty
>         then  cds
>         else
>         if    been_here_before
>         then  eval co augmented_de args alt0
>         else  case callee_result of
>                  Zero -> eval co de args alt0
>                  One  -> eval co de args alt1
>                  _    -> error "Bad callee result"

Case really means "evaluate".  

   - make sure first selector is non-Empty.  If so, return CDS as-is.

   - Copy other args.  If Empty is *copied*, return CDS as-is.
     Otherwise, call evaluator and switch on head of result.

Note about switching on the head of the result.  We expect to see
*only* the following as results:

   Zero
   One
   Case [Param m, rest]

in which case switching is performed on

   Zero
   One
   Case (Param m)

ToDo: what happens if a Call turns up ???

> eval co de args cds@(Case ((Par n):ps) alts)
>   = let (copied_an_empty, new_args) = copy_args args ps
>         functional_param = args !! (n-1)
>     in  if    functional_param == Empty || 
>               copied_an_empty
>         then  cds
>         else  eval co de args 
>                    (lkup alts (get_head 
>                                    (eval co de new_args functional_param)))

Auxiliary for evaluating Case expressions.

> get_head Zero                  = RZero
> get_head One                   = ROne
> get_head (Case ((Par n):_) _)  = RP n

Copy args based on directions in a list of selectors.
Also returns a boolean which is True if an Empty has been
*copied*.  An Empty *selector* simply produces Empty in the
corresponding output position.

> copy_args :: [CDS] -> [CDS] -> (Bool, [CDS])
>
> copy_args args params
>   = case cax False params [] of
>        (empty_copied, res) -> (empty_copied, reverse res)
>     where
>        cax empty [] res = (empty, res)
>        cax empty (Zero:ps) res = cax empty ps (Zero:res)
>        cax empty (One:ps) res = cax empty ps (One:res)
>        cax empty (Empty:ps) res = cax empty ps (Empty:res)
>        cax empty ((Par n):ps) res
>           = case args !! (n-1) of
>                Empty -> cax True ps (Empty:res)
>                other -> cax empty ps (other:res)

> lkup env k = head ( [v | (kk,v) <- env, kk == k] ++ 
>                       [error ( "Can't look up " ) ] )

%============================================================
%============================================================

%============================================================
%============================================================

Something to make running tests easier ...

> eval0 fname args = eval test [] args (lkup test fname)
>
> two = [Zero, One]

Now for some test data ...

> test
>  =
>  [
>    ("add",     add_cds),
>    ("apply",   apply_cds),
>    ("k0",      k0_cds),
>    ("id",      id_cds),
>    ("k1",      k1_cds),
>    ("kkkr",    kkkr_cds),
>    ("kkkl",    kkkl_cds),
>    ("apply2",  apply2_cds)
>  ]
>

Constant Zero function.

> k0_cds
>   = Case [Par 1]
>         [(RZero, Zero),
>          (ROne,  Zero)]
>

Identity.

> id_cds
>   = Case [Par 1]
>         [(RZero, Zero),
>          (ROne,  One)]

Constant One function.

> k1_cds
>   = Case [Par 1]
>         [(RZero, One),
>          (ROne,  One)]

Strict in both of two arguments, for example (+).

> add_cds
>  =    Case [Par 1]
>          [(RZero, Case [Par 2]
>                        [(RZero, Zero),
>                         (ROne,  Zero)
>                        ]),
>           (ROne, Case [Par 2]
>                       [(RZero, Zero),
>                        (ROne, One)
>                       ])
>          ]

The (in)famous apply function.

> apply_cds
>  = Case [Par 1, Empty]
>        [(RZero, Zero),
>         (ROne, One),
>         (RP 1, Case [Par 2]
>                    [(RZero, Case [Par 1, Zero]
>                                 [(RZero, Zero),
>                                  (ROne, One)]),
>                     (ROne,  Case [Par 1, One]
>                                 [(RZero, Zero),
>                                  (ROne, One)])
>                    ])
>        ]

The inverse K-combinator: K x y = y

> kkkr_cds
>  = Case [Par 2]
>        [(RZero, Zero),
>         (ROne, One)
>        ]

The standard K-combinator, defined thus: K x y = K-inverse y x.
Purpose of this is to test function calling.

> kkkl_cds
>  = Case [Par 1]
>        [(RZero, Case [Par 2]
>                     [(RZero, Call "kkkr" 101 [Zero, Zero] Zero One),
>                      (ROne,  Call "kkkr" 102 [One, Zero]  Zero One)
>                     ]),
>         (ROne,  Case [Par 2]
>                     [(RZero, Call "kkkr" 103 [Zero, One]  Zero One),
>                      (ROne,  Call "kkkr" 104 [One, One]   Zero One)
>                     ])
>        ]

Apply a 2-argument function (apply2 f x y = f x y).

> apply2_cds
>  = Case [Par 1, Empty, Empty]
>        [(RZero, Zero),
>         (ROne, One),
>         (RP 1, Case [Par 2]
>               [(RZero, Case [Par 1, Zero, Empty]
>                            [(RZero, Zero),
>                             (ROne, One),
>                             (RP 2, Case [Par 3]
>                                        [(RZero, Case [Par 1, Zero, Zero]
>                                                [(RZero, Zero),
>                                                 (ROne, One)]),
>                                         (ROne, Case [Par 1, Zero, One]
>                                                [(RZero, Zero),
>                                                 (ROne, One)])
>                                        ])
>                            ]),
>                (ROne,  Case [Par 1, One, Empty]
>                            [(RZero, Zero),
>                             (ROne, One),
>                             (RP 2, Case [Par 3]
>                                        [(RZero, Case [Par 1, One, Zero]
>                                                [(RZero, Zero),
>                                                 (ROne, One)]),
>                                         (ROne, Case [Par 1, One, One]
>                                                [(RZero, Zero),
>                                                 (ROne, One)])
>                                        ])
>                            ])
>               ]),
>         (RP 2, Case [Par 3]
>               [(RZero, Case [Par 1, Empty, Zero]
>                            [(RZero, Zero),
>                             (ROne, One),
>                             (RP 1, Case [Par 2]
>                                        [(RZero, Case [Par 1, Zero, Zero]
>                                                [(RZero, Zero),
>                                                 (ROne, One)]),
>                                         (ROne, Case [Par 1, One, Zero]
>                                                [(RZero, Zero),
>                                                 (ROne, One)])
>                                        ])
>                            ]),
>                (ROne,  Case [Par 1, Empty, One]
>                            [(RZero, Zero),
>                             (ROne, One),
>                             (RP 1, Case [Par 2]
>                                        [(RZero, Case [Par 1, Zero, One]
>                                                [(RZero, Zero),
>                                                 (ROne, One)]),
>                                         (ROne, Case [Par 1, One, One]
>                                                [(RZero, Zero),
>                                                 (ROne, One)])
>                                        ])
>                            ])
>               ])
>           ]

Simple, isn't it!

%============================================================
%============================================================

%============================================================
%============================================================

Enumeration of all CDSs of a given type.

Define n-ary branched trees.  These are used to hold the 
possible prefixes of function arguments, something essential
when enumerating higher-order CDSs. ToDo: translate to English

> data NTree a = NLeaf
>              | NBranch a [NTree a]

The enumeration enterprise involves some mutual recursion
when it comes to higher-order functions.  We define the
top-level enumerator function, for trivial cases, hence:

> enumerate :: Type -> [CDS]
>
> enumerate Two = [Zero, One]
> enumerate (Fn ats) = 
>    expand_templates (traverse (length ats) (gen_pfx_trees ats))

Enumerating a function space is tricky.  In summary:

   - Generate the prefix trees for each argument.  
     For non-function arguments this trivial, but for
     function-valued arguments this means a call to the
     enumerator to get all the possible values of the
     (argument) function space.

   - Traverse the prefix trees, generating a series of
     "templates" for functions.

   - Expand each template thus generated into a genuine CDS.
     Each template denotes a group of CDSs, all of
     the same "shape" and differing only in the constants
     they return.  The Magic and RMagic constructors are
     used for these purposes.

Generating prefix trees.  For a Two-argument, is easy:

> gen_pfx_trees :: [Type] -> [NTree [CDS]]
> 
> gen_pfx_trees ts = zipWith gen_pfx_tree ts [1 .. length ts]
>
> gen_pfx_tree :: Type -> Int -> NTree [CDS]
>
> gen_pfx_tree Two n = NBranch [Par n] []

Note all prefixes are missing the initial (Par n) selector ...

For a function arg

   - enumerate each of the *function's* args

   - starting with a selector [Empty, ...., Empty],
     make a tree wherein at each level, branching is 
     achieved by filling in every Empty with every value
     of that argument type.  ToDo: fix this

> gen_pfx_tree (Fn arg_types) n
>   = let number_args = length arg_types
>         enumed_args = map enumerate arg_types
>         initial_sel = take number_args (repeat Empty)
>         init_tree   = NBranch ((Par n):initial_sel) []
>     in
>         expand_pfx_tree number_args number_args n enumed_args init_tree

@expand_pfx_tree@ expands a tree until there are no Emptys
at the leaves.  Its first parameter is the number of Emptys
in the tree it has been given; when zero, expansion is complete.
The second parameter is the number of Emptys in the original
tree (equal to the arity of the function being enumerated).
Third number is the argument number in the top-level function,
needed to make the initial "Par n" selector.
Also needs to carry around the enumeration of the function's
arguments.

> expand_pfx_tree :: Int -> Int -> Int -> [[CDS]] -> NTree [CDS] -> NTree [CDS]
>
> expand_pfx_tree 0 w i enums tree = tree
>
> expand_pfx_tree n w i enums (NBranch sels [])
>   = let indices = [0 .. w - 1]
>         n_minus_1 = n - 1
>         new_sels = concat (map expand_sel indices)
>         expand_sel n
>           = case sels !! (n+1) of
>                Empty -> map (upd (n+1) sels) (enums !! n)
>                other -> []
>         mk_trivial_tree sel = NBranch sel []
>     in
>         NBranch sels (map (expand_pfx_tree n_minus_1 w i enums . mk_trivial_tree) 
>                        new_sels)

> upd :: Int -> [a] -> a -> [a]
> upd 0 (y:ys) x = x:ys
> upd n (y:ys) x = y:upd (n-1) ys x

In the second phase, the prefix trees are traversed to generate
CDS templates (full of Magic, but no Zero or One).
The first arg is the number of arguments, and the
second the prefix trees for each argument.

> traverse :: Int -> [NTree [CDS]] -> [CDS]

Each pfxtree denotes a selector, one for each argument, plus a load
of more specific selectors.  So for each argument, one manufactures
all possible sub-cds using the sub-selectors as the set Z.
You then take this arg's selector, and manufacture a load of CDSs
like this:
\begin{verbatim}
   Case this_selector
      0 -> z | z <- Z
      1 -> z | z <- Z
      Par n -> z | z <- Z for each n in [1 .. length this_selector]
                          satisfying this_selector !! n == Empty
\end{verbatim}


> traverse n pfxtrees
>   = Magic : concat (map doOne [0 .. n - 1])
>     where
>        doOne i = traverse_arg n i pfxtrees (pfxtrees !! i) 

@traverse_arg@ makes the CDSs corresponding to descending a
particular argument, the number of which is given as its second
parameter.  It also gets the complete set of pfxtrees and the one
to descend.  Note that having descended in the given argument, we
check its sub-selectors.  If none, (an empty list), this replaced
by [NLeaf] to make everything work out.  A NLeaf selector
is a dummy which generates no CDSs.

> traverse_arg n i pfxtrees NLeaf
>   = []

> traverse_arg n i pfxtrees (NBranch this_selector subsidiary_selectors_init)
>   = let subsidiary_selectors 
>            = case subsidiary_selectors_init of 
>                 [] -> [NLeaf]; (_:_) -> subsidiary_selectors_init
>         subsidiary_pfxtrees = map (upd i pfxtrees) subsidiary_selectors
>         par_requests = preq 1 [] this_selector
>         preq n acc [] = acc
>         preq n acc (Empty:rest) = preq (n+1) ((RP n):acc) rest
>         preq n acc (other:rest) = preq (n+1)         acc  rest
>         subsidiary_cdss = concat (map (traverse n) subsidiary_pfxtrees)
>         all_poss_rhss = splat (2 + length par_requests) subsidiary_cdss
>         all_poss_returns = [RZero,  ROne] ++ par_requests
>     in
>         [Case this_selector (zip all_poss_returns rhs)
>         | rhs <- all_poss_rhss]
>
> splat :: Int -> [a] -> [[a]]
> splat 0 set = [[]]
> splat n set = [x:xs | x <- set, xs <- splat (n-1) set]

The final stage in the game is to fill in all the @Magic@s
with constants.  A template with $n$ @Magic@s presently generates
@2^n@ CDSs, obtained by all possible combinations of
filling each @Magic@ in with @Zero@ or @One@.  To do this we
first need to count the @Magic@s.

> count_magic :: CDS -> Int
> 
> count_magic Magic             = 1
> count_magic (Case sels alts)  = sum (map (count_magic.snd) alts)

We don't expect to see anything else at this stage.
Now make $2^n$ lists, each of length $n$, each with a different
sequence of @Zero@s and @One@s.  Use these to label the 
@Magic@s in the template.

> label_cds :: CDS -> [CDS] -> ([CDS], CDS)
>
> label_cds Magic (l:ls) = (ls, l)
> label_cds (Case sels alts) ls
>   = case f ls alts of (l9, alts_done) -> (l9, Case sels alts_done)
>     where
>        f l0 []     = (l0, [])
>        f l0 (a:as) = let (l1, a_done)  = lalt l0 a
>                          (l2, as_done) = f l1 as
>                      in  (l2, a_done:as_done)
>        lalt l0 (ret, cds) = case label_cds cds l0 of 
>                               (l1, cds_done) -> (l1, (ret, cds_done))

Finally:

> expand_templates :: [CDS] -> [CDS]
>
> expand_templates ts
>    = concat (map f ts)
>      where
>         f tem = map (snd . label_cds tem) 
>                     (splat (count_magic tem) [Zero, One])

--> testq tt = (layn . map show' . nub) (enumerate tt)

> main = putStrLn (show (apply_cds `myElem` (enumerate (Fn [Fn [Two], Two]))))
>
> i `myElem` [] = False
> i `myElem` (x:xs) = if i == x then True else i `myElem` xs 

%============================================================
%============================================================