VERY Ad-hoc support of literals.

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

diff --git a/NormalizeTools.hs b/NormalizeTools.hs
index f016cfa9fc34684604a8efe487ac8f254297d5c3..85fae47e8f66a19865f281ee25e642d9dca1f16f 100644 (file)
--- a/NormalizeTools.hs
+++ b/NormalizeTools.hs
@@ -7,6 +7,7 @@ module NormalizeTools where
 import Debug.Trace
 import qualified List
 import qualified Data.Monoid as Monoid
 import Debug.Trace
 import qualified List
 import qualified Data.Monoid as Monoid

+import qualified Data.Either as Either

 import qualified Control.Arrow as Arrow
 import qualified Control.Monad as Monad
 import qualified Control.Monad.Trans.State as State
 import qualified Control.Arrow as Arrow
 import qualified Control.Monad as Monad
 import qualified Control.Monad.Trans.State as State


@@ -14,6 +15,7 @@ import qualified Control.Monad.Trans.Writer as Writer
 import qualified "transformers" Control.Monad.Trans as Trans
 import qualified Data.Map as Map
 import Data.Accessor
 import qualified "transformers" Control.Monad.Trans as Trans
 import qualified Data.Map as Map
 import Data.Accessor

+import Data.Accessor.MonadState as MonadState

 
 -- GHC API
 import CoreSyn
 
 -- GHC API
 import CoreSyn


@@ -32,6 +34,8 @@ import Outputable ( showSDoc, ppr, nest )
 
 -- Local imports
 import NormalizeTypes
 
 -- Local imports
 import NormalizeTypes

+import Pretty
+import qualified VHDLTools

 
 -- Create a new internal var with the given name and type. A Unique is
 -- appended to the given name, to ensure uniqueness (not strictly neccesary,
 
 -- Create a new internal var with the given name and type. A Unique is
 -- appended to the given name, to ensure uniqueness (not strictly neccesary,


@@ -156,7 +160,7 @@ subeverywhere trans (Cast expr ty) = do
   expr' <- trans expr
   return $ Cast expr' ty
 
   expr' <- trans expr
   return $ Cast expr' ty
 

-subeverywhere trans expr = error $ "NormalizeTools.subeverywhere Unsupported expression: " ++ show expr
+subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr

 
 -- Apply the given transformation to all expressions, except for direct
 -- arguments of an application
 
 -- Apply the given transformation to all expressions, except for direct
 -- arguments of an application


@@ -182,14 +186,23 @@ dotransforms transs expr = do
   if Monoid.getAny changed then dotransforms transs expr' else return expr'
 
 -- Inline all let bindings that satisfy the given condition
   if Monoid.getAny changed then dotransforms transs expr' else return expr'
 
 -- Inline all let bindings that satisfy the given condition

-inlinebind :: ((CoreBndr, CoreExpr) -> Bool) -> Transform
-inlinebind condition (Let (Rec binds) expr) | not $ null replace =
-    change newexpr
+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 
   where 

-    -- Find all simple bindings
-    (replace, others) = List.partition condition binds
-    -- Substitute the to be replaced binders with their expression
-    newexpr = substitute replace (Let (Rec others) expr)
+    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
+

 -- Leave all other expressions unchanged
 inlinebind _ expr = return expr
 
 -- Leave all other expressions unchanged
 inlinebind _ expr = return expr
 


@@ -234,5 +247,9 @@ substitute ((b, e):subss) expr = substitute subss' expr'
 -- Run a given TransformSession. Used mostly to setup the right calls and
 -- an initial state.
 runTransformSession :: UniqSupply.UniqSupply -> TransformSession a -> a
 -- Run a given TransformSession. Used mostly to setup the right calls and
 -- an initial state.
 runTransformSession :: UniqSupply.UniqSupply -> TransformSession a -> a

-runTransformSession uniqSupply session = State.evalState session initState
-                       where initState = TransformState uniqSupply Map.empty VarSet.emptyVarSet
+runTransformSession uniqSupply session = State.evalState session (emptyTransformState uniqSupply)
+
+-- 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)