[commit: ghc] : We have to include the universal type arguments in Data or we can't derive a value's type (e8b174b)

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

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/e8b174ba9798fbf56cd3782a4d57a3eb423791f5

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

commit e8b174ba9798fbf56cd3782a4d57a3eb423791f5
Author: Max Bolingbroke <[email protected]>
Date:   Mon Aug 1 18:36:50 2011 +0100

    We have to include the universal type arguments in Data or we can't derive a value's type

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

 compiler/supercompile/Supercompile.hs             |    7 ++---
 compiler/supercompile/Supercompile/Core/Syntax.hs |    2 +-
 compiler/supercompile/Supercompile/Drive/Split.hs |   22 +++++++++++++-------
 3 files changed, 18 insertions(+), 13 deletions(-)

diff --git a/compiler/supercompile/Supercompile.hs b/compiler/supercompile/Supercompile.hs
index 8c73380..792583a 100644
--- a/compiler/supercompile/Supercompile.hs
+++ b/compiler/supercompile/Supercompile.hs
@@ -11,7 +11,7 @@ import CoreSyn
 import CoreFVs    (exprFreeVars)
 import CoreUtils  (exprType)
 import Coercion   (Coercion, isCoVar, isCoVarType, mkCoVarCo)
-import DataCon    (dataConWorkId, dataConUnivTyVars, dataConExTyVars, dataConRepArgTys)
+import DataCon    (dataConWorkId, dataConAllTyVars, dataConRepArgTys)
 import VarSet
 import Name       (localiseName)
 import Var        (Var, isTyVar, varName, setVarName)
@@ -237,9 +237,8 @@ termUnfoldings e = go (S.termFreeVars e) emptyVarSet []
       where (as, arg_tys, _res_ty, _arity, _strictness) = primOpSig pop
             xs = zipWith (mkSysLocal (fsLit "x")) bv_uniques arg_tys
     
-    dataUnfolding dc = S.tyLambdas univ_as $ S.tyLambdas ex_as $ S.lambdas xs $ S.value (S.Data dc (map mkTyVarTy ex_as) (map mkCoVarCo qs) ys)
-      where univ_as = dataConUnivTyVars dc
-            ex_as   = dataConExTyVars dc
+    dataUnfolding dc = S.tyLambdas as $ S.lambdas xs $ S.value (S.Data dc (map mkTyVarTy as) (map mkCoVarCo qs) ys)
+      where as = dataConAllTyVars dc
             arg_tys = dataConRepArgTys dc
             xs = zipWith (mkSysLocal (fsLit "x")) bv_uniques arg_tys
             (qs, ys) = span isCoVar xs
diff --git a/compiler/supercompile/Supercompile/Core/Syntax.hs b/compiler/supercompile/Supercompile/Core/Syntax.hs
index 8daa1b8..5ced926 100644
--- a/compiler/supercompile/Supercompile/Core/Syntax.hs
+++ b/compiler/supercompile/Supercompile/Core/Syntax.hs
@@ -87,7 +87,7 @@ type TaggedValue = ValueF Tagged
 data ValueF ann = Indirect Id -- NB: for the avoidance of doubt, these cannot be CoVars
                 | Literal Literal | Coercion Coercion
                 | TyLambda TyVar (ann (TermF ann)) | Lambda Id (ann (TermF ann)) -- NB: might bind a CoVar
-                | Data DataCon [Type] [Coercion] [Id]
+                | Data DataCon [Type] [Coercion] [Id] -- NB: includes universal and existential type arguments, in that order
 
 instance Outputable AltCon where
     pprPrec prec altcon = case altcon of
diff --git a/compiler/supercompile/Supercompile/Drive/Split.hs b/compiler/supercompile/Supercompile/Drive/Split.hs
index 65d7c9b..a44e6ca 100644
--- a/compiler/supercompile/Supercompile/Drive/Split.hs
+++ b/compiler/supercompile/Supercompile/Drive/Split.hs
@@ -19,10 +19,9 @@ import Supercompile.StaticFlags
 import Supercompile.Utilities hiding (tails)
 
 import Var       (varType)
-import Id        (idUnique)
-import Type      (mkTyVarTy)
-import Coercion  (mkCoVarCo)
+import Id        (idUnique, idType)
 import PrelNames (undefinedName)
