Use OPTIONS rather than OPTIONS_GHC for pragmas

[ghc-hetmet.git] / compiler / stranal / WorkWrap.lhs

diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs
index 456f2f0..122750d 100644 (file)
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.lhs
@@ -4,6 +4,13 @@
 \section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+-- for details
+
 module WorkWrap ( wwTopBinds, mkWrapper ) where
 
 #include "HsVersions.h"
@@ -11,11 +18,11 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where
 import CoreSyn
 import CoreUnfold      ( certainlyWillInline )
 import CoreLint                ( showPass, endPass )
-import CoreUtils       ( exprType, exprIsHNF )
+import CoreUtils       ( exprType, exprIsHNF, exprArity )
 import Id              ( Id, idType, isOneShotLambda, 
                          setIdNewStrictness, mkWorkerId,
                          setIdWorkerInfo, setInlinePragma,
-                         idInfo )
+                         setIdArity, idInfo )
 import MkId            ( lazyIdKey, lazyIdUnfolding )
 import Type            ( Type )
 import IdInfo          ( WorkerInfo(..), arityInfo,
@@ -26,7 +33,7 @@ import NewDemand        ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..),
                        )
 import UniqSupply      ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
 import Unique          ( hasKey )
-import BasicTypes      ( RecFlag(..), isNonRec )
+import BasicTypes      ( RecFlag(..), isNonRec, isNeverActive )
 import VarEnv          ( isEmptyVarEnv )
 import Maybes          ( orElse )
 import DynFlags
@@ -215,6 +222,11 @@ tryWW is_rec fn_id rhs
        --      fw = \ab -> (__inline (\x -> E)) (a,b)
        -- and the original __inline now vanishes, so E is no longer
        -- inside its __inline wrapper.  Death!  Disaster!
+
+  || isNeverActive inline_prag
+       -- No point in worker/wrappering if the thing is never inlined!
+       -- Because the no-inline prag will prevent the wrapper ever
+       -- being inlined at a call site. 
   = returnUs [ (new_fn_id, rhs) ]
 
   | is_thunk && worthSplittingThunk maybe_fn_dmd res_info
@@ -269,6 +281,9 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
                        `setIdNewStrictness` StrictSig (mkTopDmdType work_demands work_res_info)
                                -- Even though we may not be at top level, 
                                -- it's ok to give it an empty DmdEnv
+                        `setIdArity` (exprArity work_rhs)
+                                -- Set the arity so that the Core Lint check that the 
+                                -- arity is consistent with the demand type goes through
 
        wrap_rhs = wrap_fn work_id
        wrap_id  = fn_id `setIdWorkerInfo` HasWorker work_id arity