X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=clash%2FCLasH%2FNormalize.hs;h=89f21c00ef0ecf83661a8a6248b5ae6b758d69d4;hb=bc062e2fd11672ccdd4705e5211efba0d8efbd64;hp=4ce4ffa53b4b189b4f7983968f5aac0a18c47ad8;hpb=a2b8cfae9cad1ad7040993f7f2458dd73fb968cd;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/clash/CLasH/Normalize.hs b/clash/CLasH/Normalize.hs
index 4ce4ffa..89f21c0 100644
--- a/clash/CLasH/Normalize.hs
+++ b/clash/CLasH/Normalize.hs
@@ -158,7 +158,7 @@ castsimpl c expr = return expr
 -- By not inlining any other reference, we also prevent looping problems
 -- with funextract and inlinedict.
 inlinetoplevel :: Transform
-inlinetoplevel (LetBinding:_) expr | not (is_fun expr) =
+inlinetoplevel c expr | not (null c) && is_letbinding_ctx (head c) && not (is_fun expr) =
   case collectArgs expr of
 	(Var f, args) -> do
 	  body_maybe <- needsInline f
@@ -216,12 +216,12 @@ needsInline f = do
 -- body consisting of a bunch of nested lambdas containing a
 -- non-function value (e.g., a complete application).
 eta :: Transform
-eta (AppFirst:_) expr = return expr
+eta c expr | not (null c) && is_appfirst_ctx (head c) = return expr
 -- Also don't apply to arguments, since this can cause loops with
 -- funextract. This isn't the proper solution, but due to an
 -- implementation bug in notappargs, this is how it used to work so far.
-eta (AppSecond:_) expr = return expr
-eta c expr | is_fun expr && not (is_lam expr) = do
+           | not (null c) && is_appsecond_ctx (head c) = return expr
+           | is_fun expr && not (is_lam expr) = do
  let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr
  id <- Trans.lift $ mkInternalVar "param" arg_ty
  change (Lam id (App expr (Var id)))
@@ -296,7 +296,7 @@ letflat c expr = return expr
 -- Extract the return value from the body of the top level lambdas (of
 -- which ther could be zero), unless it is a let expression (in which
 -- case the next clause applies).
-retvalsimpl c expr | all (== LambdaBody) c && not (is_lam expr) && not (is_let expr) = do
+retvalsimpl c expr | all is_lambdabody_ctx c && not (is_lam expr) && not (is_let expr) = do
   local_var <- Trans.lift $ is_local_var expr
   repr <- isRepr expr
   if not local_var && repr
@@ -308,7 +308,7 @@ retvalsimpl c expr | all (== LambdaBody) c && not (is_lam expr) && not (is_let e
 -- Extract the return value from the body of a let expression, which is
 -- itself the body of the top level lambdas (of which there could be
 -- zero).
-retvalsimpl c expr@(Let (Rec binds) body) | all (== LambdaBody) c = do
+retvalsimpl c expr@(Let (Rec binds) body) | all is_lambdabody_ctx c = do
   -- Don't extract values that are already a local variable, to prevent
   -- loops with ourselves.
   local_var <- Trans.lift $ is_local_var body
@@ -410,15 +410,14 @@ funextract c expr = return expr
 -- Make sure the scrutinee of a case expression is a local variable
 -- reference.
 scrutsimpl :: Transform
--- Don't touch scrutinees that are already simple
-scrutsimpl c expr@(Case (Var _) _ _ _) = return expr
--- Replace all other cases with a let that binds the scrutinee and a new
+-- Replace a case expression with a let that binds the scrutinee and a new
 -- simple scrutinee, but only when the scrutinee is representable (to prevent
 -- loops with inlinenonrep, though I don't think a non-representable scrutinee
--- will be supported anyway...) 
+-- will be supported anyway...) and is not a local variable already.
 scrutsimpl c expr@(Case scrut b ty alts) = do
   repr <- isRepr scrut
-  if repr
+  local_var <- Trans.lift $ is_local_var scrut
+  if repr && not local_var
     then do
       id <- Trans.lift $ mkBinderFor scrut "scrut"
       change $ Let (NonRec id scrut) (Case (Var id) b ty alts)