+import Type      (splitTyConApp_maybe)
 import Util      (zipWithEqual, zipWith3Equal, zipWith4Equal)
 import Unique    (Uniquable)
 import UniqSet   (UniqSet, mkUniqSet, uniqSetToList, elementOfUniqSet)
@@ -956,7 +955,12 @@ splitStackFrame ctxt_ids ids kf scruts bracketed_hole
             -- ===>
             --  case x of C -> let unk = C; z = C in ...
             alt_in_es = alt_rns `zip` alt_es
-            alt_hs = zipWith4Equal "alt_hs" (\alt_rn alt_con alt_bvs alt_tg -> M.fromList [(x, lambdaBound) | x <- alt_bvs] `M.union` M.fromList (do { Just scrut_v <- [altConToValue alt_con]; scrut_e <- [annedTerm alt_tg (Value scrut_v)]; scrut <- (x':scruts); return (scrut, HB (howToBindCheap scrut_e) (Right (alt_rn, scrut_e))) })) alt_rns alt_cons alt_bvss (map annedTag alt_es) -- NB: don't need to grab deeds for these just yet, due to the funny contract for transitiveInline
+            alt_hs = zipWith4Equal "alt_hs" (\alt_rn alt_con alt_bvs alt_tg -> M.fromList [(x, lambdaBound) | x <- alt_bvs] `M.union`
+                                                                               M.fromList (do Just scrut_v <- [altConToValue (idType x') (alt_rn, alt_con)]
+                                                                                              let in_scrut_e@(_, scrut_e) = renamedTerm (annedTerm alt_tg (Value scrut_v))
+                                                                                              scrut <- (x':scruts)
+                                                                                              return (scrut, HB (howToBindCheap scrut_e) (Right in_scrut_e)) ))
+                                            alt_rns alt_cons alt_bvss (map annedTag alt_es) -- NB: don't need to grab deeds for these just yet, due to the funny contract for transitiveInline
             alt_bvss = map altConBoundVars alt_cons'
             bracketed_alts = zipWith3Equal "bracketed_alts" (\alt_h alt_ids alt_in_e -> oneBracketed (Once ctxt_id, (0, Heap alt_h alt_ids, [], alt_in_e))) alt_hs alt_idss alt_in_es
     StrictLet x' in_e -> zipBracketeds (\[e_hole, e_body] -> let_ x' e_hole e_body) (\[fvs_hole, fvs_body] -> fvs_hole `unionVarSet` fvs_body) [[], [x']] (\[_tails_hole, tails_body] -> tails_body) [bracketed_hole, oneBracketed (Once ctxt_id, (0, Heap (M.singleton x' lambdaBound) ids, [], in_e))]
@@ -969,10 +973,12 @@ splitStackFrame ctxt_ids ids kf scruts bracketed_hole
             bracketed_vs = map (splitAnswer ids . annee) in_vs
             bracketed_es  = zipWith (\ctxt_id in_e -> oneBracketed (Once ctxt_id, (0, Heap M.empty ids, [], in_e))) ctxt_idss in_es)
   where
-    altConToValue :: AltCon -> Maybe (ValueF ann)
-    altConToValue (DataAlt dc as qs xs) = Just $ Data dc (map mkTyVarTy as) (map mkCoVarCo qs) xs
-    altConToValue (LiteralAlt l)        = Just $ Literal l
-    altConToValue DefaultAlt            = Nothing
+    altConToValue :: Type -> In AltCon -> Maybe (ValueF ann)
+    altConToValue ty' (rn, DataAlt dc as qs xs) = do
+        (_, univ_tys') <- splitTyConApp_maybe ty'
+        Just (Data dc (univ_tys' ++ map (lookupTyVarSubst rn) as) (map (lookupCoVarSubst rn) qs) (map (renameId rn) xs))
+    altConToValue _  (_,  LiteralAlt l) = Just (Literal l)
+    altConToValue _  (_,  DefaultAlt)   = Nothing
 
 -- I'm making use of a clever trick: after splitting an update frame for x, instead of continuing to split the stack with a
 -- noneBracketed for x in the focus, I split the stack with a oneBracketed for it in the focus.