diff options
Diffstat (limited to 'ghc/compiler/ndpFlatten')
| -rw-r--r-- | ghc/compiler/ndpFlatten/Flattening.hs | 12 | ||||
| -rw-r--r-- | ghc/compiler/ndpFlatten/NDPCoreUtils.hs | 7 | ||||
| -rw-r--r-- | ghc/compiler/ndpFlatten/PArrAnal.hs | 3 |
3 files changed, 14 insertions, 8 deletions
diff --git a/ghc/compiler/ndpFlatten/Flattening.hs b/ghc/compiler/ndpFlatten/Flattening.hs index a28be20911..393762fe40 100644 --- a/ghc/compiler/ndpFlatten/Flattening.hs +++ b/ghc/compiler/ndpFlatten/Flattening.hs @@ -285,11 +285,13 @@ vectorise (Let bind body) = (vbody, vbodyTy) <- vectorise body return ((Let vbind vbody), vbodyTy) -vectorise (Case expr b alts) = +-- gaw 2004 +vectorise (Case expr b ty alts) = do (vexpr, vexprTy) <- vectorise expr valts <- mapM vectorise' alts - return (Case vexpr (setIdType b vexprTy) (map fst valts), snd (head valts)) + let res_ty = snd (head valts) + return (Case vexpr (setIdType b vexprTy) res_ty (map fst valts), res_ty) where vectorise' (con, bs, expr) = do (vexpr, vexprTy) <- vectorise expr @@ -441,7 +443,8 @@ lift (Let (Rec binds) expr2) = -- otherwise (a) compute index vector for simpleAlts (for def permute -- later on -- (b) -lift cExpr@(Case expr b alts) = +-- gaw 2004 FIX? +lift cExpr@(Case expr b _ alts) = do (lExpr, _) <- lift expr lb <- liftBinderType b -- lift alt-expression @@ -802,7 +805,8 @@ showCoreExpr (Let bnds expr) = where showBinds (NonRec b e) = showBind (b,e) showBinds (Rec bnds) = concat (map showBind bnds) showBind (b,e) = " b = " ++ (showCoreExpr e)++ "\n" -showCoreExpr (Case ex b alts) = +-- gaw 2004 FIX? +showCoreExpr (Case ex b ty alts) = "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts) where showAlts _ = "" showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex) diff --git a/ghc/compiler/ndpFlatten/NDPCoreUtils.hs b/ghc/compiler/ndpFlatten/NDPCoreUtils.hs index 1bf74b4866..193f6028aa 100644 --- a/ghc/compiler/ndpFlatten/NDPCoreUtils.hs +++ b/ghc/compiler/ndpFlatten/NDPCoreUtils.hs @@ -163,12 +163,13 @@ substIdEnv env (Let (Rec bnds) expr) = newExpr = substIdEnv newEnv expr substBnd (b,e) = (b, substIdEnv newEnv e) in Let (Rec (map substBnd bnds)) newExpr -substIdEnv env (Case expr b alts) = - Case (substIdEnv newEnv expr) b (map substAlt alts) +-- gaw 2004 +substIdEnv env (Case expr b ty alts) = + Case (substIdEnv newEnv expr) b ty (map substAlt alts) where newEnv = delVarEnv env b substAlt (c, bnds, expr) = (c, bnds, substIdEnv (delVarEnvList env bnds) expr) substIdEnv env (Note n expr) = Note n (substIdEnv env expr) -substIdEnv env e@(Type t) = e
\ No newline at end of file +substIdEnv env e@(Type t) = e diff --git a/ghc/compiler/ndpFlatten/PArrAnal.hs b/ghc/compiler/ndpFlatten/PArrAnal.hs index 46643d1a05..b4d084364b 100644 --- a/ghc/compiler/ndpFlatten/PArrAnal.hs +++ b/ghc/compiler/ndpFlatten/PArrAnal.hs @@ -75,7 +75,8 @@ arrUsage (Let (Rec bnds) expr) = t2 = arrUsage expr in if isArrayUsage t1 then Array else t2 -arrUsage (Case expr b alts) = +-- gaw 2004 +arrUsage (Case expr b _ alts) = let t1 = arrUsage expr t2 = scanType (map (arrUsage . (\ (_,_,x) -> x)) alts) |