[commit: ghc] : Use Train data type for promises tree instead (more precise), allow ancestor instance match (595e672)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/595e6721f0e333c6bb9de1bf0f32082df9cbe9ed

>---------------------------------------------------------------

commit 595e6721f0e333c6bb9de1bf0f32082df9cbe9ed
Author: Max Bolingbroke <[email protected]>
Date:   Wed Feb 8 17:04:16 2012 +0000

    Use Train data type for promises tree instead (more precise), allow ancestor instance match

>---------------------------------------------------------------

 .../supercompile/Supercompile/Drive/Process3.hs    |   36 +++++++++++---------
 compiler/supercompile/Supercompile/Utilities.hs    |    7 ++++
 2 files changed, 27 insertions(+), 16 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs
index 19f5270..df9a5ef 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -63,19 +63,21 @@ data Promise = P {
   }
 
 
-appendHead :: [b] -> [(a, [b])] -> [(a, [b])]
-appendHead ys1 ((x, ys2):zs) = (x, ys1 ++ ys2):zs
-appendHead _   []            = error "Used promises after last fulfilment"
+appendHead :: [b] -> Train (a, [b]) [b] -> Train (a, [b]) [b]
+appendHead ys1 (Car (x, ys2) zs) = (x, ys1 ++ ys2) `Car` zs
+appendHead ys1 (Loco ys2)        = Loco (ys1 ++ ys2)
 
-leftExtension :: [a] -- ^ Longer list
-              -> [a] -- ^ Shorter list
-              -> ([a], [a]) -- Pair of the prefix present in the longer list and the common suffix (== shorter list)
-leftExtension xs ys = (reverse prefix_rev, suffix_rev)
-  where (prefix_rev, suffix_rev) = splitBy ys (reverse xs) -- NB: we actually assume ys == suffix_rev
+leftExtension :: Train a b -- ^ Longer list
+              -> Train a b -- ^ Shorter list
+              -> ([a], Train a b) -- Pair of the prefix present in the longer list and the common suffix (== shorter list)
+leftExtension xs_train ys_train = (reverse prefix_rev, ys_train)
+  where (xs, _xs_loco) = trainToList xs_train
+        (ys, _ys_loco) = trainToList ys_train
+        (prefix_rev, _suffix_rev) = splitBy ys (reverse xs) -- NB: we actually assume ys == suffix_rev
 
 
 data MemoState = MS {
-    promises :: [(Maybe Promise, [Promise])], -- (parent, siblings) pairs, with those closest to current level first
+    promises :: Train (Promise, [Promise]) [Promise], -- (parent, siblings) pairs, with those closest to current level first
     hNames   :: Stream Name
   }
 
@@ -99,7 +101,7 @@ promise ms (state, reduced_state) = (ms', p)
             dumped     = False
           }
         ms' = MS {
-            promises = (Just p, []) : promises ms, -- Establishes a new level in the process tree
+            promises = (p, []) `Car` promises ms, -- Establishes a new level in the process tree
             hNames   = h_names'
           }
 
