[commit: ghc] : Changes with Simon (4f815dd)

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

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/4f815ddfe6338c17225ba967e01aac1039619293

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

commit 4f815ddfe6338c17225ba967e01aac1039619293
Author: Max Bolingbroke <[email protected]>
Date:   Tue Jan 3 14:23:30 2012 +0000

    Changes with Simon

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

 compiler/supercompile/Supercompile/Core/Tag.hs     |    4 +-
 .../supercompile/Supercompile/Drive/Process3.hs    |   22 +++++++++++--------
 2 files changed, 15 insertions(+), 11 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Core/Tag.hs b/compiler/supercompile/Supercompile/Core/Tag.hs
index 82951b9..8dfcaad 100644
--- a/compiler/supercompile/Supercompile/Core/Tag.hs
+++ b/compiler/supercompile/Supercompile/Core/Tag.hs
@@ -9,6 +9,7 @@ import Supercompile.Core.Size
 import Supercompile.Core.Syntax
 
 import qualified DataCon
+import Unique (Uniquable(getUnique))
 import Literal (hashLiteral)
 import Var (varUnique)
 
@@ -26,8 +27,7 @@ tagFVedTerm = mkTagger (\tg e -> Comp (Tagged tg e))
 -- are specialised on very long repititions of the same constructor.
 
 dataConTag :: DataCon -> Tag
---dataConTag dc = mkTag (negate (DataCon.dataConTag dc)) -- Works well because (hashLiteral l) is always positive
-dataConTag = mkTag . getKey . varUnique . DataCon.dataConWorkId -- This is much better because otherwise [], True and all dictionary all get the same tag!!
+dataConTag dc = mkTag (negate (abs (getKey (getUnique dc)))) -- Works well because (hashLiteral l) is always positive. Don't use dataConTag because tags are shared between DC families
 
 literalTag :: Literal -> Tag
 literalTag = mkTag . hashLiteral
diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs
index 3caef19..0425c17 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -96,7 +96,6 @@ fulfill :: Promise -> (Deeds, FVedTerm) -> FulfilmentState -> ((Deeds, FVedTerm)
 fulfill p (deeds, e_body) fs = ((deeds, fun p `applyAbsVars` abstracted p), FS { fulfilments = (fun p, absVarLambdas (abstracted p) e_body) : fulfilments fs })
 
 
-type Depth = Int
 type StopCount = Int
 
 data ScpState = ScpState {
@@ -107,9 +106,9 @@ data ScpState = ScpState {
   }
 
 data ScpEnv = ScpEnv {
-    scpDepth :: Depth,
     scpStopCount :: StopCount,
     scpNodeKey :: NodeKey,
+    scpParents :: [Var],
     scpAlreadySpeculated :: AlreadySpeculated,
     scpTagAnnotations :: TagAnnotations
   }
@@ -130,22 +129,27 @@ runScpM tag_anns me = letRec (fulfilments fs') e
         hist = pROCESS_HISTORY
         fs = FS { fulfilments = [] }
         parent = generatedKey hist
-        (e, ScpState _ms' _hist' fs' _resid_tags) = unI $ unReaderT (unStateT (unScpM me) (ScpState ms hist fs emptyResidTags)) (ScpEnv 0 0 parent nothingSpeculated tag_anns)
+        (e, ScpState _ms' _hist' fs' _resid_tags) = unI $ unReaderT (unStateT (unScpM me) (ScpState ms hist fs emptyResidTags)) (ScpEnv 0 parent [] nothingSpeculated tag_anns)
 
 
+scpDepth = length . scpParents
+
 traceRenderM :: Outputable a => String -> a -> ScpM ()
 traceRenderM msg x = ScpM $ StateT $ \s -> ReaderT $ \env -> pprTraceSC (replicate (scpDepth env) ' ' ++ msg) (pPrint x) $ pure ((), s) -- TODO: include depth, refine to ScpM monad only
 
+addParentM :: Promise -> ScpM a -> ScpM a
+addParentM p mx = ScpM $ StateT $ \s -> ReaderT $ \env ->  trace ("depth: " ++ show (scpDepth env) ++ ' ' : showSDoc (parens (hsep (map ppr (scpParents env))))) $ unReaderT (unStateT (unScpM mx) s) (env { scpParents = fun p : scpParents env })
+
 fulfillM :: Promise -> (Deeds, FVedTerm) -> ScpM (Deeds, FVedTerm)
 fulfillM p res = ScpM $ StateT $ \s -> case fulfill p res (scpFulfilmentState s) of (res', fs') -> return (res', s { scpFulfilmentState = fs' })
 
 terminateM :: String -> State -> ScpM a -> (String -> State -> ScpM a) -> ScpM a
-terminateM h state mcont mstop = ScpM $ StateT $ \s -> ReaderT $ \env -> trace ("depth: " ++ show (scpDepth env)) $ case terminate (scpProcessHistory s) (scpNodeKey env, (h, state)) of
+terminateM h state mcont mstop = ScpM $ StateT $ \s -> ReaderT $ \env -> case terminate (scpProcessHistory s) (scpNodeKey env, (h, state)) of
         Stop (_, (shallow_h, shallow_state))
           -> trace ("stops: " ++ show (scpStopCount env)) $
-             unReaderT (unStateT (unScpM (mstop shallow_h shallow_state)) s)                                 (env { scpDepth = scpDepth env + 1, scpStopCount = scpStopCount env + 1}) -- FIXME: prevent rollback?
+             unReaderT (unStateT (unScpM (mstop shallow_h shallow_state)) s)                                 (env { scpStopCount = scpStopCount env + 1}) -- FIXME: prevent rollback?
         Continue hist'
-          -> unReaderT (unStateT (unScpM mcont)                           (s { scpProcessHistory = hist' })) (env { scpDepth = scpDepth env + 1, scpNodeKey = generatedKey hist' })
+          -> unReaderT (unStateT (unScpM mcont)                           (s { scpProcessHistory = hist' })) (env { scpNodeKey = generatedKey hist' })
   -- TODO: record the names of the h-functions on the way to the current one instead of a Int depth
 
 speculateM :: State -> (State -> ScpM a) -> ScpM a
@@ -246,9 +250,9 @@ memo opt state
                           match (meaning p) reduced_state]
          ] of (p, res):_ -> pure (do { traceRenderM "=sc" (fun p, PrettyDoc (pPrintFullState quietStatePrettiness state), res)
                                      ; return res }, ScpState ms hist fs resid_tags)
-              _          -> pure (do { traceRenderM ">sc" (fun p, stateTags state, PrettyDoc (pPrintFullState quietStatePrettiness state))
-                                     ; res <- opt (Just (getOccString (varName (fun p)))) state
-                                     ; traceRenderM "<sc" (fun p, PrettyDoc (pPrintFullState quietStatePrettiness state), res)
+              _          -> pure (do { traceRenderM ">sc {" (fun p, stateTags state, PrettyDoc (pPrintFullState quietStatePrettiness state))
+                                     ; res <- addParentM p $ opt (Just (getOccString (varName (fun p)))) state
+                                     ; traceRenderM "<sc }" (fun p, PrettyDoc (pPrintFullState quietStatePrettiness state), res)
                                      ; fulfillM p res }, ScpState ms' hist fs resid_tags)
                 where (p, ms') = promise (state, reduced_state) ms
   where reduced_state = reduceForMatch state