From: Christiaan Baaij Date: Thu, 13 Aug 2009 15:20:33 +0000 (+0200) Subject: Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=4e12174b5b6515c056d4f83edcc18b991c71465d;hp=aa2503aeb4cfa5540633db2cdd50bea20b5f1c50;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Merge branch 'cλash' of git.stderr.nl/matthijs/projects/master-project * 'cλash' of http://git.stderr.nl/matthijs/projects/master-project: Don't generate a state proc for an empty state. Make splitNormalized work for non-recursive lets. Add and use splitNormalized helper function. --- diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index ec3ed56..1d40f92 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -4,7 +4,7 @@ -- top level function "normalize", and defines the actual transformation passes that -- are performed. -- -module CLasH.Normalize (getNormalized, normalizeExpr) where +module CLasH.Normalize (getNormalized, normalizeExpr, splitNormalized) where -- Standard modules import Debug.Trace @@ -589,3 +589,31 @@ getBinding bndr = Utils.makeCached bndr tsBindings $ do -- 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 + +-- | Split a normalized expression into the argument binders, top level +-- bindings and the result binder. +splitNormalized :: + CoreExpr -- ^ The normalized expression + -> ([CoreBndr], [Binding], CoreBndr) +splitNormalized expr = (args, binds, res) + where + (args, letexpr) = CoreSyn.collectBinders expr + (binds, resexpr) = flattenLets letexpr + res = case resexpr of + (Var x) -> x + _ -> error $ "Normalize.splitNormalized: Not in normal form: " ++ pprString expr ++ "\n" + +-- | Flattens nested lets into a single list of bindings. The expression +-- passed does not have to be a let expression, if it isn't an empty list of +-- bindings is returned. +flattenLets :: + CoreExpr -- ^ The expression to flatten. + -> ([Binding], CoreExpr) -- ^ The bindings and resulting expression. +flattenLets (Let binds expr) = + (bindings ++ bindings', expr') + where + -- Recursively flatten the contained expression + (bindings', expr') =flattenLets expr + -- Flatten our own bindings to remove the Rec / NonRec constructors + bindings = CoreSyn.flattenBinds [binds] +flattenLets expr = ([], expr) diff --git "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" index 48ca948..d8f4289 100644 --- "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" +++ "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" @@ -43,6 +43,9 @@ import CLasH.Utils.GhcTools import CLasH.Utils.HsTools import CLasH.Utils.Pretty +-- | A single binding, used as a shortcut to simplify type signatures. +type Binding = (CoreSyn.CoreBndr, CoreSyn.CoreExpr) + -- | Evaluate a core Type representing type level int from the tfp -- library to a real int. eval_tfp_int :: HscTypes.HscEnv -> Type.Type -> Int diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index 99d5d27..0be4f60 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -44,12 +44,10 @@ getEntity :: getEntity fname = Utils.makeCached fname tsEntities $ do expr <- Normalize.getNormalized fname - -- Strip off lambda's, these will be arguments - let (args, letexpr) = CoreSyn.collectBinders expr + -- Split the normalized expression + let (args, binds, res) = Normalize.splitNormalized expr -- Generate ports for all non-empty types args' <- catMaybesM $ mapM mkMap args - -- There must be a let at top level - let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr -- TODO: Handle Nothing res' <- mkMap res count <- getA tsEntityCounter @@ -113,12 +111,12 @@ getArchitecture :: getArchitecture fname = Utils.makeCached fname tsArchitectures $ do expr <- Normalize.getNormalized fname + -- Split the normalized expression + let (args, binds, res) = Normalize.splitNormalized expr + + -- Get the entity for this function signature <- getEntity fname let entity_id = ent_id signature - -- Strip off lambda's, these will be arguments - let (args, letexpr) = CoreSyn.collectBinders expr - -- There must be a let at top level - let (CoreSyn.Let (CoreSyn.Rec binds) (CoreSyn.Var res)) = letexpr -- Create signal declarations for all binders in the let expression, except -- for the output port (that will already have an output port declared in @@ -131,9 +129,9 @@ getArchitecture fname = Utils.makeCached fname tsArchitectures $ do let (in_state_maybes, out_state_maybes) = unzip state_vars let (statementss, used_entitiess) = unzip sms -- Create a state proc, if needed - let state_proc = case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes) of - ([in_state], [out_state]) -> [AST.CSPSm $ mkStateProcSm (in_state, out_state)] - ([], []) -> [] + state_proc <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes) of + ([in_state], [out_state]) -> mkStateProcSm (in_state, out_state) + ([], []) -> return [] (ins, outs) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs -- Join the create statements and the (optional) state_proc let statements = concat statementss ++ state_proc @@ -164,9 +162,12 @@ getArchitecture fname = Utils.makeCached fname tsArchitectures $ do mkStateProcSm :: (CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current and new state variables - -> AST.ProcSm -- ^ The resulting statement -mkStateProcSm (old, new) = - AST.ProcSm label [clk] [statement] + -> TranslatorSession [AST.ConcSm] -- ^ The resulting statements +mkStateProcSm (old, new) = do + nonempty <- hasNonEmptyType old + if nonempty + then return [AST.CSPSm $ AST.ProcSm label [clk] [statement]] + else return [] where label = mkVHDLBasicId $ "state" clk = mkVHDLBasicId "clock" diff --git "a/c\316\273ash/CLasH/VHDL/Testbench.hs" "b/c\316\273ash/CLasH/VHDL/Testbench.hs" index 98c5b46..84f550a 100644 --- "a/c\316\273ash/CLasH/VHDL/Testbench.hs" +++ "b/c\316\273ash/CLasH/VHDL/Testbench.hs" @@ -129,7 +129,10 @@ createStimulans :: createStimulans expr cycl = do -- There must be a let at top level - (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) <- normalizeExpr ("test input #" ++ show cycl) expr + expr <- normalizeExpr ("test input #" ++ show cycl) expr + -- Split the normalized expression. It can't have a function type, so match + -- an empty list of argument binders + let ([], binds, res) = splitNormalized expr (stimulansbindss, useds) <- unzipM $ Monad.mapM mkConcSm binds sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds) let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)