X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectorise.hs;h=ea69c4ff6e8845a48a940e7845ab1c21e37fb41a;hb=28c2bbb03ff6144f3a09e5286c8c3ca6ad3689e8;hp=59fded3c4f01c552c081869fd34c7698b2e285d6;hpb=222415a5b658e737a0a1f2c980c6f80635289f75;p=ghc-hetmet.git

diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index 59fded3..ea69c4f 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -106,7 +106,7 @@ vectTopBinder var inline expr
       return var'
   where
     unfolding = case inline of
-                  Inline arity -> mkInlineRule InlSat expr arity
+                  Inline arity -> mkInlineRule expr (Just arity)
                   DontInline   -> noUnfolding
 
 vectTopRhs :: Var -> CoreExpr -> VM (Inline, CoreExpr)
@@ -314,7 +314,8 @@ vectScalarLam args body
       scalars <- globalScalars
       onlyIfV (all is_scalar_ty arg_tys
                && is_scalar_ty res_ty
-               && is_scalar (extendVarSetList scalars args) body)
+               && is_scalar (extendVarSetList scalars args) body
+               && uses scalars body)
         $ do
             fn_var <- hoistExpr (fsLit "fn") (mkLams args body) DontInline
             zipf <- zipScalars arg_tys res_ty
@@ -339,6 +340,14 @@ vectScalarLam args body
     is_scalar vs (App e1 e2) = is_scalar vs e1 && is_scalar vs e2
     is_scalar _ _            = False
 
+    -- A scalar function has to actually compute something. Without the check,
+    -- we would treat (\(x :: Int) -> x) as a scalar function and lift it to
+    -- (map (\x -> x)) which is very bad. Normal lifting transforms it to
+    -- (\n# x -> x) which is what we want.
+    uses funs (Var v)     = v `elemVarSet` funs 
+    uses funs (App e1 e2) = uses funs e1 || uses funs e2
+    uses _ _              = False
+
 vectLam :: Bool -> Bool -> VarSet -> [Var] -> CoreExprWithFVs -> VM VExpr
 vectLam inline loop_breaker fvs bs body
   = do