Make warning printing a bit less noisy

[ghc-hetmet.git] / compiler / coreSyn / CorePrep.lhs

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index b8dd80f..738bf82 100644 (file)
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -11,15 +11,16 @@ module CorePrep (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

+import PrelNames       ( lazyIdKey, hasKey )

 import CoreUtils
 import CoreArity
 import CoreFVs
 import CoreUtils
 import CoreArity
 import CoreFVs

-import CoreLint
+import CoreMonad       ( endPass )

 import CoreSyn
 import Type
 import Coercion
 import TyCon
 import CoreSyn
 import Type
 import Coercion
 import TyCon

-import NewDemand
+import Demand

 import Var
 import VarSet
 import VarEnv
 import Var
 import VarSet
 import VarEnv

@@ -85,10 +86,11 @@ The goal of this pass is to prepare for code generation.
 8.  Inject bindings for the "implicit" Ids:
        * Constructor wrappers
        * Constructor workers
 8.  Inject bindings for the "implicit" Ids:
        * Constructor wrappers
        * Constructor workers

-       * Record selectors

     We want curried definitions for all of these in case they
     aren't inlined by some caller.
        
     We want curried definitions for all of these in case they
     aren't inlined by some caller.
        

+9.  Replace (lazy e) by e.  See Note [lazyId magic] in MkId.lhs
+

 This is all done modulo type applications and abstractions, so that
 when type erasure is done for conversion to STG, we don't end up with
 any trivial or useless bindings.
 This is all done modulo type applications and abstractions, so that
 when type erasure is done for conversion to STG, we don't end up with
 any trivial or useless bindings.

@@ -145,7 +147,7 @@ corePrepPgm dflags binds data_tycons = do
                       floats2 <- corePrepTopBinds implicit_binds
                       return (deFloatTop (floats1 `appendFloats` floats2))
 
                       floats2 <- corePrepTopBinds implicit_binds
                       return (deFloatTop (floats1 `appendFloats` floats2))
 

-    endPass dflags "CorePrep" Opt_D_dump_prep binds_out
+    endPass dflags "CorePrep" Opt_D_dump_prep binds_out []

     return binds_out
 
 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
     return binds_out
 
 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr

@@ -242,7 +244,7 @@ cpeBind :: TopLevelFlag
        -> UniqSM (CorePrepEnv, Floats)
 cpeBind top_lvl env (NonRec bndr rhs)
   = do { (_, bndr1) <- cloneBndr env bndr
        -> UniqSM (CorePrepEnv, Floats)
 cpeBind top_lvl env (NonRec bndr rhs)
   = do { (_, bndr1) <- cloneBndr env bndr

-       ; let is_strict   = isStrictDmd (idNewDemandInfo bndr)
+       ; let is_strict   = isStrictDmd (idDemandInfo bndr)

              is_unlifted = isUnLiftedType (idType bndr)
        ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive 
                                                  (is_strict || is_unlifted) 
              is_unlifted = isUnLiftedType (idType bndr)
        ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive 
                                                  (is_strict || is_unlifted) 

@@ -277,35 +279,59 @@ cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
        -> UniqSM (Floats, Id, CoreExpr)
 -- Used for all bindings
 cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
        -> UniqSM (Floats, Id, CoreExpr)
 -- Used for all bindings
 cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs

-  = do { (floats, rhs') <- cpeRhs want_float (idArity bndr) env rhs
+  = do { (floats1, rhs1) <- cpeRhsE env rhs
+       ; let (rhs1_bndrs, _) = collectBinders rhs1
+       ; (floats2, rhs2)
+                   <- if want_float floats1 rhs1 
+                      then return (floats1, rhs1)
+                      else -- Non-empty floats will wrap rhs1
+                    -- But: rhs1 might have lambdas, and we can't
+                   --      put them inside a wrapBinds
+              if valBndrCount rhs1_bndrs <= arity 
+              then    -- Lambdas in rhs1 will be nuked by eta expansion
+                   return (emptyFloats, wrapBinds floats1 rhs1)
+          
+              else do { body1 <- rhsToBodyNF rhs1
+                      ; return (emptyFloats, wrapBinds floats1 body1) } 
+
+       ; (floats3, rhs')   -- Note [Silly extra arguments]
+            <- if manifestArity rhs2 <= arity 
+              then return (floats2, cpeEtaExpand arity rhs2)
+              else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
+                   (do { v <- newVar (idType bndr)
+                       ; let float = mkFloat False False v rhs2
+                       ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })

 
                -- Record if the binder is evaluated
        ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
                           | otherwise      = bndr
 
 
                -- Record if the binder is evaluated
        ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
                           | otherwise      = bndr
 

-       ; return (floats, bndr', rhs') }
+       ; return (floats3, bndr', rhs') }

   where
   where

+    arity = idArity bndr       -- We must match this arity

     want_float floats rhs 
      | isTopLevel top_lvl = wantFloatTop bndr floats
      | otherwise          = wantFloatNested is_rec is_strict_or_unlifted floats rhs
 
     want_float floats rhs 
      | isTopLevel top_lvl = wantFloatTop bndr floats
      | otherwise          = wantFloatNested is_rec is_strict_or_unlifted floats rhs
 

-
+{- Note [Silly extra arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we had this
+       f{arity=1} = \x\y. e
+We *must* match the arity on the Id, so we have to generate
+        f' = \x\y. e
+       f  = \x. f' x
+
+It's a bizarre case: why is the arity on the Id wrong?  Reason
+(in the days of __inline_me__): 
+        f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
+When InlineMe notes go away this won't happen any more.  But
+it seems good for CorePrep to be robust.
+-}

 
 -- ---------------------------------------------------------------------------
 --             CpeRhs: produces a result satisfying CpeRhs
 -- ---------------------------------------------------------------------------
 
 
 -- ---------------------------------------------------------------------------
 --             CpeRhs: produces a result satisfying CpeRhs
 -- ---------------------------------------------------------------------------
 

-cpeRhs :: (Floats -> CpeRhs -> Bool)   -- Float the floats out
-       -> Arity                -- Guarantees an Rhs with this manifest arity
-       -> CorePrepEnv
-       -> CoreExpr     -- Expression and its type
-       -> UniqSM (Floats, CpeRhs)
-cpeRhs want_float arity env expr
-  = do { (floats, rhs) <- cpeRhsE env expr
-       ; if want_float floats rhs
-                then return (floats,      cpeEtaExpand arity rhs)
-                else return (emptyFloats, cpeEtaExpand arity (wrapBinds floats rhs)) }
-

 cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 -- If
 --     e  ===>  (bs, e')
 cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 -- If
 --     e  ===>  (bs, e')

@@ -317,9 +343,14 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 
 cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
 cpeRhsE _env expr@(Lit _)  = return (emptyFloats, expr)
 
 cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
 cpeRhsE _env expr@(Lit _)  = return (emptyFloats, expr)

-cpeRhsE env expr@(App {})  = cpeApp env expr

 cpeRhsE env expr@(Var {})  = cpeApp env expr
 
 cpeRhsE env expr@(Var {})  = cpeApp env expr
 

+cpeRhsE env (Var f `App` _ `App` arg)
+  | f `hasKey` lazyIdKey         -- Replace (lazy a) by a
+  = cpeRhsE env arg              -- See Note [lazyId magic] in MkId
+
+cpeRhsE env expr@(App {}) = cpeApp env expr
+

 cpeRhsE env (Let bind expr)
   = do { (env', new_binds) <- cpeBind NotTopLevel env bind
        ; (floats, body) <- cpeRhsE env' expr
 cpeRhsE env (Let bind expr)
   = do { (env', new_binds) <- cpeBind NotTopLevel env bind
        ; (floats, body) <- cpeRhsE env' expr

@@ -377,8 +408,13 @@ cpeBody env expr
        ; return (floats1 `appendFloats` floats2, body) }
 
 --------
        ; return (floats1 `appendFloats` floats2, body) }
 
 --------

+rhsToBodyNF :: CpeRhs -> UniqSM CpeBody
+rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs
+                    ; return (wrapBinds floats body) }
+
+--------

 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)

--- Remove top level lambdas by let-bindinig
+-- Remove top level lambdas by let-binding

 
 rhsToBody (Note n expr)
         -- You can get things like
 
 rhsToBody (Note n expr)
         -- You can get things like

@@ -446,7 +482,7 @@ cpeApp env expr
 
     collect_args (App fun arg) depth
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
 
     collect_args (App fun arg) depth
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)

-           ; let
+          ; let

               (ss1, ss_rest)   = case ss of
                                    (ss1:ss_rest) -> (ss1,     ss_rest)
                                    []            -> (lazyDmd, [])
               (ss1, ss_rest)   = case ss of
                                    (ss1:ss_rest) -> (ss1,     ss_rest)
                                    []            -> (lazyDmd, [])

@@ -461,7 +497,7 @@ cpeApp env expr
            ; let v2 = lookupCorePrepEnv env v1
            ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
        where
            ; let v2 = lookupCorePrepEnv env v1
            ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
        where

-         stricts = case idNewStrictness v of
+         stricts = case idStrictness v of

                        StrictSig (DmdType _ demands _)
                            | listLengthCmp demands depth /= GT -> demands
                                    -- length demands <= depth
                        StrictSig (DmdType _ demands _)
                            | listLengthCmp demands depth /= GT -> demands
                                    -- length demands <= depth

@@ -482,10 +518,10 @@ cpeApp env expr
       = collect_args fun depth  -- They aren't used by the code generator
 
        -- N-variable fun, better let-bind it
       = collect_args fun depth  -- They aren't used by the code generator
 
        -- N-variable fun, better let-bind it

-       -- ToDo: perhaps we can case-bind rather than let-bind this closure,
-       -- since it is sure to be evaluated.

     collect_args fun depth
       = do { (fun_floats, fun') <- cpeArg env True fun ty
     collect_args fun depth
       = do { (fun_floats, fun') <- cpeArg env True fun ty

+                         -- The True says that it's sure to be evaluated,
+                         -- so we'll end up case-binding it

            ; return (fun', (fun', depth), ty, fun_floats, []) }
         where
          ty = exprType fun
            ; return (fun', (fun', depth), ty, fun_floats, []) }
         where
          ty = exprType fun

@@ -498,14 +534,21 @@ cpeApp env expr
 cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type
        -> UniqSM (Floats, CpeTriv)
 cpeArg env is_strict arg arg_ty
 cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type
        -> UniqSM (Floats, CpeTriv)
 cpeArg env is_strict arg arg_ty

-  | cpe_ExprIsTrivial arg      -- Do not eta expand etc a trivial argument
-  = cpeBody env arg    -- Must still do substitution though
+  | cpe_ExprIsTrivial arg   -- Do not eta expand etc a trivial argument
+  = cpeBody env arg        -- Must still do substitution though

   | otherwise
   | otherwise

-  = do { (floats, arg') <- cpeRhs want_float
-                                         (exprArity arg) env arg
+  = do { (floats1, arg1) <- cpeRhsE env arg    -- arg1 can be a lambda
+       ; (floats2, arg2) <- if want_float floats1 arg1 
+                                   then return (floats1, arg1)
+                                   else do { body1 <- rhsToBodyNF arg1
+                                   ; return (emptyFloats, wrapBinds floats1 body1) } 
+               -- Else case: arg1 might have lambdas, and we can't
+               --            put them inside a wrapBinds
+

        ; v <- newVar arg_ty
        ; v <- newVar arg_ty

-       ; let arg_float = mkFloat is_strict is_unlifted v arg'
-       ; return (addFloat floats arg_float, Var v) }
+       ; let arg3      = cpeEtaExpand (exprArity arg2) arg2
+                    arg_float = mkFloat is_strict is_unlifted v arg3
+       ; return (addFloat floats2 arg_float, Var v) }

   where
     is_unlifted = isUnLiftedType arg_ty
     want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
   where
     is_unlifted = isUnLiftedType arg_ty
     want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)

@@ -597,7 +640,6 @@ ignoreNote :: Note -> Bool
 -- want to get this:
 --     unzip = /\ab \xs. (__inline_me__ ...) a b xs
 ignoreNote (CoreNote _) = True 
 -- want to get this:
 --     unzip = /\ab \xs. (__inline_me__ ...) a b xs
 ignoreNote (CoreNote _) = True 

-ignoreNote InlineMe     = True

 ignoreNote _other       = False
 
 
 ignoreNote _other       = False
 
 

@@ -748,6 +790,9 @@ mkFloat is_strict is_unlifted bndr rhs
 emptyFloats :: Floats
 emptyFloats = Floats OkToSpec nilOL
 
 emptyFloats :: Floats
 emptyFloats = Floats OkToSpec nilOL
 

+isEmptyFloats :: Floats -> Bool
+isEmptyFloats (Floats _ bs) = isNilOL bs
+

 wrapBinds :: Floats -> CoreExpr -> CoreExpr
 wrapBinds (Floats _ binds) body
   = foldrOL mk_bind body binds
 wrapBinds :: Floats -> CoreExpr -> CoreExpr
 wrapBinds (Floats _ binds) body
   = foldrOL mk_bind body binds

@@ -800,12 +845,14 @@ deFloatTop (Floats _ floats)
 -------------------------------------------
 wantFloatTop :: Id -> Floats -> Bool
        -- Note [CafInfo and floating]
 -------------------------------------------
 wantFloatTop :: Id -> Floats -> Bool
        -- Note [CafInfo and floating]

-wantFloatTop bndr floats = mayHaveCafRefs (idCafInfo bndr)
-                          && allLazyTop floats
+wantFloatTop bndr floats = isEmptyFloats floats
+                        || (mayHaveCafRefs (idCafInfo bndr)
+                            && allLazyTop floats)

 
 wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
 wantFloatNested is_rec strict_or_unlifted floats rhs
 
 wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
 wantFloatNested is_rec strict_or_unlifted floats rhs

-  = strict_or_unlifted
+  =  isEmptyFloats floats
+  || strict_or_unlifted

   || (allLazyNested is_rec floats && exprIsHNF rhs)
        -- Why the test for allLazyNested? 
        --      v = f (x `divInt#` y)
   || (allLazyNested is_rec floats && exprIsHNF rhs)
        -- Why the test for allLazyNested? 
        --      v = f (x `divInt#` y)