Fix casesimpl and caseremove wrt scrutinee binders.

[matthijs/master-project/cλash.git] / cλash / CLasH / Normalize.hs

diff --git a/cλash/CLasH/Normalize.hs b/cλash/CLasH/Normalize.hs
index 86ade5b21728f16d2422090328147ed642332ce8..bbdd23925b169542904c49ce4650e9a0964f1926 100644 (file)
--- a/cλash/CLasH/Normalize.hs
+++ b/cλash/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
@@ -497,17 +499,20 @@ casesimpl expr@(Case scrut b ty [(con, bndrs, Var x)]) = return expr
 -- is bound to a new simple selector case statement and for each complex
 -- expression. We do this only for representable types, to prevent loops with
 -- inlinenonrep.
-casesimpl expr@(Case scrut b ty alts) = do
+casesimpl expr@(Case scrut bndr ty alts) | not bndr_used = do
   (bindingss, alts') <- (Monad.liftM unzip) $ mapM doalt alts
   let bindings = concat bindingss
   -- Replace the case with a let with bindings and a case
-  let newlet = mkNonRecLets bindings (Case scrut b ty alts')
+  let newlet = mkNonRecLets bindings (Case scrut bndr ty alts')
   -- If there are no non-wild binders, or this case is already a simple
   -- selector (i.e., a single alt with exactly one binding), already a simple
   -- selector altan no bindings (i.e., no wild binders in the original case),
   -- don't change anything, otherwise, replace the case.
   if null bindings then return expr else change newlet 
   where
+  -- Check if the scrutinee binder is used
+  is_used (_, _, expr) = expr_uses_binders [bndr] expr
+  bndr_used = or $ map is_used alts
   -- Generate a single wild binder, since they are all the same
   wild = MkCore.mkWildBinder
   -- Wilden the binders of one alt, producing a list of bindings as a
@@ -589,7 +594,7 @@ caseremove, caseremovetop :: Transform
 -- Replace a useless case by the value of its single alternative
 caseremove (Case scrut b ty [(con, bndrs, expr)]) | not usesvars = change expr
     -- Find if any of the binders are used by expr
-    where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
+    where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` b:bndrs))) expr
 -- Leave all other expressions unchanged
 caseremove expr = return expr
 -- Perform this transform everywhere