import qualified "transformers" Control.Monad.Trans as Trans
import qualified Control.Monad as Monad
import qualified Control.Monad.Trans.Writer as Writer
-import qualified Data.Map as Map
import qualified Data.Monoid as Monoid
-import Data.Accessor
-- GHC API
import CoreSyn
-import qualified UniqSupply
import qualified CoreUtils
import qualified Type
-import qualified TcType
-import qualified Name
import qualified Id
import qualified Var
import qualified VarSet
-import qualified NameSet
import qualified CoreFVs
-import qualified CoreUtils
import qualified MkCore
-import qualified HscTypes
import Outputable ( showSDoc, ppr, nest )
-- Local imports
import CLasH.Normalize.NormalizeTypes
import CLasH.Translator.TranslatorTypes
import CLasH.Normalize.NormalizeTools
-import CLasH.VHDL.VHDLTypes
import qualified CLasH.Utils as Utils
import CLasH.Utils.Core.CoreTools
import CLasH.Utils.Core.BinderTools
--------------------------------
-- Remove empty (recursive) lets
letremove, letremovetop :: Transform
-letremove (Let (Rec []) res) = change $ res
+letremove (Let (Rec []) res) = change res
-- Leave all other expressions unchanged
letremove expr = return expr
-- Perform this transform everywhere
-- Perform this transform everywhere
scrutsimpltop = everywhere ("scrutsimpl", scrutsimpl)
+ --------------------------------
+ -- Scrutinee binder removal
+ --------------------------------
+ -- A case expression can have an extra binder, to which the scrutinee is bound
+ -- after bringing it to WHNF. This is used for forcing evaluation of strict
+ -- arguments. Since strictness does not matter for us (rather, everything is
+ -- sort of strict), this binder is ignored when generating VHDL, and must thus
+ -- be wild in the normal form.
+ scrutbndrremove, scrutbndrremovetop :: Transform
+ -- If the scrutinee is already simple, and the bndr is not wild yet, replace
+ -- all occurences of the binder with the scrutinee variable.
+ scrutbndrremove (Case (Var scrut) bndr ty alts) | bndr_used = do
+ alts' <- mapM subs_bndr alts
+ return $ Case (Var scrut) wild ty alts'
+ where
+ is_used (_, _, expr) = expr_uses_binders [bndr] expr
+ bndr_used = or $ map is_used alts
+ subs_bndr (con, bndrs, expr) = do
+ expr' <- substitute bndr (Var scrut) expr
+ return (con, bndrs, expr')
+ wild = MkCore.mkWildBinder (Id.idType bndr)
+ -- Leave all other expressions unchanged
+ scrutbndrremove expr = return expr
+ scrutbndrremovetop = everywhere ("scrutbndrremove", scrutbndrremove)
+
--------------------------------
-- Case binder wildening
--------------------------------
-- Extract a complex expression, if possible. For this we check if any of
-- the new list of bndrs are used by expr. We can't use free_vars here,
-- since that looks at the old bndrs.
- let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) $ expr
+ let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) expr
(exprbinding_maybe, expr') <- doexpr expr uses_bndrs
-- Create a new alternative
let newalt = (con, newbndrs, expr')
id <- Trans.lift $ mkBinderFor expr "caseval"
-- We don't flag a change here, since casevalsimpl will do that above
-- based on Just we return here.
- return $ (Just (id, expr), Var id)
+ return (Just (id, expr), Var id)
else
-- Don't simplify anything else
return (Nothing, expr)
doarg arg = do
repr <- isRepr arg
bndrs <- Trans.lift getGlobalBinders
- let interesting var = Var.isLocalVar var && (not $ var `elem` bndrs)
+ let interesting var = Var.isLocalVar var && (var `notElem` bndrs)
if not repr && not (is_var arg && interesting (exprToVar arg)) && not (has_free_tyvars arg)
then do
-- Propagate all complex arguments that are not representable, but not
-- What transforms to run?
- transforms = [inlinetopleveltop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop, lambdasimpltop, simplrestop]
+ transforms = [inlinetopleveltop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, scrutbndrremovetop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop, lambdasimpltop, simplrestop]
-- | Returns the normalized version of the given function.
getNormalized ::
CoreBndr -- ^ The function to get
-> TranslatorSession CoreExpr -- The normalized function body
-getNormalized bndr = Utils.makeCached bndr tsNormalized $ do
+getNormalized bndr = Utils.makeCached bndr tsNormalized $
if is_poly (Var bndr)
then
-- This should really only happen at the top level... TODO: Give
CoreBndr -- ^ The binder to get the expression for
-> TranslatorSession CoreExpr -- ^ The value bound to the binder
-getBinding bndr = Utils.makeCached bndr tsBindings $ do
+getBinding bndr = Utils.makeCached bndr tsBindings $
-- If the binding isn't in the "cache" (bindings map), then we can't create
-- it out of thin air, so return an error.
error $ "Normalize.getBinding: Unknown function requested: " ++ show bndr
projects / matthijs / master-project / cλash.git / commitdiff