import qualified UniqSupply
import qualified CoreUtils
import qualified Type
+import qualified TcType
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 NormalizeTypes
import NormalizeTools
+import VHDLTypes
import CoreTools
import Pretty
--------------------------------
-- Remove a = b bindings from let expressions everywhere
letremovetop :: Transform
-letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) | not $ Id.isDataConWorkId v -> True; otherwise -> False))
+letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) | not $ Id.isDataConWorkId v -> return True; otherwise -> return False))
--------------------------------
-- Function inlining
-- will just not work on those function-typed values at first, but the other
-- transformations (in particular β-reduction) should make sure that the type
-- of those values eventually becomes primitive.
-inlinefuntop :: Transform
-inlinefuntop = everywhere ("inlinefun", inlinebind (is_applicable . snd))
+inlinenonreptop :: Transform
+inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd))
--------------------------------
-- Scrutinee simplification
-- What transforms to run?
-transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop]
+transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinenonreptop, appsimpltop]
-- Turns the given bind into VHDL
-normalizeModule ::
- UniqSupply.UniqSupply -- ^ A UniqSupply we can use
+normalizeModule ::
+ HscTypes.HscEnv
+ -> 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
+ -> ([(CoreBndr, CoreExpr)], TypeState) -- ^ The resulting VHDL
-normalizeModule uniqsupply bindings generate_for statefuls = runTransformSession uniqsupply $ do
+normalizeModule env uniqsupply bindings generate_for statefuls = runTransformSession env 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
bindings_map <- getA tsBindings
let bindings = Map.assocs bindings_map
normalized_bindings <- getA tsNormalized
+ typestate <- getA tsType
-- But return only the normalized bindings
- return $ filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings
+ return $ (filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings, typestate)
normalizeBind :: CoreBndr -> TransformSession ()
normalizeBind bndr =
-- 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 -> (Type.isFunTy . snd . Type.splitForAllTys . Id.idType) v) expr'
+ bndrs <- getGlobalBinders
+ let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> not (Id.isDictId v) && v `elem` bndrs) expr'
let used_funcs = VarSet.varSetElems used_funcs_set
-- Process each of the used functions recursively
mapM normalizeBind used_funcs
+ -- FIXME: Can't we inline these 'implicit' function calls or something?
+ -- TODO: Add an extra let expression to the current finding, so the VHDL
+ -- Will make a signa assignment for this 'implicit' function call
+ --
+ -- Find all the other free variables used that are used. This applies to
+ -- variables that are actually a reference to a Class function. Example:
+ --
+ -- functiontest :: SizedInt D8 -> SizedInt D8
+ -- functiontest = \a -> let r = a + 1 in r
+ --
+ -- The literal(Lit) '1' will be turned into a variable (Var)
+ -- As it will call the 'fromInteger' class function that belongs
+ -- to the Num class. So we need to translate the refenced function
+ -- let used_vars_set = CoreFVs.exprSomeFreeVars (\v -> (Type.isAlgType . snd . Type.splitForAllTys . Id.idType) v) expr'
+ -- let used_vars = VarSet.varSetElems used_vars_set
+ -- -- Filter for dictionary args, they should not be translated
+ -- -- FIXME: check for other non-translatable stuff as well
+ -- let trans_vars = filter (\v -> (not . TcType.isDictTy . Id.idType) v) used_vars
+ -- mapM normalizeBind trans_vars
return ()
-- We don't have a value for this binder. This really shouldn't
-- happen for local id's...
projects / matthijs / master-project / cλash.git / blobdiff