Don't mix up the i and dc_i variables.

[matthijs/master-project/cλash.git] / clash / CLasH / Utils / Core / CoreTools.hs

diff --git a/clash/CLasH/Utils/Core/CoreTools.hs b/clash/CLasH/Utils/Core/CoreTools.hs
index 2bb688bb7f0c023a1d9b7986a97eb581f22b808c..c7bce65eeceabaa27b691ce929a8117014ff8e57 100644 (file)
--- 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,20 @@ 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 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 -> case List.elemIndex dc dcs of
+          Nothing -> error $ "Datacon " ++ pprString dc ++ " does not occur in type: " ++ pprString ty
+          Just i -> i
+
 -- Is the given core expression a lambda abstraction?
 is_lam :: CoreSyn.CoreExpr -> Bool
 is_lam (CoreSyn.Lam _ _) = True
@@ -347,7 +363,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 +454,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)