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 "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
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,
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,
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
-- 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
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
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
+
+subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
-- Apply the given transformation to all expressions, except for direct
-- arguments of an application
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
-- 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
projects / matthijs / master-project / cλash.git / blobdiff