From: Matthijs Kooijman <m.kooijman@student.utwente.nl>
Date: Thu, 13 Aug 2009 14:12:31 +0000 (+0200)
Subject: Add and use splitNormalized helper function.
X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=10dfe589f40e65d51ca1585beecf00ae85169cae;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

Add and use splitNormalized helper function.

This function puts the matching of a normalized expression in a single
place instead of spread out over multiple places. This prevents some code
duplication and allows for better error reporting.
---

diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs"
index ec3ed56..7fb0dc2 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,15 @@ 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 = 
+  case letexpr of
+    (Let (Rec binds) (Var res)) -> (args, binds, res)
+    _ -> error $ "Normalize.splitNormalized: Not in normal form: " ++ pprString expr ++ "\n"
+  where
+    (args, letexpr) = CoreSyn.collectBinders 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 3f81f8f..f89b989 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
       let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
@@ -111,12 +109,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
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)