--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
import qualified Literal
import qualified MkCore
import qualified VarEnv
+import qualified Outputable
-- Local imports
import CLasH.Translator.TranslatorTypes
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
-- | 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
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)