X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FUtils%2FCore%2FCoreTools.hs;h=2bb688bb7f0c023a1d9b7986a97eb581f22b808c;hb=6b25abd35ae3cfe2fe42b9d0446d35d0dd118f98;hp=19c12700aa86d23709589687e779d70b82fc23f2;hpb=fc16bdb6576ef2c08d3675fdbf74fd61d5d25589;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs"
index 19c1270..2bb688b 100644
--- "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs"
+++ "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs"
@@ -8,6 +8,8 @@ module CLasH.Utils.Core.CoreTools where
 --Standard modules
 import qualified Maybe
 import qualified System.IO.Unsafe
+import qualified Data.Map as Map
+import qualified Data.Accessor.Monad.Trans.State as MonadState
 
 -- GHC API
 import qualified GHC
@@ -36,6 +38,7 @@ import qualified VarEnv
 -- Local imports
 import CLasH.Translator.TranslatorTypes
 import CLasH.Utils.GhcTools
+import CLasH.Utils.Core.BinderTools
 import CLasH.Utils.HsTools
 import CLasH.Utils.Pretty
 import CLasH.Utils
@@ -45,7 +48,40 @@ import qualified CLasH.Utils.Core.BinderTools as BinderTools
 type Binding = (CoreSyn.CoreBndr, CoreSyn.CoreExpr)
 
 -- | Evaluate a core Type representing type level int from the tfp
--- library to a real int.
+-- library to a real int. Checks if the type really is a Dec type and
+-- caches the results.
+tfp_to_int :: Type.Type -> TypeSession Int
+tfp_to_int ty = do
+  hscenv <- MonadState.get tsHscEnv
+  let norm_ty = normalize_tfp_int hscenv ty
+  case Type.splitTyConApp_maybe norm_ty of
+    Just (tycon, args) -> do
+      let name = Name.getOccString (TyCon.tyConName tycon)
+      case name of
+        "Dec" ->
+          tfp_to_int' ty
+        otherwise -> do
+          return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
+    Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
+
+-- | Evaluate a core Type representing type level int from the tfp
+-- library to a real int. Caches the results. Do not use directly, use
+-- tfp_to_int instead.
+tfp_to_int' :: Type.Type -> TypeSession Int
+tfp_to_int' ty = do
+  lens <- MonadState.get tsTfpInts
+  hscenv <- MonadState.get tsHscEnv
+  let norm_ty = normalize_tfp_int hscenv ty
+  let existing_len = Map.lookup (OrdType norm_ty) lens
+  case existing_len of
+    Just len -> return len
+    Nothing -> do
+      let new_len = eval_tfp_int hscenv ty
+      MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
+      return new_len
+      
+-- | Evaluate a core Type representing type level int from the tfp
+-- library to a real int. Do not use directly, use tfp_to_int instead.
 eval_tfp_int :: HscTypes.HscEnv -> Type.Type -> Int
 eval_tfp_int env ty =
   unsafeRunGhc libdir $ do
@@ -65,15 +101,11 @@ eval_tfp_int env ty =
     libdir = DynFlags.topDir dynflags
     dynflags = HscTypes.hsc_dflags env
 
-normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
-normalise_tfp_int env ty =
+normalize_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
+normalize_tfp_int env ty =
    System.IO.Unsafe.unsafePerformIO $
-     normaliseType env ty
+     normalizeType env ty
 
--- | Get the width of a SizedWord type
--- sized_word_len :: HscTypes.HscEnv -> Type.Type -> Int
--- sized_word_len env ty = eval_tfp_int env (sized_word_len_ty ty)
-    
 sized_word_len_ty :: Type.Type -> Type.Type
 sized_word_len_ty ty = len
   where
@@ -82,10 +114,6 @@ sized_word_len_ty ty = len
       Nothing -> error $ "\nCoreTools.sized_word_len_ty: Not a sized word type: " ++ (pprString ty)
     [len]         = args
 
--- | Get the width of a SizedInt type
--- sized_int_len :: HscTypes.HscEnv -> Type.Type -> Int
--- sized_int_len env ty = eval_tfp_int env (sized_int_len_ty ty)
-
 sized_int_len_ty :: Type.Type -> Type.Type
 sized_int_len_ty ty = len
   where
@@ -94,10 +122,6 @@ sized_int_len_ty ty = len
       Nothing -> error $ "\nCoreTools.sized_int_len_ty: Not a sized int type: " ++ (pprString ty)
     [len]         = args
     
