From 3858748d71e47b52ddc1b464df804ec21bebaeff Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Wed, 9 Jun 2010 22:27:58 +0200 Subject: [PATCH] Make casesimpl support multiple-alt cases with fields. --- clash/CLasH/Normalize.hs | 11 +++++--- clash/CLasH/Utils/Core/CoreTools.hs | 44 +++++++++++++++++------------ 2 files changed, 33 insertions(+), 22 deletions(-) diff --git a/clash/CLasH/Normalize.hs b/clash/CLasH/Normalize.hs index 11212f9..72885b7 100644 --- 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 2bb688b..e98aec6 100644 --- 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) -- 2.30.2