@@ -490,7 +489,23 @@ casesimpl c expr@(Case scrut bndr ty alts) | not bndr_used = do
   -- Wilden the binders of one alt, producing a list of bindings as a
   -- sideeffect.
   doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt)
-  doalt (con, bndrs, expr) = do
+  doalt (LitAlt _, _, _) = error $ "Don't know how to handle LitAlt in case expression: " ++ pprString expr
+  doalt alt@(DEFAULT, [], expr) = do
+    local_var <- Trans.lift $ is_local_var expr
+    repr <- isRepr expr
+    (exprbinding_maybe, expr') <- if (not local_var) && repr
+      then do
+        id <- Trans.lift $ mkBinderFor expr "caseval"
+        -- We don't flag a change here, since casevalsimpl will do that above
+        -- based on Just we return here.
+        return (Just (id, expr), Var id)
+      else
+        -- Don't simplify anything else
+        return (Nothing, expr)
+    let newalt = (DEFAULT, [], expr')
+    let bindings = Maybe.catMaybes [exprbinding_maybe]
+    return (bindings, newalt)
+  doalt (DataAlt dc, bndrs, expr) = do
     -- Make each binder wild, if possible
     bndrs_res <- Monad.zipWithM dobndr bndrs [0..]
     let (newbndrs, bindings_maybe) = unzip bndrs_res
@@ -500,7 +515,7 @@ casesimpl c expr@(Case scrut bndr ty alts) | not bndr_used = do
     let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) expr
     (exprbinding_maybe, expr') <- doexpr expr uses_bndrs
     -- Create a new alternative
-    let newalt = (con, newbndrs, expr')
+    let newalt = (DataAlt dc, newbndrs, expr')
     let bindings = Maybe.catMaybes (bindings_maybe ++ [exprbinding_maybe])
     return (bindings, newalt)
     where
@@ -522,7 +537,8 @@ casesimpl c expr@(Case scrut bndr ty alts) | not bndr_used = do
         -- inlinenonrep).
         if (not wild) && repr
           then do
-            caseexpr <- Trans.lift $ mkSelCase scrut i
+            let dc_i = datacon_index (CoreUtils.exprType scrut) dc
+            caseexpr <- Trans.lift $ mkSelCase scrut dc_i i
             -- Create a new binder that will actually capture a value in this
             -- case statement, and return it.
             return (wildbndrs!!i, Just (b, caseexpr))
@@ -753,7 +769,7 @@ inlinenonrepresult :: Transform
 -- that is fully applied (i.e., dos not have a function type) but is not
 -- representable. We apply in any context, since non-representable
 -- expressions are generally left alone and can occur anywhere.
-inlinenonrepresult context expr | not (is_fun expr) =
+inlinenonrepresult context expr | not (is_applicable expr) && not (has_free_tyvars expr) =
   case collectArgs expr of
     (Var f, args) | not (Id.isDictId f) -> do
       repr <- isRepr expr
@@ -794,7 +810,7 @@ inlinenonrepresult context expr | not (is_fun expr) =
                   res_bndr <- Trans.lift $ mkBinderFor newapp "res"
                   -- Create extractor case expressions to extract each of the
                   -- free variables from the tuple.
-                  sel_cases <- Trans.lift $ mapM (mkSelCase (Var res_bndr)) [0..n_free_vars-1]
+                  sel_cases <- Trans.lift $ mapM (mkSelCase (Var res_bndr) 0) [0..n_free_vars-1]
 
                   -- Bind the res_bndr to the result of the new application
                   -- and each of the free variables to the corresponding
@@ -821,6 +837,10 @@ inlinenonrepresult context expr | not (is_fun expr) =
 -- Leave all other expressions unchanged
 inlinenonrepresult c expr = return expr
 
+----------------------------------------------------------------
+-- Type-class transformations
+----------------------------------------------------------------
+
 --------------------------------
 -- ClassOp resolution
 --------------------------------
@@ -952,7 +972,7 @@ letmerge c expr = return expr
 -- What transforms to run?
 transforms = [ ("inlinedict", inlinedict)
              , ("inlinetoplevel", inlinetoplevel)
-             -- , ("inlinenonrepresult", inlinenonrepresult)
+             , ("inlinenonrepresult", inlinenonrepresult)
              , ("knowncase", knowncase)
              , ("classopresolution", classopresolution)
              , ("argprop", argprop)