Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/e8b174ba9798fbf56cd3782a4d57a3eb423791f5 >--------------------------------------------------------------- commit e8b174ba9798fbf56cd3782a4d57a3eb423791f5 Author: Max Bolingbroke <batterseapo...@hotmail.com> 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. _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
