X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=clash%2FCLasH%2FUtils%2FCore%2FCoreTools.hs;h=7d5423ccc16b39ccf2c96e8cd2ee8e4fc0eab242;hb=33091be93e25da149859abb7635a1694b42d4b31;hp=2bb688bb7f0c023a1d9b7986a97eb581f22b808c;hpb=04f836932ad17dd557af0ba388a12d2b74c1e7d7;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/clash/CLasH/Utils/Core/CoreTools.hs b/clash/CLasH/Utils/Core/CoreTools.hs index 2bb688b..7d5423c 100644 --- a/clash/CLasH/Utils/Core/CoreTools.hs +++ b/clash/CLasH/Utils/Core/CoreTools.hs @@ -7,6 +7,7 @@ module CLasH.Utils.Core.CoreTools where --Standard modules import qualified Maybe +import qualified List import qualified System.IO.Unsafe import qualified Data.Map as Map import qualified Data.Accessor.Monad.Trans.State as MonadState @@ -34,6 +35,7 @@ import qualified CoreFVs import qualified Literal import qualified MkCore import qualified VarEnv +import qualified Outputable -- Local imports import CLasH.Translator.TranslatorTypes @@ -147,6 +149,27 @@ tfvec_elem ty = el_ty Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty) [len, el_ty] = args +-- | Gets the index of the given datacon in the given typed thing. +-- Errors out if it does not occur or if the type is not an ADT. +datacon_index :: TypedThing t => t -> DataCon.DataCon -> Int +datacon_index tt dc = case List.elemIndex dc dcs of + Nothing -> error $ "Datacon " ++ pprString dc ++ " does not occur in typed thing: " ++ pprString tt + Just i -> i + where + dcs = datacons_for tt + +-- | Gets all datacons for the given typed thing. Errors out if the +-- typed thing is not ADT typed. +datacons_for :: TypedThing t => t -> [DataCon.DataCon] +datacons_for tt = + case getType tt of + Nothing -> error $ "Getting datacon index of untyped thing? " ++ pprString tt + Just ty -> case Type.splitTyConApp_maybe ty of + Nothing -> error $ "Trying to find datacon in a type without a tycon?" ++ pprString ty + Just (tycon, _) -> case TyCon.tyConDataCons_maybe tycon of + Nothing -> error $ "Trying to find datacon in a type without datacons?" ++ pprString ty + Just dcs -> dcs + -- Is the given core expression a lambda abstraction? is_lam :: CoreSyn.CoreExpr -> Bool is_lam (CoreSyn.Lam _ _) = True @@ -347,7 +370,7 @@ mkNonRecLets bindings expr = MkCore.mkCoreLets binds expr -- | A class of things that (optionally) have a core Type. The type is -- optional, since Type expressions don't have a type themselves. -class TypedThing t where +class Outputable.Outputable t => TypedThing t where getType :: t -> Maybe Type.Type instance TypedThing CoreSyn.CoreExpr where @@ -438,26 +461,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 | dc_i < 0 || dc_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)