X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;ds=sidebyside;f=c%CE%BBash%2FCLasH%2FUtils%2FCore%2FCoreTools.hs;h=a4ea1eca740bbd7f6222781b30259a90a31e7e8c;hb=2cc551233a06fbb34887db4f89ae7d153b81aedd;hp=bf2ca27be3b6717b5262a8f9c1770397924be605;hpb=96a32048f9da6c1ffb1c8fd95a617b7aa4e82e36;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 bf2ca27..a4ea1ec 100644
--- "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs"
+++ "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs"
@@ -7,7 +7,7 @@ module CLasH.Utils.Core.CoreTools where
 
 --Standard modules
 import qualified Maybe
-import System.IO.Unsafe
+import qualified System.IO.Unsafe
 
 -- GHC API
 import qualified GHC
@@ -15,24 +15,18 @@ import qualified Type
 import qualified TcType
 import qualified HsExpr
 import qualified HsTypes
-import qualified HsBinds
 import qualified HscTypes
-import qualified RdrName
 import qualified Name
-import qualified OccName
-import qualified Type
 import qualified Id
 import qualified TyCon
 import qualified DataCon
 import qualified TysWiredIn
-import qualified Bag
 import qualified DynFlags
 import qualified SrcLoc
 import qualified CoreSyn
 import qualified Var
 import qualified IdInfo
 import qualified VarSet
-import qualified Unique
 import qualified CoreUtils
 import qualified CoreFVs
 import qualified Literal
@@ -73,9 +67,8 @@ eval_tfp_int env ty =
 
 normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
 normalise_tfp_int env ty =
-   unsafePerformIO $ do
-     nty <- normaliseType env ty
-     return nty
+   System.IO.Unsafe.unsafePerformIO $
+     normaliseType env ty
 
 -- | Get the width of a SizedWord type
 -- sized_word_len :: HscTypes.HscEnv -> Type.Type -> Int
@@ -155,6 +148,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.
@@ -228,13 +226,21 @@ get_val_args ty args = drop n args
     -- arguments, to get at the value arguments.
     n = length tyvars + length predtypes
 
-getLiterals :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
-getLiterals app@(CoreSyn.App _ _) = literals
+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 _ 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
 
 reduceCoreListToHsList :: 
   [HscTypes.CoreModule] -- ^ The modules where parts of the list are hidden
@@ -269,7 +275,7 @@ reduceCoreListToHsList _ _ = return []
 
 -- Is the given var the State data constructor?
 isStateCon :: Var.Var -> Bool
-isStateCon var = do
+isStateCon var =
   -- See if it is a DataConWrapId (not DataConWorkId, since State is a
   -- newtype).
   case Id.idDetails var of
@@ -381,7 +387,7 @@ genUniques' subst (CoreSyn.Let (CoreSyn.NonRec bndr bound) res) = do
 genUniques' subst (CoreSyn.Let (CoreSyn.Rec binds) res) = do
   -- Make each of the binders unique
   (subst', bndrs') <- mapAccumLM genUnique subst (map fst binds)
-  bounds' <- mapM (genUniques' subst') (map snd binds)
+  bounds' <- mapM (genUniques' subst' . snd) binds
   res' <- genUniques' subst' res
   let binds' = zip bndrs' bounds'
   return $ CoreSyn.Let (CoreSyn.Rec binds') res'