-- top level function "normalize", and defines the actual transformation passes that
-- are performed.
--
-module Normalize (normalize) where
+module Normalize (normalizeModule) where
-- Standard modules
import Debug.Trace
import qualified Maybe
import qualified Control.Monad as Monad
+import qualified Data.Map as Map
+import Data.Accessor
-- GHC API
import CoreSyn
import qualified CoreUtils
import qualified Type
import qualified Id
-import qualified UniqSet
+import qualified VarSet
import qualified CoreFVs
import Outputable ( showSDoc, ppr, nest )
-- based on Just we return here.
return $ (Just (id, expr), (con, bndrs, Var id))
-- Find if any of the binders are used by expr
- where usesvars = (not . UniqSet.isEmptyUniqSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
+ where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
-- Don't simplify anything else
doalt alt = return (Nothing, alt)
-- Leave all other expressions unchanged
-- Replace a useless case by the value of its single alternative
caseremove (Case scrut b ty [(con, bndrs, expr)]) | not usesvars = change expr
-- Find if any of the binders are used by expr
- where usesvars = (not . UniqSet.isEmptyUniqSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
+ where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
-- Leave all other expressions unchanged
caseremove expr = return expr
-- Perform this transform everywhere
-- What transforms to run?
transforms = [etatop, betatop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop]
--- Normalize a core expression by running transforms until none applies
--- anymore. Uses a UniqSupply to generate new identifiers.
-normalize :: UniqSupply.UniqSupply -> CoreExpr -> CoreExpr
-normalize = dotransforms transforms
+-- Turns the given bind into VHDL
+normalizeModule ::
+ UniqSupply.UniqSupply -- ^ A UniqSupply we can use
+ -> [(CoreBndr, CoreExpr)] -- ^ All bindings we know (i.e., in the current module)
+ -> [CoreBndr] -- ^ The bindings to generate VHDL for (i.e., the top level bindings)
+ -> [Bool] -- ^ For each of the bindings to generate VHDL for, if it is stateful
+ -> [(CoreBndr, CoreExpr)] -- ^ The resulting VHDL
+normalizeModule uniqsupply bindings generate_for statefuls = runTransformSession uniqsupply $ do
+ -- Put all the bindings in this module in the tsBindings map
+ putA tsBindings (Map.fromList bindings)
+ -- (Recursively) normalize each of the requested bindings
+ mapM normalizeBind generate_for
+ -- Get all initial bindings and the ones we produced
+ bindings_map <- getA tsBindings
+ let bindings = Map.assocs bindings_map
+ normalized_bindings <- getA tsNormalized
+ -- But return only the normalized bindings
+ return $ filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings
+
+normalizeBind :: CoreBndr -> TransformSession ()
+normalizeBind bndr = do
+ normalized_funcs <- getA tsNormalized
+ -- See if this function was normalized already
+ if VarSet.elemVarSet bndr normalized_funcs
+ then
+ -- Yup, don't do it again
+ return ()
+ else do
+ -- Nope, note that it has been and do it.
+ modA tsNormalized (flip VarSet.extendVarSet bndr)
+ expr_maybe <- getGlobalBind bndr
+ case expr_maybe of
+ Just expr -> do
+ -- Normalize this expression
+ expr' <- dotransforms transforms expr
+ let expr'' = trace ("Before:\n\n" ++ showSDoc ( ppr expr ) ++ "\n\nAfter:\n\n" ++ showSDoc ( ppr expr')) expr'
+ -- And store the normalized version in the session
+ modA tsBindings (Map.insert bndr expr'')
+ -- Find all vars used with a function type. All of these should be global
+ -- binders (i.e., functions used), since any local binders with a function
+ -- type should have been inlined already.
+ let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> trace (showSDoc $ ppr $ Id.idType v) ((Type.isFunTy . snd . Type.splitForAllTys . Id.idType)v)) expr''
+ let used_funcs = VarSet.varSetElems used_funcs_set
+ -- Process each of the used functions recursively
+ mapM normalizeBind (trace (show used_funcs) used_funcs)
+ return ()
+ -- We don't have a value for this binder, let's assume this is a builtin
+ -- function. This might need some extra checking and a nice error
+ -- message).
+ Nothing -> return ()
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
-- GHC API
import qualified IdInfo
import qualified CoreUtils
import qualified CoreSubst
+import qualified VarSet
import Outputable ( showSDoc, ppr, nest )
-- Local imports
-- Let subeverywhere handle all other expressions
subnotapplied trans expr = subeverywhere (notapplied trans) expr
--- Run the given transforms over the given expression
-dotransforms :: [Transform] -> UniqSupply.UniqSupply -> CoreExpr -> CoreExpr
-dotransforms transs uniqSupply = (flip State.evalState initState) . (dotransforms' transs)
- where initState = TransformState uniqSupply
-
-- Runs each of the transforms repeatedly inside the State monad.
-dotransforms' :: [Transform] -> CoreExpr -> State.State TransformState CoreExpr
-dotransforms' transs expr = do
+dotransforms :: [Transform] -> CoreExpr -> TransformSession CoreExpr
+dotransforms transs expr = do
(expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
- if Monoid.getAny changed then dotransforms' transs expr' else return expr'
+ 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
substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
substitute replace expr = CoreSubst.substExpr subs expr
where subs = foldl (\s (b, e) -> CoreSubst.extendIdSubst s b e) CoreSubst.emptySubst replace
+
+-- 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
import qualified Control.Monad.Trans.State as State
import qualified Data.Monoid as Monoid
import qualified Data.Accessor.Template
+import Data.Accessor
+import qualified Data.Map as Map
import Debug.Trace
-- GHC API
import CoreSyn
import qualified UniqSupply
+import qualified VarSet
import Outputable ( Outputable, showSDoc, ppr )
-- Local imports
import Pretty
data TransformState = TransformState {
- tsUniqSupply_ :: UniqSupply.UniqSupply
+ tsUniqSupply_ :: UniqSupply.UniqSupply
+ , tsBindings_ :: Map.Map CoreBndr CoreExpr
+ , tsNormalized_ :: VarSet.VarSet -- ^ The binders that have been normalized
}
$( Data.Accessor.Template.deriveAccessors ''TransformState )
-type TransformMonad a = Writer.WriterT Monoid.Any (State.State TransformState) a
+-- A session of multiple transformations over multiple expressions
+type TransformSession = (State.State TransformState)
+-- Wrap a writer around a TransformSession, to run a single transformation
+-- over a single expression and track if the expression was changed.
+type TransformMonad = Writer.WriterT Monoid.Any TransformSession
+
-- | Transforms a CoreExpr and keeps track if it has changed.
type Transform = CoreExpr -> TransformMonad CoreExpr
+
+-- Finds the value of a global binding, if available
+getGlobalBind :: CoreBndr -> TransformSession (Maybe CoreExpr)
+getGlobalBind bndr = do
+ bindings <- getA tsBindings
+ return $ Map.lookup bndr bindings
+
+-- Adds a new global binding with the given value
+addGlobalBind :: CoreBndr -> CoreExpr -> TransformSession ()
+addGlobalBind bndr expr = modA tsBindings (Map.insert bndr expr)
moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
moduleToVHDL core list = do
let (names, statefuls) = unzip list
- let binds = findBinds core names
+ let binds = map fst $ findBinds core names
-- Generate a UniqSupply
-- Running
-- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
-- unique supply anywhere.
uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
-- Turn bind into VHDL
- let (vhdl, sess) = State.runState (mkVHDL uniqSupply binds statefuls) (TranslatorSession core 0 Map.empty)
+ let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
+ let normalized_bindings = normalizeModule uniqSupply all_bindings binds statefuls
+ let vhdl = VHDL.createDesignFiles normalized_bindings
mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl
- putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
+ --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
return vhdl
where
- -- Turns the given bind into VHDL
- mkVHDL :: UniqSupply.UniqSupply -> [(CoreBndr, CoreExpr)] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
- mkVHDL uniqSupply binds statefuls = do
- let binds'' = map (Arrow.second $ normalize uniqSupply) binds
- let binds' = trace ("Before:\n\n" ++ showSDoc ( ppr binds ) ++ "\n\nAfter:\n\n" ++ showSDoc ( ppr binds'')) binds''
- -- Add the builtin functions
- --mapM addBuiltIn builtin_funcs
- -- Create entities and architectures for them
- --Monad.zipWithM processBind statefuls binds
- --modA tsFlatFuncs (Map.map nameFlatFunction)
- --flatfuncs <- getA tsFlatFuncs
- return $ VHDL.createDesignFiles binds'
-- | Write the given design file to a file with the given name inside the
-- given dir
-- Var.
find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
--- | Processes the given bind as a top level bind.
-processBind ::
- Bool -- ^ Should this be stateful function?
- -> (CoreBndr, CoreExpr) -- ^ The bind to process
- -> TranslatorState ()
-
-processBind stateful bind@(var, expr) = do
- -- Create the function signature
- let ty = CoreUtils.exprType expr
- let hsfunc = mkHsFunction var ty stateful
- flattenBind hsfunc bind
-
-- | Flattens the given bind into the given signature and adds it to the
-- session. Then (recursively) finds any functions it uses and does the same
-- with them.
projects / matthijs / master-project / cλash.git / commitdiff