X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=NormalizeTools.hs;h=920d28bdcefa171f8bfa3437f727fa3df25f5dbf;hb=b8c1e8554ba8aee73bc9d9a54bb3cb32f7930957;hp=f016cfa9fc34684604a8efe487ac8f254297d5c3;hpb=dfdf88c20bacf8f8e7863cf7a41c86c869735f6f;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/NormalizeTools.hs b/NormalizeTools.hs
index f016cfa..920d28b 100644
--- 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 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
@@ -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 Data.Accessor.MonadState as MonadState
 
 -- GHC API
 import CoreSyn
@@ -28,10 +30,14 @@ import qualified IdInfo
 import qualified CoreUtils
 import qualified CoreSubst
 import qualified VarSet
+import qualified HscTypes
 import Outputable ( showSDoc, ppr, nest )
 
 -- Local imports
 import NormalizeTypes
+import Pretty
+import VHDLTypes
+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,
@@ -42,7 +48,7 @@ mkInternalVar str ty = do
   uniq <- mkUnique
   let occname = OccName.mkVarOcc (str ++ show uniq)
   let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
-  return $ Var.mkLocalIdVar name ty IdInfo.vanillaIdInfo
+  return $ Var.mkLocalVar IdInfo.VanillaId name ty IdInfo.vanillaIdInfo
 
 -- Create a new type variable with the given name and kind. A Unique is
 -- appended to the given name, to ensure uniqueness (not strictly neccesary,
@@ -73,7 +79,7 @@ cloneVar v = do
   uniq <- mkUnique
   -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it
   -- contains, but vannillaIdInfo is always correct, since it means "no info").
-  return $ Var.lazySetVarIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo
+  return $ Var.lazySetIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo
 
 -- Creates a new function with the same name as the given binder (but with a
 -- new unique) and with the given function body. Returns the new binder for
@@ -100,15 +106,15 @@ applyboth first (name, second) expr  = do
   -- Apply the second
   (expr'', changed) <- Writer.listen $ second expr'
   if Monoid.getAny $
-  --      trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
+--        trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
         changed 
     then 
 --      trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
- --     trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
+--      trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
       applyboth first (name, second) $
         expr'' 
     else 
-    --  trace ("No changes") $
+--      trace ("No changes") $
       return expr''
 
 -- Apply the given transformation to all direct subexpressions (only), not the
@@ -156,7 +162,7 @@ subeverywhere trans (Cast expr ty) = do
   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
@@ -182,14 +188,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
-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 
-    -- 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
 
@@ -233,6 +248,19 @@ 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
-runTransformSession uniqSupply session = State.evalState session initState
-                       where initState = TransformState uniqSupply Map.empty VarSet.emptyVarSet
+runTransformSession :: HscTypes.HscEnv -> UniqSupply.UniqSupply -> TransformSession a -> a
+runTransformSession env uniqSupply session = State.evalState session emptyTransformState
+  where
+    emptyTypeState = TypeState Map.empty [] Map.empty Map.empty env
+    emptyTransformState = TransformState uniqSupply Map.empty VarSet.emptyVarSet emptyTypeState
+
+-- 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)
+
+is_local_var :: CoreSyn.CoreExpr -> TransformSession Bool
+is_local_var (CoreSyn.Var v) = do
+  bndrs <- getGlobalBinders
+  return $ not $ v `elem` bndrs
+is_local_var _ = return False