@@ -113,7 +115,7 @@ fulfill (deeds, e_body) fs ms
   = ((deeds, fun p `applyAbsVars` abstracted p),
      FS { fulfilments = (fun p, absVarLambdas (abstracted p) e_body) : fulfilments fs },
      ms { promises = appendHead (p:children) promises' })
-  where (Just p, children):promises' = promises ms
+  where (p, children) `Car` promises' = promises ms
 
 
 type StopCount = Int
@@ -151,7 +153,7 @@ runScpM tag_anns me = fvedTermSize e' `seq` trace ("Deepest path:\n" ++ showSDoc
                                                    "\nDepth histogram:\n" ++ showSDoc (depthHistogram (scpParentChildren s'))) e'
   where h_names = listToStream $ zipWith (\i uniq -> mkSystemVarName uniq (mkFastString ('h' : show (i :: Int))))
                                          [1..] (uniqsFromSupply hFunctionsUniqSupply)
-        ms = MS { promises = [(Nothing, [])], hNames = h_names }
+        ms = MS { promises = Loco [], hNames = h_names }
         hist = pROCESS_HISTORY
         fs = FS { fulfilments = [] }
         parent = generatedKey hist
@@ -187,7 +189,7 @@ rolledBackTo s' s = ScpState {
   where
     -- We have to roll back any promise on the "stack" above us:
     (dangerous_promises, ok_promises) = (leftExtension `on` (promises . scpMemoState)) s' s
-    (spine_rolled_back, possibly_rolled_back) = (catMaybes *** concat) $ unzip dangerous_promises
+    (spine_rolled_back, possibly_rolled_back) = (second concat) $ unzip dangerous_promises
     -- NB: rolled_back includes names of both unfulfilled promises rolled back from the stack and fulfilled promises that have to be dumped as a result
     (rolled_fulfilments, rolled_back) = pruneFulfilments (scpFulfilmentState s') (mkVarSet (map fun spine_rolled_back))
 
@@ -331,14 +333,16 @@ memo opt = memo_opt
         --  2. Suprisingly, terms that match *before* reduction may not match *after* reduction! This occurs because
         --     two terms with different distributions of tag may match, but may roll back in different ways in reduce.
         case [ (p, instanceSplit (remaining_deeds, heap_inst, k_inst, fun p `applyAbsVars` map (renameAbsVar rn_lr) (abstracted p)) memo_opt)
-             | (mb_p_parent, p_siblings) <- promises (scpMemoState s)
-             , p <- maybe id (:) mb_p_parent p_siblings
+             | let (parented_ps, unparented_ps) = trainToList (promises (scpMemoState s))
+             , (mb_p_parent, p) <- [(Just p_parent, p_sibling) | (p_parent, p_siblings) <- parented_ps, p_sibling <- p_parent:p_siblings] ++
+                                   [(Nothing,       p_root)    | p_root <- unparented_ps]
              , Just (heap_inst@(Heap h_inst _), k_inst, rn_lr) <- [-- (\res -> if isNothing res then pprTraceSC "no match:" (ppr (fun p)) res   else   pprTraceSC "match!" (ppr (fun p)) res) $
                                                                    match' (meaning p) reduced_state]
              , let instance_match = not (M.null h_inst && null k_inst)
                    -- This will always succeed because the state had deeds for everything in its heap/stack anyway:
                    Just remaining_deeds = claimDeeds (releaseStateDeed state) (heapSize heap_inst + stackSize k_inst)
-             , not instance_match -- FIXME: less restrictive instance matches
+               -- Alow instance matching against direct ancestors only, NOT their children
+             , not instance_match || fmap fun mb_p_parent == Just (fun p)
                -- FIXME: prefer "more exact" matches
              , if dumped p
                 then pprTraceSC "tieback-to-dumped" (ppr (fun p)) False
diff --git a/compiler/supercompile/Supercompile/Utilities.hs b/compiler/supercompile/Supercompile/Utilities.hs
index 9939612..c447515 100644
--- a/compiler/supercompile/Supercompile/Utilities.hs
+++ b/compiler/supercompile/Supercompile/Utilities.hs
@@ -619,6 +619,13 @@ supercompileUniqSupply = unsafePerformIO $ mkSplitUniqSupply 'p'
 (hFunctionsUniqSupply:anfUniqSupply:expandUniqSupply:reduceUniqSupply:tagUniqSupply:prettyUniqSupply:matchUniqSupply:splitterUniqSupply:_) = listSplitUniqSupply supercompileUniqSupply
 
 
+data Train a b = Car a (Train a b) | Loco b
+
+trainToList :: Train a b -> ([a], b)
+trainToList (Car a abs) = first (a:) (trainToList abs)
+trainToList (Loco b)    = ([], b)
+
+
 data Stream a = a :< Stream a
 
 listToStream :: [a] -> Stream a