From 254a259d6cfa363ac4da8c69b665ce4ce2a29ee7 Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Wed, 3 Mar 2010 13:30:44 +0100
Subject: [PATCH 01/16] Use fromMaybe with an error message instead of
 fromJust.

---
 "c\316\273ash/CLasH/VHDL/Generate.hs" | 8 ++++++--
 1 file changed, 6 insertions(+), 2 deletions(-)

diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs"
index 1d8194d..afd1741 100644
--- "a/c\316\273ash/CLasH/VHDL/Generate.hs"
+++ "b/c\316\273ash/CLasH/VHDL/Generate.hs"
@@ -172,9 +172,13 @@ mkStateProcSm ::
 mkStateProcSm (old, new, res) = do
   let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString res 
   type_mark_old_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType old)
-  let type_mark_old = Maybe.fromJust type_mark_old_maybe
+  let type_mark_old = Maybe.fromMaybe 
+                        (error $ "\nGenerate.mkStateProcSm: empty type for state? Type: " ++ pprString (Var.varType old))
+                        type_mark_old_maybe
   type_mark_res_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType res)
-  let type_mark_res' = Maybe.fromJust type_mark_res_maybe
+  let type_mark_res' = Maybe.fromMaybe 
+                        (error $ "\nGenerate.mkStateProcSm: empty type for initial state? Type: " ++ pprString (Var.varType res))
+                        type_mark_res_maybe
   let type_mark_res = if type_mark_old == type_mark_res' then
                         type_mark_res'
                       else 
-- 
2.30.2


From 7c8bb43c572704c4afb86bdaf917c1a695009378 Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Wed, 3 Mar 2010 14:05:19 +0100
Subject: [PATCH 02/16] Allow inlining of head and friends.

---
 "c\316\273ash/CLasH/Normalize/NormalizeTools.hs" | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs"
index c67b9e1..187c6f9 100644
--- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs"
+++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs"
@@ -199,7 +199,7 @@ isUserDefined bndr = str `notElem` compiler_names
     -- These are names of bindings usually generated by the compiler. For some
     -- reason these are not marked as system, probably because the name itself
     -- is not made up by the compiler, just this particular binding is.
-    compiler_names = ["fromInteger", "+", "*", "-", "!"]
+    compiler_names = ["fromInteger", "head", "tail", "init", "last", "+", "*", "-", "!"]
 
 -- Is the given binder normalizable? This means that its type signature can be
 -- represented in hardware, which should (?) guarantee that it can be made
-- 
2.30.2


From c39649cd42d2ef3bc2105b19356aa97b4913a540 Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Wed, 3 Mar 2010 14:05:33 +0100
Subject: [PATCH 03/16] Support stateful functions with no own state (only
 substate).

---
 "c\316\273ash/CLasH/VHDL/Generate.hs" | 10 ++++++++--
 1 file changed, 8 insertions(+), 2 deletions(-)

diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs"
index afd1741..a9947a2 100644
--- "a/c\316\273ash/CLasH/VHDL/Generate.hs"
+++ "b/c\316\273ash/CLasH/VHDL/Generate.hs"
@@ -134,8 +134,14 @@ getArchitecture fname = makeCached fname tsArchitectures $ do
   (state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of
         ([in_state], [out_state], Nothing) -> do 
           nonEmpty <- hasNonEmptyType in_state
-          if nonEmpty then error ("No initial state defined for: " ++ show fname) else return ([],[])
-        ([in_state], [out_state], Just resetval) -> mkStateProcSm (in_state, out_state,resetval)
+          if nonEmpty 
+            then error ("No initial state defined for: " ++ show fname) 
+            else return ([],[])
+        ([in_state], [out_state], Just resetval) -> do
+          nonEmpty <- hasNonEmptyType in_state
+          if nonEmpty 
+            then mkStateProcSm (in_state, out_state, resetval)
+            else error ("Initial state defined for function with only substate: " ++ show fname)
         ([], [], Just _) -> error $ "Initial state defined for state-less function: " ++ show fname
         ([], [], Nothing) -> return ([],[])
         (ins, outs, res) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
-- 
2.30.2


From 729463aa72a83323564e39a608a68d02412af2c1 Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Fri, 5 Mar 2010 17:29:02 +0100
Subject: [PATCH 04/16] Remove getBinding and use getGlobalBind instead.

---
 "c\316\273ash/CLasH/Normalize.hs" | 13 +------------
 1 file changed, 1 insertion(+), 12 deletions(-)

diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs"
index 538b60d..5690589 100644
--- "a/c\316\273ash/CLasH/Normalize.hs"
+++ "b/c\316\273ash/CLasH/Normalize.hs"
@@ -738,7 +738,7 @@ getNormalized bndr = Utils.makeCached bndr tsNormalized $
       -- a different error if this happens down in the recursion.
       error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize"
     else do
-      expr <- getBinding bndr
+      Just expr <- getGlobalBind bndr
       normalizeExpr (show bndr) expr
 
 -- | Normalize an expression
@@ -755,17 +755,6 @@ normalizeExpr what expr = do
       trace ("\n" ++ what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr')) $ return ()
       return expr'
 
--- | Get the value that is bound to the given binder at top level. Fails when
---   there is no such binding.
-getBinding ::
-  CoreBndr -- ^ The binder to get the expression for
-  -> TranslatorSession CoreExpr -- ^ The value bound to the binder
-
-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
-
 -- | Split a normalized expression into the argument binders, top level
 --   bindings and the result binder.
 splitNormalized ::
-- 
2.30.2


From d59ed8de0b03c0eeba23f5a5e08f3c24b87dc3ab Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Fri, 5 Mar 2010 17:54:45 +0100
Subject: [PATCH 05/16] Add getNormalized_maybe that does not fail if a binder
 was not found.

---
 "c\316\273ash/CLasH/Normalize.hs" | 42 +++++++++++++++++++++++--------
 1 file changed, 31 insertions(+), 11 deletions(-)

diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs"
index 5690589..fa14ef6 100644
--- "a/c\316\273ash/CLasH/Normalize.hs"
+++ "b/c\316\273ash/CLasH/Normalize.hs"
@@ -726,20 +726,40 @@ simplrestop expr = do
 -- What transforms to run?
 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.
+-- | Returns the normalized version of the given function, or an error
+-- if it is not a known global binder.
 getNormalized ::
   CoreBndr -- ^ The function to get
   -> TranslatorSession CoreExpr -- The normalized function body
-
-getNormalized bndr = Utils.makeCached bndr tsNormalized $
-  if is_poly (Var bndr)
-    then
-      -- This should really only happen at the top level... TODO: Give
-      -- a different error if this happens down in the recursion.
-      error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize"
-    else do
-      Just expr <- getGlobalBind bndr
-      normalizeExpr (show bndr) expr
+getNormalized bndr = do
+  norm <- getNormalized_maybe bndr
+  return $ Maybe.fromMaybe
+    (error $ "Normalize.getNormalized: Unknown function requested: " ++ show bndr)
+    norm
+
+-- | Returns the normalized version of the given function, or Nothing
+-- when the binder is not a known global binder.
+getNormalized_maybe ::
+  CoreBndr -- ^ The function to get
+  -> TranslatorSession (Maybe CoreExpr) -- The normalized function body
+
+getNormalized_maybe bndr = do
+    expr_maybe <- getGlobalBind bndr
+    if Maybe.isNothing expr_maybe
+      then
+        -- Binder not found
+        return Nothing
+      else if is_poly (Var bndr)
+        then
+          -- This should really only happen at the top level... TODO: Give
+          -- a different error if this happens down in the recursion.
+          error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize"
+        else do
+          -- Binder found and is monomorphic. Normalize the expression
+          -- and cache the result.
+          normalized <- Utils.makeCached bndr tsNormalized $ 
+            normalizeExpr (show bndr) (Maybe.fromJust expr_maybe)
+          return (Just normalized)
 
 -- | Normalize an expression
 normalizeExpr ::
-- 
2.30.2


From 339dab663321157d33d724846a7cec084b0da81e Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Fri, 5 Mar 2010 18:12:51 +0100
Subject: [PATCH 06/16] Add variant of isRepr that operates in the
 TranslatorSession.

---
 "c\316\273ash/CLasH/Normalize/NormalizeTools.hs" | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs"
index 187c6f9..3da2728 100644
--- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs"
+++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs"
@@ -178,9 +178,12 @@ substitute_clone find repl expr = subeverywhere (substitute_clone find repl) exp
 
 -- Is the given expression representable at runtime, based on the type?
 isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
-isRepr tything = case CoreTools.getType tything of
+isRepr tything = Trans.lift (isRepr' tything)
+
+isRepr' :: (CoreTools.TypedThing t) => t -> TranslatorSession Bool
+isRepr' tything = case CoreTools.getType tything of
   Nothing -> return False
-  Just ty -> Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType ty 
+  Just ty -> MonadState.lift tsType $ VHDLTools.isReprType ty 
 
 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
 is_local_var (CoreSyn.Var v) = do
-- 
2.30.2


From 7eed9f7f33ef0a7b8ac307af9249a379692dd21d Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Fri, 5 Mar 2010 18:14:45 +0100
Subject: [PATCH 07/16] Add variant of isNormalizeable that operates in the
 TranslatorSession.

---
 "c\316\273ash/CLasH/Normalize/NormalizeTools.hs" | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs"
index 3da2728..7a187f8 100644
--- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs"
+++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs"
@@ -209,9 +209,12 @@ isUserDefined bndr = str `notElem` compiler_names
 -- into hardware. Note that if a binder is not normalizable, it might become
 -- so using argument propagation.
 isNormalizeable :: CoreBndr -> TransformMonad Bool 
-isNormalizeable bndr = do
+isNormalizeable bndr = Trans.lift (isNormalizeable' bndr)
+
+isNormalizeable' :: CoreBndr -> TranslatorSession Bool 
+isNormalizeable' bndr = do
   let ty = Id.idType bndr
   let (arg_tys, res_ty) = Type.splitFunTys ty
   -- This function is normalizable if all its arguments and return value are
   -- representable.
-  andM $ mapM isRepr (res_ty:arg_tys)
+  andM $ mapM isRepr' (res_ty:arg_tys)
-- 
2.30.2


From c499e901a25eb7df0bfac03d57ee3401ad6cb7e7 Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Fri, 5 Mar 2010 18:15:49 +0100
Subject: [PATCH 08/16] Let getNormalized return Nothing on non-normalizeable
 functions.

---
 "c\316\273ash/CLasH/Normalize.hs" | 9 +++++----
 1 file changed, 5 insertions(+), 4 deletions(-)

diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs"
index fa14ef6..82cc89b 100644
--- "a/c\316\273ash/CLasH/Normalize.hs"
+++ "b/c\316\273ash/CLasH/Normalize.hs"
@@ -734,20 +734,21 @@ getNormalized ::
 getNormalized bndr = do
   norm <- getNormalized_maybe bndr
   return $ Maybe.fromMaybe
-    (error $ "Normalize.getNormalized: Unknown function requested: " ++ show bndr)
+    (error $ "Normalize.getNormalized: Unknown or non-representable function requested: " ++ show bndr)
     norm
 
 -- | Returns the normalized version of the given function, or Nothing
--- when the binder is not a known global binder.
+-- when the binder is not a known global binder or is not normalizeable.
 getNormalized_maybe ::
   CoreBndr -- ^ The function to get
   -> TranslatorSession (Maybe CoreExpr) -- The normalized function body
 
 getNormalized_maybe bndr = do
     expr_maybe <- getGlobalBind bndr
-    if Maybe.isNothing expr_maybe
+    normalizeable <- isNormalizeable' bndr
+    if not normalizeable || Maybe.isNothing expr_maybe
       then
-        -- Binder not found
+        -- Binder not normalizeable or not found
         return Nothing
       else if is_poly (Var bndr)
         then
-- 
2.30.2


From bb9442c6efb3b7dc6b16d56234e4b064c45bfb75 Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Fri, 5 Mar 2010 18:20:51 +0100
Subject: [PATCH 09/16] Let inlinetoplevel use getNormalized_maybe.

This makes the transformation slightly simpler and prepares it for
inlining dictionaries next.
---
 "c\316\273ash/CLasH/Normalize.hs" | 28 ++++++++++++----------------
 1 file changed, 12 insertions(+), 16 deletions(-)

diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs"
index 82cc89b..91033b5 100644
--- "a/c\316\273ash/CLasH/Normalize.hs"
+++ "b/c\316\273ash/CLasH/Normalize.hs"
@@ -338,23 +338,19 @@ inlinetoplevel, inlinetopleveltop :: Transform
 -- Any system name is candidate for inlining. Never inline user-defined
 -- functions, to preserve structure.
 inlinetoplevel expr@(Var f) | not $ isUserDefined f = do
-  norm <- isNormalizeable f
-  -- See if this is a top level binding for which we have a body
-  body_maybe <- Trans.lift $ getGlobalBind f
-  if norm && Maybe.isJust body_maybe
-    then do
-      -- Get the normalized version
-      norm <- Trans.lift $ getNormalized f
-      if needsInline norm 
-        then do
-          -- Regenerate all uniques in the to-be-inlined expression
-          norm_uniqued <- Trans.lift $ genUniques norm
-          change norm_uniqued
-        else
-          return expr
-    else
+  norm_maybe <- Trans.lift $ getNormalized_maybe f
+  case norm_maybe of
       -- No body or not normalizeable.
-      return expr
+    Nothing -> return expr
+    Just norm -> if needsInline norm then do
+        -- Regenerate all uniques in the to-be-inlined expression
+        norm_uniqued <- Trans.lift $ genUniques norm
+        -- And replace the variable reference with the unique'd body.
+        change norm_uniqued
+      else
+        -- No need to inline
+        return expr
+
 -- Leave all other expressions unchanged
 inlinetoplevel expr = return expr
 inlinetopleveltop = everywhere ("inlinetoplevel", inlinetoplevel)
-- 
2.30.2


From d20ac1165e401bed9991affa47eae14e1a815b25 Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Mon, 8 Mar 2010 10:49:51 +0100
Subject: [PATCH 10/16] Add dictionary inlining transformation.

---
 "c\316\273ash/CLasH/Normalize.hs" | 18 +++++++++++++++++-
 1 file changed, 17 insertions(+), 1 deletion(-)

diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs"
index 91033b5..4c04e85 100644
--- "a/c\316\273ash/CLasH/Normalize.hs"
+++ "b/c\316\273ash/CLasH/Normalize.hs"
@@ -364,6 +364,22 @@ needsInline expr = case splitNormalized expr of
   (args, [bind], res) -> True
   _ -> False
 
+
+--------------------------------
+-- Dictionary inlining
+--------------------------------
+-- Inline all top level dictionaries, so we can use them to resolve
+-- class methods based on the dictionary passed. 
+inlinedict expr@(Var f) | Id.isDictId f = do
+  body_maybe <- Trans.lift $ getGlobalBind f
+  case body_maybe of
+    Nothing -> return expr
+    Just body -> change body
+
+-- Leave all other expressions unchanged
+inlinedict expr = return expr
+inlinedicttop = everywhere ("inlinedict", inlinedict)
+
 --------------------------------
 -- Scrutinee simplification
 --------------------------------
@@ -720,7 +736,7 @@ simplrestop expr = do
 
 
 -- What transforms to run?
-transforms = [inlinetopleveltop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, scrutbndrremovetop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop, lambdasimpltop, simplrestop]
+transforms = [inlinedicttop, 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, or an error
 -- if it is not a known global binder.
-- 
2.30.2


From d00bdb4899f108cbb766260aace1a019919a5283 Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Mon, 8 Mar 2010 11:35:52 +0100
Subject: [PATCH 11/16] Add class operation resolution transformation.

This transformation enables user-defined type classes.
---
 "c\316\273ash/CLasH/Normalize.hs" | 57 ++++++++++++++++++++++++++++++-
 1 file changed, 56 insertions(+), 1 deletion(-)

diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs"
index 4c04e85..86ade5b 100644
--- "a/c\316\273ash/CLasH/Normalize.hs"
+++ "b/c\316\273ash/CLasH/Normalize.hs"
@@ -25,6 +25,7 @@ import qualified Id
 import qualified Var
 import qualified VarSet
 import qualified CoreFVs
+import qualified Class
 import qualified MkCore
 import Outputable ( showSDoc, ppr, nest )
 
@@ -380,6 +381,60 @@ inlinedict expr@(Var f) | Id.isDictId f = do
 inlinedict expr = return expr
 inlinedicttop = everywhere ("inlinedict", inlinedict)
 
+--------------------------------
+-- ClassOp resolution
+--------------------------------
+-- Resolves any class operation to the actual operation whenever
+-- possible. Class methods (as well as parent dictionary selectors) are
+-- special "functions" that take a type and a dictionary and evaluate to
+-- the corresponding method. A dictionary is nothing more than a
+-- special dataconstructor applied to the type the dictionary is for,
+-- each of the superclasses and all of the class method definitions for
+-- that particular type. Since dictionaries all always inlined (top
+-- levels dictionaries are inlined by inlinedict, local dictionaries are
+-- inlined by inlinenonrep), we will eventually have something like:
+--
+--   baz
+--     @ CLasH.HardwareTypes.Bit
+--     (D:Baz @ CLasH.HardwareTypes.Bit bitbaz)
+--
+-- Here, baz is the method selector for the baz method, while
+-- D:Baz is the dictionary constructor for the Baz and bitbaz is the baz
+-- method defined in the Baz Bit instance declaration.
+--
+-- To resolve this, we can look at the ClassOp IdInfo from the baz Id,
+-- which contains the Class it is defined for. From the Class, we can
+-- get a list of all selectors (both parent class selectors as well as
+-- method selectors). Since the arguments to D:Baz (after the type
+-- argument) correspond exactly to this list, we then look up baz in
+-- that list and replace the entire expression by the corresponding 
+-- argument to D:Baz.
+classopresolution, classopresolutiontop :: Transform
+classopresolution expr@(App (App (Var sel) ty) dict) =
+  case Id.isClassOpId_maybe sel of
+    -- Not a class op selector
+    Nothing -> return expr
+    Just cls -> case collectArgs dict of
+      (_, []) -> return expr -- Dict is not an application (e.g., not inlined yet)
+      (dictdc, (ty':selectors)) | tyargs_neq ty ty' -> error $ "Applying class selector to dictionary without matching type?\n" ++ pprString expr
+                                | otherwise ->
+        let selector_ids = Class.classSelIds cls in
+        -- Find the selector used in the class' list of selectors
+        case List.elemIndex sel selector_ids of
+          Nothing -> error $ "Selector not found in class' selector list? This should not happen!\nExpression: " ++ pprString expr ++ "\nClass: " ++ show cls ++ "\nSelectors: " ++ show selector_ids
+          -- Get the corresponding argument from the dictionary
+          Just n -> change (selectors!!n)
+  where
+    -- Compare two type arguments, returning True if they are _not_
+    -- equal
+    tyargs_neq (Type ty1) (Type ty2) = not $ Type.coreEqType ty1 ty2
+    tyargs_neq _ _ = True
+
+-- Leave all other expressions unchanged
+classopresolution expr = return expr
+-- Perform this transform everywhere
+classopresolutiontop = everywhere ("classopresolution", classopresolution)
+
 --------------------------------
 -- Scrutinee simplification
 --------------------------------
@@ -736,7 +791,7 @@ simplrestop expr = do
 
 
 -- What transforms to run?
-transforms = [inlinedicttop, inlinetopleveltop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, scrutbndrremovetop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop, lambdasimpltop, simplrestop]
+transforms = [inlinedicttop, inlinetopleveltop, classopresolutiontop, 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, or an error
 -- if it is not a known global binder.
-- 
2.30.2


From 829e3b461156a39d30f6796b26a8c83a119bed43 Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Mon, 8 Mar 2010 11:54:26 +0100
Subject: [PATCH 12/16] Show uniques in listBindings output.

---
 "c\316\273ash/CLasH/Utils/GhcTools.hs" | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git "a/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs"
index fc63ac4..d898795 100644
--- "a/c\316\273ash/CLasH/Utils/GhcTools.hs"
+++ "b/c\316\273ash/CLasH/Utils/GhcTools.hs"
@@ -35,7 +35,7 @@ listBindings libdir filenames = do
 listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
 listBinding (b, e) = do
   putStr "\nBinder: "
-  putStr $ show b
+  putStr $ show b ++ "[" ++ show (Var.varUnique b) ++ "]"
   putStr "\nType of Binder: \n"
   putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b
   putStr "\n\nExpression: \n"
-- 
2.30.2


From eade653c03372e3cc27e502e053b6de7d924eb64 Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Mon, 8 Mar 2010 11:54:45 +0100
Subject: [PATCH 13/16] Show classes in listBindings output.

---
 "c\316\273ash/CLasH/Utils/GhcTools.hs" | 12 ++++++++++++
 1 file changed, 12 insertions(+)

diff --git "a/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs"
index d898795..c407436 100644
--- "a/c\316\273ash/CLasH/Utils/GhcTools.hs"
+++ "b/c\316\273ash/CLasH/Utils/GhcTools.hs"
@@ -19,6 +19,7 @@ import qualified Name
 import qualified Serialized
 import qualified Var
 import qualified Outputable
+import qualified Class
 
 -- Local Imports
 import CLasH.Utils.Pretty
@@ -31,6 +32,9 @@ listBindings libdir filenames = do
   (cores,_,_) <- loadModules libdir filenames Nothing
   let binds = concatMap (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
   mapM listBinding binds
+  putStr "\n=========================\n"
+  let classes = concatMap (HscTypes.typeEnvClasses . HscTypes.cm_types) cores
+  mapM listClass classes
 
 listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
 listBinding (b, e) = do
@@ -45,6 +49,14 @@ listBinding (b, e) = do
   putStr "\n\nType of Expression: \n"
   putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e
   putStr "\n\n"
+
+listClass :: Class.Class -> IO ()
+listClass c = do
+  putStr "\nClass: "
+  putStr $ show (Class.className c)
+  putStr "\nSelectors: "
+  putStr $ show (Class.classSelIds c)
+  putStr "\n"
   
 -- | Show the core structure of the given binds in the given file.
 listBind :: FilePath -> [FilePath] -> String -> IO ()
-- 
2.30.2


From dd0b3f0f95a335492533202a5801d7df9edd2762 Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Mon, 8 Mar 2010 12:07:27 +0100
Subject: [PATCH 14/16] Make listBindings return IO () instead of IO [()].

The previous type caused ghci to print an extra list of units after the
regular output, while it simple ignores the single tuple now.
---
 "c\316\273ash/CLasH/Utils/GhcTools.hs" | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git "a/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs"
index c407436..f1fe6ba 100644
--- "a/c\316\273ash/CLasH/Utils/GhcTools.hs"
+++ "b/c\316\273ash/CLasH/Utils/GhcTools.hs"
@@ -27,7 +27,7 @@ import CLasH.Translator.TranslatorTypes
 import CLasH.Translator.Annotations
 import CLasH.Utils
 
-listBindings :: FilePath -> [FilePath] -> IO [()]
+listBindings :: FilePath -> [FilePath] -> IO ()
 listBindings libdir filenames = do
   (cores,_,_) <- loadModules libdir filenames Nothing
   let binds = concatMap (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
@@ -35,6 +35,7 @@ listBindings libdir filenames = do
   putStr "\n=========================\n"
   let classes = concatMap (HscTypes.typeEnvClasses . HscTypes.cm_types) cores
   mapM listClass classes
+  return ()
 
 listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
 listBinding (b, e) = do
-- 
2.30.2


From db014de8ebda19a0828193c1230d0581bb923ce0 Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Wed, 10 Mar 2010 12:36:55 +0100
Subject: [PATCH 15/16] Let classoperationresolution handle partially inlined
 dictionaries.

Previously, if a dictionary argument was not yet an application of a
dataconstructor (e.g., completely inlined) but an application of a
polymorphic top level binder (e.g., $fsomething), then it would complain
about mismatching types.
---
 "c\316\273ash/CLasH/Normalize.hs" | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs"
index 86ade5b..2f056d7 100644
--- "a/c\316\273ash/CLasH/Normalize.hs"
+++ "b/c\316\273ash/CLasH/Normalize.hs"
@@ -416,7 +416,8 @@ classopresolution expr@(App (App (Var sel) ty) dict) =
     Nothing -> return expr
     Just cls -> case collectArgs dict of
       (_, []) -> return expr -- Dict is not an application (e.g., not inlined yet)
-      (dictdc, (ty':selectors)) | tyargs_neq ty ty' -> error $ "Applying class selector to dictionary without matching type?\n" ++ pprString expr
+      (Var dictdc, (ty':selectors)) | not (Maybe.isJust (Id.isDataConId_maybe dictdc)) -> return expr -- Dictionary is not a datacon yet (but e.g., a top level binder)
+                                | tyargs_neq ty ty' -> error $ "Applying class selector to dictionary without matching type?\n" ++ pprString expr
                                 | otherwise ->
         let selector_ids = Class.classSelIds cls in
         -- Find the selector used in the class' list of selectors
@@ -424,6 +425,7 @@ classopresolution expr@(App (App (Var sel) ty) dict) =
           Nothing -> error $ "Selector not found in class' selector list? This should not happen!\nExpression: " ++ pprString expr ++ "\nClass: " ++ show cls ++ "\nSelectors: " ++ show selector_ids
           -- Get the corresponding argument from the dictionary
           Just n -> change (selectors!!n)
+      (_, _) -> return expr -- Not applying a variable? Don't touch
   where
     -- Compare two type arguments, returning True if they are _not_
     -- equal
-- 
2.30.2


From 0dcd1ce078cbae64bc2b968b4c8233c9b94727dc Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Wed, 10 Mar 2010 13:32:07 +0100
Subject: [PATCH 16/16] Put a list of builtin functions in VHDL.Constants

This will allow normalization to use this list, without creating
circular dependencies by using VHDL.Generate.globalNameTable.
---
 "c\316\273ash/CLasH/VHDL/Constants.hs" | 16 +++++++++++++++-
 "c\316\273ash/CLasH/VHDL/Generate.hs"  |  3 ++-
 2 files changed, 17 insertions(+), 2 deletions(-)

diff --git "a/c\316\273ash/CLasH/VHDL/Constants.hs" "b/c\316\273ash/CLasH/VHDL/Constants.hs"
index 22bf14a..b9cbb0b 100644
--- "a/c\316\273ash/CLasH/VHDL/Constants.hs"
+++ "b/c\316\273ash/CLasH/VHDL/Constants.hs"
@@ -3,6 +3,20 @@ module CLasH.VHDL.Constants where
 -- VHDL Imports  
 import qualified Language.VHDL.AST as AST
 
+-- | A list of all builtin functions. Partly duplicates the name table
+-- in VHDL.Generate, but we can't use that map everywhere due to
+-- circular dependencie.
+builtinIds = [ exId, replaceId, headId, lastId, tailId, initId, takeId, dropId
+             , selId, plusgtId, ltplusId, plusplusId, mapId, zipWithId, foldlId
+             , foldrId, zipId, unzipId, shiftlId, shiftrId, rotlId, rotrId
+             , concatId, reverseId, iteratenId, iterateId, generatenId, generateId
+             , emptyId, singletonId, copynId, copyId, lengthTId, nullId
+             , hwxorId, hwandId, hworId, hwnotId, equalityId, inEqualityId, ltId
+             , lteqId, gtId, gteqId, boolOrId, boolAndId, plusId, timesId
+             , negateId, minusId, fromSizedWordId, fromIntegerId, resizeWordId
+             , resizeIntId, sizedIntId, smallIntegerId, fstId, sndId, blockRAMId
+             , splitId, minimumId 
+             ]
 --------------
 -- Identifiers
 --------------
@@ -376,4 +390,4 @@ stringTM = AST.unsafeVHDLBasicId "string"
 
 -- | tup VHDLName suffix
 tupVHDLSuffix :: AST.VHDLId -> AST.Suffix
-tupVHDLSuffix id = AST.SSimple id
\ No newline at end of file
+tupVHDLSuffix id = AST.SSimple id
diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs"
index a9947a2..61e95b4 100644
--- "a/c\316\273ash/CLasH/VHDL/Generate.hs"
+++ "b/c\316\273ash/CLasH/VHDL/Generate.hs"
@@ -1554,7 +1554,8 @@ type BuiltinBuilder =
 type NameTable = Map.Map String (Int, BuiltinBuilder )
 
 -- | The builtin functions we support. Maps a name to an argument count and a
--- builder function.
+-- builder function. If you add a name to this map, don't forget to add
+-- it to VHDL.Constants/builtinIds as well.
 globalNameTable :: NameTable
 globalNameTable = Map.fromList
   [ (exId             , (2, genFCall True          ) )
-- 
2.30.2