Make isRepr work on TypedThings instead of CoreExpr.

[matthijs/master-project/cλash.git] / cλash / CLasH / Normalize / NormalizeTools.hs

diff --git a/cλash/CLasH/Normalize/NormalizeTools.hs b/cλash/CLasH/Normalize/NormalizeTools.hs
index b26cb74359c12da06c2c1e1a5556cc4a44a20a32..f38da518e8535b68e4f560fdbae021db1d1b7af9 100644 (file)
--- a/cλash/CLasH/Normalize/NormalizeTools.hs
+++ b/cλash/CLasH/Normalize/NormalizeTools.hs
@@ -20,6 +20,8 @@ import Data.Accessor.MonadState as MonadState
 
 -- GHC API
 import CoreSyn
+import qualified Name
+import qualified Id
 import qualified CoreSubst
 import qualified CoreUtils
 import Outputable ( showSDoc, ppr, nest )
@@ -28,6 +30,7 @@ import Outputable ( showSDoc, ppr, nest )
 import CLasH.Normalize.NormalizeTypes
 import CLasH.Translator.TranslatorTypes
 import CLasH.Utils.Pretty
+import qualified CLasH.Utils.Core.CoreTools as CoreTools
 import CLasH.VHDL.VHDLTypes
 import qualified CLasH.VHDL.VHDLTools as VHDLTools
 
@@ -128,22 +131,15 @@ dotransforms transs expr = do
 
 -- Inline all let bindings that satisfy the given condition
 inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
-inlinebind condition expr@(Let (Rec binds) res) = do
-    -- Find all bindings that adhere to the condition
-    res_eithers <- mapM docond binds
-    case Either.partitionEithers res_eithers of
-      -- No replaces? No change
-      ([], _) -> return expr
-      (replace, others) -> do
-        -- Substitute the to be replaced binders with their expression
-        let newexpr = substitute replace (Let (Rec others) res)
-        change newexpr
-  where 
-    docond :: (CoreBndr, CoreExpr) -> TransformMonad (Either (CoreBndr, CoreExpr) (CoreBndr, CoreExpr))
-    docond b = do
-      res <- condition b
-      return $ case res of True -> Left b; False -> Right b
-
+inlinebind condition expr@(Let (NonRec bndr expr') res) = do
+    applies <- condition (bndr, expr')
+    if applies
+      then
+        -- Substitute the binding in res and return that
+        change $ substitute [(bndr, expr')] res
+      else
+        -- Don't change this let
+        return expr
 -- Leave all other expressions unchanged
 inlinebind _ expr = return expr
 
@@ -158,6 +154,12 @@ change val = do
   setChanged
   return val
 
+-- Returns the given value and sets the changed flag if the bool given is
+-- True. Note that this will not unset the changed flag if the bool is False.
+changeif :: Bool -> a -> TransformMonad a
+changeif True val = change val
+changeif False val = return val
+
 -- Replace each of the binders given with the coresponding expressions in the
 -- given expression.
 substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
@@ -178,12 +180,26 @@ substitute ((b, e):subss) expr = substitute subss' expr'
     subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss
 
 -- Is the given expression representable at runtime, based on the type?
-isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool
-isRepr (Type ty) = return False
-isRepr expr = Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType (CoreUtils.exprType expr)
+isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
+isRepr tything = case CoreTools.getType tything of
+  Nothing -> return False
+  Just ty -> Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType ty 
 
 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
 is_local_var (CoreSyn.Var v) = do
   bndrs <- getGlobalBinders
   return $ not $ v `elem` bndrs
 is_local_var _ = return False
+
+-- Is the given binder defined by the user?
+isUserDefined :: CoreSyn.CoreBndr -> Bool
+-- System names are certain to not be user defined
+isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
+-- Check a list of typical compiler-defined names
+isUserDefined bndr = str `elem` compiler_names
+  where
+    str = Name.getOccString bndr
+    -- These are names of bindings usually generated by the compiler. For some
+    -- reason these are not marked as system, probably because the name itself
+    -- is not made up by the compiler, just this particular binding is.
+    compiler_names = ["fromInteger"]