Make casesimpl support multiple-alt cases with fields.

diff --git a/clash/CLasH/Normalize.hs b/clash/CLasH/Normalize.hs
index 11212f943df0678a4b9cef09fb52657ba06bc2dd..72885b7b9cd4f3c9ae00f9853ac0f102ea91b57b 100644 (file)
--- a/clash/CLasH/Normalize.hs
+++ b/clash/CLasH/Normalize.hs
@@ -489,7 +489,9 @@ casesimpl c expr@(Case scrut bndr ty alts) | not bndr_used = do
   -- Wilden the binders of one alt, producing a list of bindings as a
   -- sideeffect.
   doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt)
-  doalt (con, bndrs, expr) = do
+  doalt (LitAlt _, _, _) = error $ "Don't know how to handle LitAlt in case expression: " ++ pprString expr
+  doalt alt@(DEFAULT, [], expr) = return ([], alt)
+  doalt (DataAlt dc, bndrs, expr) = do
     -- Make each binder wild, if possible
     bndrs_res <- Monad.zipWithM dobndr bndrs [0..]
     let (newbndrs, bindings_maybe) = unzip bndrs_res
@@ -499,7 +501,7 @@ casesimpl c expr@(Case scrut bndr ty alts) | not bndr_used = do
     let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) expr
     (exprbinding_maybe, expr') <- doexpr expr uses_bndrs
     -- Create a new alternative
-    let newalt = (con, newbndrs, expr')
+    let newalt = (DataAlt dc, newbndrs, expr')
     let bindings = Maybe.catMaybes (bindings_maybe ++ [exprbinding_maybe])
     return (bindings, newalt)
     where
@@ -521,7 +523,8 @@ casesimpl c expr@(Case scrut bndr ty alts) | not bndr_used = do
         -- inlinenonrep).
         if (not wild) && repr
           then do
-            caseexpr <- Trans.lift $ mkSelCase scrut i
+            let dc_i = datacon_index (CoreUtils.exprType scrut) dc
+            caseexpr <- Trans.lift $ mkSelCase scrut dc_i i
             -- Create a new binder that will actually capture a value in this
             -- case statement, and return it.
             return (wildbndrs!!i, Just (b, caseexpr))
@@ -793,7 +796,7 @@ inlinenonrepresult context expr | not (is_applicable expr) && not (has_free_tyva
                   res_bndr <- Trans.lift $ mkBinderFor newapp "res"
                   -- Create extractor case expressions to extract each of the
                   -- free variables from the tuple.
-                  sel_cases <- Trans.lift $ mapM (mkSelCase (Var res_bndr)) [0..n_free_vars-1]
+                  sel_cases <- Trans.lift $ mapM (mkSelCase (Var res_bndr) 0) [0..n_free_vars-1]
 
                   -- Bind the res_bndr to the result of the new application
                   -- and each of the free variables to the corresponding

diff --git a/clash/CLasH/Utils/Core/CoreTools.hs b/clash/CLasH/Utils/Core/CoreTools.hs
index 2bb688bb7f0c023a1d9b7986a97eb581f22b808c..e98aec6a090ab2abc77d15251ac25850054c3185 100644 (file)
--- a/clash/CLasH/Utils/Core/CoreTools.hs
+++ b/clash/CLasH/Utils/Core/CoreTools.hs
@@ -438,26 +438,34 @@ genUnique subst bndr = do
   let subst' = VarEnv.extendVarEnv subst bndr bndr'
   return (subst', bndr')
 
--- Create a "selector" case that selects the ith field from a datacon
-mkSelCase :: CoreSyn.CoreExpr -> Int -> TranslatorSession CoreSyn.CoreExpr
-mkSelCase scrut i = do
-  let scrut_ty = CoreUtils.exprType scrut
+-- Create a "selector" case that selects the ith field from dc_ith
+-- datacon
+mkSelCase :: CoreSyn.CoreExpr -> Int -> Int -> TranslatorSession CoreSyn.CoreExpr
+mkSelCase scrut dc_i i = do
   case Type.splitTyConApp_maybe scrut_ty of
     -- The scrutinee should have a type constructor. We keep the type
     -- arguments around so we can instantiate the field types below
-    Just (tycon, tyargs) -> case TyCon.tyConDataCons tycon of
+    Just (tycon, tyargs) -> case TyCon.tyConDataCons_maybe tycon of
       -- The scrutinee type should have a single dataconstructor,
       -- otherwise we can't construct a valid selector case.
-      [datacon] -> do
-        let field_tys = DataCon.dataConInstOrigArgTys datacon tyargs
-        -- Create a list of wild binders for the fields we don't want
-        let wildbndrs = map MkCore.mkWildBinder field_tys
-        -- Create a single binder for the field we want
-        sel_bndr <- mkInternalVar "sel" (field_tys!!i)
-        -- Create a wild binder for the scrutinee
-        let scrut_bndr = MkCore.mkWildBinder scrut_ty
-        -- Create the case expression
-        let binders = take i wildbndrs ++ [sel_bndr] ++ drop (i+1) wildbndrs
-        return $ CoreSyn.Case scrut scrut_bndr scrut_ty [(CoreSyn.DataAlt datacon, binders, CoreSyn.Var sel_bndr)]
-      dcs -> error $ "CoreTools.mkSelCase: Scrutinee type must have exactly one datacon. Extracting element " ++ (show i) ++ " from '" ++ pprString scrut ++ "' Datacons: " ++ (show dcs) ++ " Type: " ++ (pprString scrut_ty)
-    Nothing -> error $ "CoreTools.mkSelCase: Creating extractor case, but scrutinee has no tycon? Extracting element " ++ (show i) ++ " from '" ++ pprString scrut ++ "'" ++ " Type: " ++ (pprString scrut_ty)
+      Just dcs | i < 0 || i >= length dcs -> error $ "\nCoreTools.mkSelCase: Creating extractor case, but datacon index is invalid." ++ error_msg
+               | otherwise -> do
+        let datacon = (dcs!!dc_i)
+        let field_tys = DataCon.dataConInstOrigArgTys datacon  tyargs
+        if i < 0 || i >= length field_tys
+          then error $ "\nCoreTools.mkSelCase: Creating extractor case, but field index is invalid." ++ error_msg
+          else do
+            -- Create a list of wild binders for the fields we don't want
+            let wildbndrs = map MkCore.mkWildBinder field_tys
+            -- Create a single binder for the field we want
+            sel_bndr <- mkInternalVar "sel" (field_tys!!i)
+            -- Create a wild binder for the scrutinee
+            let scrut_bndr = MkCore.mkWildBinder scrut_ty
+            -- Create the case expression
+            let binders = take i wildbndrs ++ [sel_bndr] ++ drop (i+1) wildbndrs
+            return $ CoreSyn.Case scrut scrut_bndr scrut_ty [(CoreSyn.DataAlt datacon, binders, CoreSyn.Var sel_bndr)]
+      Nothing -> error $ "CoreTools.mkSelCase: Creating extractor case, but scrutinee has no datacons?" ++ error_msg
+    Nothing -> error $ "CoreTools.mkSelCase: Creating extractor case, but scrutinee has no tycon?" ++ error_msg
+  where
+    scrut_ty = CoreUtils.exprType scrut
+    error_msg = " Extracting element " ++ (show i) ++ " from datacon " ++ (show dc_i) ++ " from '" ++ pprString scrut ++ "'" ++ " Type: " ++ (pprString scrut_ty)