3 This test runs for a Long Time (10mins for the registerised version)
4 and allocates 3.4Gbytes. It also hammers the GC; with -H16M it spend
5 40% of the time in the GC.
9 Date: Sun, 25 Oct 92 16:38:12 GMT
10 From: Julian Seward (DRL PhD) <sewardj@uk.ac.man.cs>
11 Message-Id: <9210251638.AA21153@r6b.cs.man.ac.uk>
12 To: partain@uk.ac.glasgow.dcs
13 Subject: Space consumption in 0.09 produced binary
14 Cc: sewardj@uk.ac.man.cs, simonpj@uk.ac.glasgow.dcs
18 At the risk of wasting even more of your valuable time, here is
19 a small problem I ran into:
21 The program (XXXX.lhs) listed below runs in constant space (about 4k)
22 in both Gofer and hbc 0.998.5. When compiled with 0.09, it runs out
23 of heap in seconds (4 meg heap).
25 The program builds a gigantic list of things (CDSs, in fact), I believe
26 at least 100,000 long, and searches to find out if a particular CDS is
27 present. The CDS list is generated lazily, and should be thrown away
28 as it goes, until apply_cds is found (see the bottom of the listing).
29 Gofer and hbc behave as expected, but I suspect ghc is holding onto
30 the complete list unnecessarily.
32 I include XXXX.stat as supporting evidence.
37 ghc9 -v -O -gc-ap -flet-float -Rgc-stats -Rmax-heapsize 14M -o XXXX XXXX.lhs
40 -----------------------------------------------------------------------
44 Collector: APPEL HeapSize: 4,194,304 (bytes)
46 Alloc Live Live Astk Bstk OldGen GC GC TOT TOT Page Flts Collec Resid
47 bytes bytes % bytes bytes roots user elap user elap GC TOT tion %heap
48 2097108 1119672 53.4 52 132 1119616 0.33 0.35 1.01 1.15 0 0 Minor
49 1537300 918200 59.7 48 128 918188 0.26 0.31 1.76 1.95 0 0 Minor
50 1078216 654212 60.7 56 160 652612 0.19 0.18 2.29 2.46 0 0 Minor
51 751108 442140 58.9 52 108 442140 0.12 0.12 2.64 2.84 0 0 Minor
52 3134224 2935044 93.6 52 108 1.49 1.50 4.13 4.34 0 0 *MAJOR* 70.0%
53 629612 376848 59.9 52 132 376836 0.11 0.11 4.44 4.64 0 0 Minor
54 441184 265100 60.1 96 200 264416 0.08 0.07 4.66 4.86 0 0 Minor
55 308640 204072 66.1 56 160 199476 0.06 0.05 4.81 5.01 0 0 Minor
56 3781064 3687092 97.5 56 160 1.81 1.85 6.62 6.86 0 0 *MAJOR* 87.9%
57 253600 160584 63.3 52 108 160584 0.05 0.04 6.75 6.98 0 0 Minor
58 173312 112344 64.8 56 160 110304 0.03 0.03 6.83 7.07 0 0 Minor
59 117128 77260 66.0 36 140 74112 0.01 0.02 6.88 7.13 0 0 Minor
60 4037280 3985284 98.7 36 140 1.96 1.98 8.85 9.11 0 0 *MAJOR* 95.0%
62 -------------------------------------------------------------------------
67 %============================================================
68 %============================================================
70 \section{A CDS interpreter}
72 \subsection{Declarations}
74 Second attempt at a CDS interpreter. Should do
75 loop detection correctly in the presence of higher order functions.
77 The types allowed are very restrictive at the mo.
82 Now, we also have to define CDSs and selectors.
85 @Empty@ is a non-legitimate CDS, denoting no value at all. We use
86 it as an argument in calls to other CDSs denoting that
87 the particular argument is not really supplied.
89 @Par@ is similarly a non-legit CDS, but useful for constructing
90 selectors. It simply denotes the parameter specified (note
91 parameter numbering starts at 1).
93 @Zero@ and @One@ are constant valued CDSs.
96 Calls to other functions are done with @Call@, which expects
97 the callee to return @Zero@ or @One@, and selects the relevant
98 branch. The @Tag@s identify calls in the dependancy list.
99 Although a @Call@ is a glorified @Case@ statement, the only allowed
100 return values are @Zero@ and @One@. Hence the @CDS CDS@ continuations
101 rather than the more comprehensive @(AList Return CDS)@.
102 We require arguments to be fully disassembled.
104 Case selectors can only be of the following form:
107 @[Par n]@ if the n'th parameter is not a function space.
109 @[Par n, v1 ... vn]@ if the n'th parameter is a function space of
110 arity n. The v's may be only @Empty@, @Zero@,
114 We also have a @Magic@ CDS which is a load of mumbo-jumbo for use
115 in enumeration of and compilation to CDSs. Of no significance
122 > | Case [CDS] (AList Return CDS)
123 > | Call String Tag [CDS] CDS CDS
126 > type AList a b = [(a, b)]
130 > instance Eq CDS where
131 > (Par n1) == (Par n2) = n1 == n2
132 > Zero == Zero = True
134 > (Case sels1 rets1) == (Case sels2 rets2) = sels1 == sels2 &&
136 > (Call f1 t1 sels1 a1 b1) == (Call f2 t2 sels2 a2 b2)
137 > = f1 == f2 && t1 == t2 && sels1 == sels2 && a1 == a2 && b1 == b2
138 > Magic == Magic = True
142 A @Return@ is a temporary thing used to decide which way to go at
145 > data Return = RZero
149 > instance Eq Return where
150 > RZero == RZero = True
151 > ROne == ROne = True
152 > (RP p1) == (RP p2) = p1 == p2
155 We need a code store, which gives out a fresh instance of a CDS
156 as necessary. ToDo: Need to rename call sites? I don't think so.
158 > type Code = AList String CDS
160 %============================================================
161 %============================================================
163 \subsection{The evaluator}
164 Main CDS evaluator takes
167 \item the dependancy list, a list of @Tag@s of calls which are
168 currently in progress
169 \item the current arguments
170 \item the CDS fragment currently being worked on
173 > type Depends = [Tag]
175 > eval :: Code -> Depends -> [CDS] -> CDS -> CDS
177 Evaluating a constant valued CDS is trivial. There may be arguments
178 present -- this is not a mistake.
180 > eval co de args Zero = Zero
181 > eval co de args One = One
183 Making a call is also pretty simple, because we assume
184 that all non-functional arguments are presented as literals,
185 and all functional values have already been dismantled (unless
186 they are being passed unchanged in the same position in a recursive call
187 to the same function, something for the compiler to detect).
189 Two other issues are at work here. Guided by the selectors,
190 we copy the args to make a set of args for the call. However, if an
191 copied arg is Empty, the call cannot proceed, so we return the CDS as-is.
192 Note that an Empty *selector* is not allowed in a Call (although it is
195 The second issue arises if the call can go ahead. We need to check the
196 tag on the call just about to be made with the tags of calls already in
197 progress (in de) to see if we are looping. If the tag has already been
198 encountered, the result of the call is Zero, so the Zero alternative is
199 immediately selected.
201 > eval co de args cds@(Call fname tag params alt0 alt1)
202 > = let (copied_an_empty, callee_args) = copy_args args params
203 > augmented_de = tag : de
204 > callee_code = lkup co fname
205 > callee_result = eval co augmented_de callee_args callee_code
206 > been_here_before = tag `elem` de
211 > if been_here_before
212 > then eval co augmented_de args alt0
213 > else case callee_result of
214 > Zero -> eval co de args alt0
215 > One -> eval co de args alt1
216 > _ -> error "Bad callee result"
218 Case really means "evaluate".
220 - make sure first selector is non-Empty. If so, return CDS as-is.
222 - Copy other args. If Empty is *copied*, return CDS as-is.
223 Otherwise, call evaluator and switch on head of result.
225 Note about switching on the head of the result. We expect to see
226 *only* the following as results:
232 in which case switching is performed on
238 ToDo: what happens if a Call turns up ???
240 > eval co de args cds@(Case ((Par n):ps) alts)
241 > = let (copied_an_empty, new_args) = copy_args args ps
242 > functional_param = args !! (n-1)
243 > in if functional_param == Empty ||
246 > else eval co de args
247 > (lkup alts (get_head
248 > (eval co de new_args functional_param)))
250 Auxiliary for evaluating Case expressions.
252 > get_head Zero = RZero
253 > get_head One = ROne
254 > get_head (Case ((Par n):_) _) = RP n
256 Copy args based on directions in a list of selectors.
257 Also returns a boolean which is True if an Empty has been
258 *copied*. An Empty *selector* simply produces Empty in the
259 corresponding output position.
261 > copy_args :: [CDS] -> [CDS] -> (Bool, [CDS])
263 > copy_args args params
264 > = case cax False params [] of
265 > (empty_copied, res) -> (empty_copied, reverse res)
267 > cax empty [] res = (empty, res)
268 > cax empty (Zero:ps) res = cax empty ps (Zero:res)
269 > cax empty (One:ps) res = cax empty ps (One:res)
270 > cax empty (Empty:ps) res = cax empty ps (Empty:res)
271 > cax empty ((Par n):ps) res
272 > = case args !! (n-1) of
273 > Empty -> cax True ps (Empty:res)
274 > other -> cax empty ps (other:res)
276 > lkup env k = head ( [v | (kk,v) <- env, kk == k] ++
277 > [error ( "Can't look up " ) ] )
279 %============================================================
280 %============================================================
282 %============================================================
283 %============================================================
285 Something to make running tests easier ...
287 > eval0 fname args = eval test [] args (lkup test fname)
291 Now for some test data ...
297 > ("apply", apply_cds),
301 > ("kkkr", kkkr_cds),
302 > ("kkkl", kkkl_cds),
303 > ("apply2", apply2_cds)
307 Constant Zero function.
322 Constant One function.
329 Strict in both of two arguments, for example (+).
333 > [(RZero, Case [Par 2]
337 > (ROne, Case [Par 2]
343 The (in)famous apply function.
346 > = Case [Par 1, Empty]
349 > (RP 1, Case [Par 2]
350 > [(RZero, Case [Par 1, Zero]
353 > (ROne, Case [Par 1, One]
359 The inverse K-combinator: K x y = y
367 The standard K-combinator, defined thus: K x y = K-inverse y x.
368 Purpose of this is to test function calling.
372 > [(RZero, Case [Par 2]
373 > [(RZero, Call "kkkr" 101 [Zero, Zero] Zero One),
374 > (ROne, Call "kkkr" 102 [One, Zero] Zero One)
376 > (ROne, Case [Par 2]
377 > [(RZero, Call "kkkr" 103 [Zero, One] Zero One),
378 > (ROne, Call "kkkr" 104 [One, One] Zero One)
382 Apply a 2-argument function (apply2 f x y = f x y).
385 > = Case [Par 1, Empty, Empty]
388 > (RP 1, Case [Par 2]
389 > [(RZero, Case [Par 1, Zero, Empty]
392 > (RP 2, Case [Par 3]
393 > [(RZero, Case [Par 1, Zero, Zero]
396 > (ROne, Case [Par 1, Zero, One]
401 > (ROne, Case [Par 1, One, Empty]
404 > (RP 2, Case [Par 3]
405 > [(RZero, Case [Par 1, One, Zero]
408 > (ROne, Case [Par 1, One, One]
414 > (RP 2, Case [Par 3]
415 > [(RZero, Case [Par 1, Empty, Zero]
418 > (RP 1, Case [Par 2]
419 > [(RZero, Case [Par 1, Zero, Zero]
422 > (ROne, Case [Par 1, One, Zero]
427 > (ROne, Case [Par 1, Empty, One]
430 > (RP 1, Case [Par 2]
431 > [(RZero, Case [Par 1, Zero, One]
434 > (ROne, Case [Par 1, One, One]
444 %============================================================
445 %============================================================
447 %============================================================
448 %============================================================
450 Enumeration of all CDSs of a given type.
452 Define n-ary branched trees. These are used to hold the
453 possible prefixes of function arguments, something essential
454 when enumerating higher-order CDSs. ToDo: translate to English
456 > data NTree a = NLeaf
457 > | NBranch a [NTree a]
459 The enumeration enterprise involves some mutual recursion
460 when it comes to higher-order functions. We define the
461 top-level enumerator function, for trivial cases, hence:
463 > enumerate :: Type -> [CDS]
465 > enumerate Two = [Zero, One]
466 > enumerate (Fn ats) =
467 > expand_templates (traverse (length ats) (gen_pfx_trees ats))
469 Enumerating a function space is tricky. In summary:
471 - Generate the prefix trees for each argument.
472 For non-function arguments this trivial, but for
473 function-valued arguments this means a call to the
474 enumerator to get all the possible values of the
475 (argument) function space.
477 - Traverse the prefix trees, generating a series of
478 "templates" for functions.
480 - Expand each template thus generated into a genuine CDS.
481 Each template denotes a group of CDSs, all of
482 the same "shape" and differing only in the constants
483 they return. The Magic and RMagic constructors are
484 used for these purposes.
486 Generating prefix trees. For a Two-argument, is easy:
488 > gen_pfx_trees :: [Type] -> [NTree [CDS]]
490 > gen_pfx_trees ts = zipWith gen_pfx_tree ts [1 .. length ts]
492 > gen_pfx_tree :: Type -> Int -> NTree [CDS]
494 > gen_pfx_tree Two n = NBranch [Par n] []
496 Note all prefixes are missing the initial (Par n) selector ...
500 - enumerate each of the *function's* args
502 - starting with a selector [Empty, ...., Empty],
503 make a tree wherein at each level, branching is
504 achieved by filling in every Empty with every value
505 of that argument type. ToDo: fix this
507 > gen_pfx_tree (Fn arg_types) n
508 > = let number_args = length arg_types
509 > enumed_args = map enumerate arg_types
510 > initial_sel = take number_args (repeat Empty)
511 > init_tree = NBranch ((Par n):initial_sel) []
513 > expand_pfx_tree number_args number_args n enumed_args init_tree
515 @expand_pfx_tree@ expands a tree until there are no Emptys
516 at the leaves. Its first parameter is the number of Emptys
517 in the tree it has been given; when zero, expansion is complete.
518 The second parameter is the number of Emptys in the original
519 tree (equal to the arity of the function being enumerated).
520 Third number is the argument number in the top-level function,
521 needed to make the initial "Par n" selector.
522 Also needs to carry around the enumeration of the function's
525 > expand_pfx_tree :: Int -> Int -> Int -> [[CDS]] -> NTree [CDS] -> NTree [CDS]
527 > expand_pfx_tree 0 w i enums tree = tree
529 > expand_pfx_tree n w i enums (NBranch sels [])
530 > = let indices = [0 .. w - 1]
532 > new_sels = concat (map expand_sel indices)
534 > = case sels !! (n+1) of
535 > Empty -> map (upd (n+1) sels) (enums !! n)
537 > mk_trivial_tree sel = NBranch sel []
539 > NBranch sels (map (expand_pfx_tree n_minus_1 w i enums . mk_trivial_tree)
542 > upd :: Int -> [a] -> a -> [a]
543 > upd 0 (y:ys) x = x:ys
544 > upd n (y:ys) x = y:upd (n-1) ys x
546 In the second phase, the prefix trees are traversed to generate
547 CDS templates (full of Magic, but no Zero or One).
548 The first arg is the number of arguments, and the
549 second the prefix trees for each argument.
551 > traverse :: Int -> [NTree [CDS]] -> [CDS]
553 Each pfxtree denotes a selector, one for each argument, plus a load
554 of more specific selectors. So for each argument, one manufactures
555 all possible sub-cds using the sub-selectors as the set Z.
556 You then take this arg's selector, and manufacture a load of CDSs
562 Par n -> z | z <- Z for each n in [1 .. length this_selector]
563 satisfying this_selector !! n == Empty
567 > traverse n pfxtrees
568 > = Magic : concat (map doOne [0 .. n - 1])
570 > doOne i = traverse_arg n i pfxtrees (pfxtrees !! i)
572 @traverse_arg@ makes the CDSs corresponding to descending a
573 particular argument, the number of which is given as its second
574 parameter. It also gets the complete set of pfxtrees and the one
575 to descend. Note that having descended in the given argument, we
576 check its sub-selectors. If none, (an empty list), this replaced
577 by [NLeaf] to make everything work out. A NLeaf selector
578 is a dummy which generates no CDSs.
580 > traverse_arg n i pfxtrees NLeaf
583 > traverse_arg n i pfxtrees (NBranch this_selector subsidiary_selectors_init)
584 > = let subsidiary_selectors
585 > = case subsidiary_selectors_init of
586 > [] -> [NLeaf]; (_:_) -> subsidiary_selectors_init
587 > subsidiary_pfxtrees = map (upd i pfxtrees) subsidiary_selectors
588 > par_requests = preq 1 [] this_selector
589 > preq n acc [] = acc
590 > preq n acc (Empty:rest) = preq (n+1) ((RP n):acc) rest
591 > preq n acc (other:rest) = preq (n+1) acc rest
592 > subsidiary_cdss = concat (map (traverse n) subsidiary_pfxtrees)
593 > all_poss_rhss = splat (2 + length par_requests) subsidiary_cdss
594 > all_poss_returns = [RZero, ROne] ++ par_requests
596 > [Case this_selector (zip all_poss_returns rhs)
597 > | rhs <- all_poss_rhss]
599 > splat :: Int -> [a] -> [[a]]
601 > splat n set = [x:xs | x <- set, xs <- splat (n-1) set]
603 The final stage in the game is to fill in all the @Magic@s
604 with constants. A template with $n$ @Magic@s presently generates
605 @2^n@ CDSs, obtained by all possible combinations of
606 filling each @Magic@ in with @Zero@ or @One@. To do this we
607 first need to count the @Magic@s.
609 > count_magic :: CDS -> Int
611 > count_magic Magic = 1
612 > count_magic (Case sels alts) = sum (map (count_magic.snd) alts)
614 We don't expect to see anything else at this stage.
615 Now make $2^n$ lists, each of length $n$, each with a different
616 sequence of @Zero@s and @One@s. Use these to label the
617 @Magic@s in the template.
619 > label_cds :: CDS -> [CDS] -> ([CDS], CDS)
621 > label_cds Magic (l:ls) = (ls, l)
622 > label_cds (Case sels alts) ls
623 > = case f ls alts of (l9, alts_done) -> (l9, Case sels alts_done)
626 > f l0 (a:as) = let (l1, a_done) = lalt l0 a
627 > (l2, as_done) = f l1 as
628 > in (l2, a_done:as_done)
629 > lalt l0 (ret, cds) = case label_cds cds l0 of
630 > (l1, cds_done) -> (l1, (ret, cds_done))
634 > expand_templates :: [CDS] -> [CDS]
636 > expand_templates ts
637 > = concat (map f ts)
639 > f tem = map (snd . label_cds tem)
640 > (splat (count_magic tem) [Zero, One])
642 --> testq tt = (layn . map show' . nub) (enumerate tt)
644 > main = putStrLn (show (apply_cds `myElem` (enumerate (Fn [Fn [Two], Two]))))
646 > i `myElem` [] = False
647 > i `myElem` (x:xs) = if i == x then True else i `myElem` xs
649 %============================================================
650 %============================================================