--- | Get the upperbound of a RangedWord type
--- ranged_word_bound :: HscTypes.HscEnv -> Type.Type -> Int
--- ranged_word_bound env ty = eval_tfp_int env (ranged_word_bound_ty ty)
-    
 ranged_word_bound_ty :: Type.Type -> Type.Type
 ranged_word_bound_ty ty = len
   where
@@ -106,26 +130,6 @@ ranged_word_bound_ty ty = len
       Nothing -> error $ "\nCoreTools.ranged_word_bound_ty: Not a sized word type: " ++ (pprString ty)
     [len]         = args
 
--- | Evaluate a core Type representing type level int from the TypeLevel
--- library to a real int.
--- eval_type_level_int :: Type.Type -> Int
--- eval_type_level_int ty =
---   unsafeRunGhc $ do
---     -- Automatically import modules for any fully qualified identifiers
---     setDynFlag DynFlags.Opt_ImplicitImportQualified
--- 
---     let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
---     let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
---     let undef = hsTypedUndef $ coreToHsType ty
---     let app = HsExpr.HsApp (to_int) (undef)
--- 
---     core <- toCore [] app
---     execCore core 
-
--- | Get the length of a FSVec type
--- tfvec_len :: HscTypes.HscEnv -> Type.Type -> Int
--- tfvec_len env ty = eval_tfp_int env (tfvec_len_ty ty)
-
 tfvec_len_ty :: Type.Type -> Type.Type
 tfvec_len_ty ty = len
   where  
@@ -148,6 +152,11 @@ is_lam :: CoreSyn.CoreExpr -> Bool
 is_lam (CoreSyn.Lam _ _) = True
 is_lam _ = False
 
+-- Is the given core expression a let expression?
+is_let :: CoreSyn.CoreExpr -> Bool
+is_let (CoreSyn.Let _ _) = True
+is_let _ = False
+
 -- Is the given core expression of a function type?
 is_fun :: CoreSyn.CoreExpr -> Bool
 -- Treat Type arguments differently, because exprType is not defined for them.
@@ -221,21 +230,27 @@ get_val_args ty args = drop n args
     -- arguments, to get at the value arguments.
     n = length tyvars + length predtypes
 
-getLiterals :: HscTypes.HscEnv -> CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
-getLiterals _ app@(CoreSyn.App _ _) = literals
-  where
-    (CoreSyn.Var f, args) = CoreSyn.collectArgs app
-    literals = filter (is_lit) args
-
-getLiterals _ lit@(CoreSyn.Lit _) = [lit]
-
-getLiterals hscenv letrec@(CoreSyn.Let (CoreSyn.NonRec letBind (letExpr)) letRes) = [lit]
-  where
-    ty     = Var.varType letBind
-    litInt = eval_tfp_int hscenv ty
-    lit    = CoreSyn.Lit (Literal.mkMachInt (toInteger litInt))
-
-getLiterals _ expr = error $ "\nCoreTools.getLiterals: Not a known Lit: " ++ pprString expr
+-- Finds out what literal Integer this expression represents.
+getIntegerLiteral :: CoreSyn.CoreExpr -> TranslatorSession Integer
+getIntegerLiteral expr =
+  case CoreSyn.collectArgs expr of
+    (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachInt integer)]) 
+      | getFullString f == "GHC.Integer.smallInteger" -> return integer
+    (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachInt64 integer)]) 
+      | getFullString f == "GHC.Integer.int64ToInteger" -> return integer
+    (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachWord integer)]) 
+      | getFullString f == "GHC.Integer.wordToInteger" -> return integer
+    (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachWord64 integer)]) 
+      | getFullString f == "GHC.Integer.word64ToInteger" -> return integer
+    -- fromIntegerT returns the integer corresponding to the type of its
+    -- (third) argument. Since it is polymorphic, the type of that
+    -- argument is passed as the first argument, so we can just use that
+    -- one.
+    (CoreSyn.Var f, [CoreSyn.Type dec_ty, dec_dict, CoreSyn.Type num_ty, num_dict, arg]) 
+      | getFullString f == "Types.Data.Num.Ops.fromIntegerT" -> do
+          int <- MonadState.lift tsType $ tfp_to_int dec_ty
+          return $ toInteger int
+    _ -> error $ "CoreTools.getIntegerLiteral: Unsupported Integer literal: " ++ pprString expr
 
 reduceCoreListToHsList :: 
   [HscTypes.CoreModule] -- ^ The modules where parts of the list are hidden
@@ -422,3 +437,27 @@ genUnique subst bndr = do
   -- binder.
   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
+  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
+      -- 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)