Add predicates for testing representability of types.

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

diff --git a/NormalizeTools.hs b/NormalizeTools.hs
index 25c9273d8fb38ef4810f6207925aa8e109251e73..5ea3a7db8ab852fce0a7dd8529573e718ff2e7eb 100644 (file)
--- a/NormalizeTools.hs
+++ b/NormalizeTools.hs
@@ -7,12 +7,14 @@ module NormalizeTools where
 import Debug.Trace
 import qualified List
 import qualified Data.Monoid as Monoid
+import qualified Control.Arrow as Arrow
 import qualified Control.Monad as Monad
 import qualified Control.Monad.Trans.State as State
 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 Data.Accessor.MonadState as MonadState
 
 -- GHC API
 import CoreSyn
@@ -31,6 +33,8 @@ import Outputable ( showSDoc, ppr, nest )
 
 -- 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,
@@ -118,6 +122,11 @@ subeverywhere trans (App a b) = do
   b' <- trans b
   return $ App a' b'
 
+subeverywhere trans (Let (NonRec b bexpr) expr) = do
+  bexpr' <- trans bexpr
+  expr' <- trans expr
+  return $ Let (NonRec b bexpr') expr'
+
 subeverywhere trans (Let (Rec binds) expr) = do
   expr' <- trans expr
   binds' <- mapM transbind binds
@@ -141,26 +150,33 @@ subeverywhere trans (Case scrut b t alts) = do
     transalt (con, binders, expr) = do
       expr' <- trans expr
       return (con, binders, expr')
-      
 
-subeverywhere trans expr = return expr
+subeverywhere trans (Var x) = return $ Var x
+subeverywhere trans (Lit x) = return $ Lit x
+subeverywhere trans (Type x) = return $ Type x
+
+subeverywhere trans (Cast expr ty) = do
+  expr' <- trans expr
+  return $ Cast expr' ty
 
--- Apply the given transformation to all expressions, except for every first
--- argument of an application.
-notapplied :: (String, Transform) -> Transform
-notapplied trans = applyboth (subnotapplied trans) trans
+subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
+
+-- Apply the given transformation to all expressions, except for direct
+-- arguments of an application
+notappargs :: (String, Transform) -> Transform
+notappargs trans = applyboth (subnotappargs trans) trans
 
 -- Apply the given transformation to all (direct and indirect) subexpressions
--- (but not the expression itself), except for the first argument of an
--- applicfirst argument of an application
-subnotapplied :: (String, Transform) -> Transform
-subnotapplied trans (App a b) = do
-  a' <- subnotapplied trans a
-  b' <- notapplied trans b
+-- (but not the expression itself), except for direct arguments of an
+-- application
+subnotappargs :: (String, Transform) -> Transform
+subnotappargs trans (App a b) = do
+  a' <- subnotappargs trans a
+  b' <- subnotappargs trans b
   return $ App a' b'
 
 -- Let subeverywhere handle all other expressions
-subnotapplied trans expr = subeverywhere (notapplied trans) expr
+subnotappargs trans expr = subeverywhere (notappargs trans) expr
 
 -- Runs each of the transforms repeatedly inside the State monad.
 dotransforms :: [Transform] -> CoreExpr -> TransformSession CoreExpr
@@ -202,11 +218,28 @@ mkUnique = Trans.lift $ do
 -- Replace each of the binders given with the coresponding expressions in the
 -- given expression.
 substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
-substitute replace expr = CoreSubst.substExpr subs expr
-    where subs = foldl (\s (b, e) -> CoreSubst.extendSubst s b e) CoreSubst.emptySubst replace
+substitute [] expr = expr
+-- Apply one substitution on the expression, but also on any remaining
+-- substitutions. This seems to be the only way to handle substitutions like
+-- [(b, c), (a, b)]. This means we reuse a substitution, which is not allowed
+-- according to CoreSubst documentation (but it doesn't seem to be a problem).
+-- TODO: Find out how this works, exactly.
+substitute ((b, e):subss) expr = substitute subss' expr'
+  where 
+    -- Create the Subst
+    subs = (CoreSubst.extendSubst CoreSubst.emptySubst b e)
+    -- Apply this substitution to the main expression
+    expr' = CoreSubst.substExpr subs expr
+    -- Apply this substitution on all the expressions in the remaining
+    -- substitutions
+    subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss
 
 -- 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)