X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fstranal%2FWorkWrap.lhs;h=30754e5fe51abe8c4caf2d1a42bcd24ef7970607;hb=21eea25f1212ec306aac806233a2ec048212d529;hp=5143eea08e4b5192801f65a7fc16e1970af62e26;hpb=a26e1e3310f4c92196fe6b4d407f72f3c6824132;p=ghc-hetmet.git

diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs
index 5143eea..30754e5 100644
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.lhs
@@ -10,11 +10,12 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where
 
 import CoreSyn
 import CoreUnfold	( certainlyWillInline )
-import CoreUtils	( exprType, exprIsHNF, exprArity )
+import CoreUtils	( exprType, exprIsHNF )
+import CoreArity	( exprArity )
 import Var
 import Id		( Id, idType, isOneShotLambda, 
 			  setIdNewStrictness, mkWorkerId,
-			  setIdWorkerInfo, setInlinePragma,
+			  setIdWorkerInfo, setInlineActivation,
 			  setIdArity, idInfo )
 import MkId		( lazyIdKey, lazyIdUnfolding )
 import Type		( Type )
@@ -24,7 +25,8 @@ import NewDemand        ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..),
 			)
 import UniqSupply
 import Unique		( hasKey )
-import BasicTypes	( RecFlag(..), isNonRec, isNeverActive )
+import BasicTypes	( RecFlag(..), isNonRec, isNeverActive,
+                          Activation, inlinePragmaActivation )
 import VarEnv		( isEmptyVarEnv )
 import Maybes		( orElse )
 import WwLib
@@ -195,7 +197,7 @@ tryWW is_rec fn_id rhs
   |  -- isNonRec is_rec && 	-- Now omitted: see Note [Don't w/w inline things]
      certainlyWillInline unfolding
 
-  || isNeverActive inline_prag
+  || isNeverActive inline_act
 	-- 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. 
@@ -206,7 +208,7 @@ tryWW is_rec fn_id rhs
     splitThunk new_fn_id rhs
 
   | is_fun && worthSplittingFun wrap_dmds res_info
-  = splitFun new_fn_id fn_info wrap_dmds res_info inline_prag rhs
+  = splitFun new_fn_id fn_info wrap_dmds res_info inline_act rhs
 
   | otherwise
   = return [ (new_fn_id, rhs) ]
@@ -215,7 +217,7 @@ tryWW is_rec fn_id rhs
     fn_info   	 = idInfo fn_id
     maybe_fn_dmd = newDemandInfo fn_info
     unfolding 	 = unfoldingInfo fn_info
-    inline_prag  = inlinePragInfo fn_info
+    inline_act   = inlinePragmaActivation (inlinePragInfo fn_info)
 
 	-- In practice it always will have a strictness 
 	-- signature, even if it's a uninformative one
@@ -235,9 +237,9 @@ tryWW is_rec fn_id rhs
     is_thunk  = not is_fun && not (exprIsHNF rhs)
 
 ---------------------
-splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> InlinePragInfo -> Expr Var
+splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Activation -> Expr Var
          -> UniqSM [(Id, CoreExpr)]
-splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
+splitFun fn_id fn_info wrap_dmds res_info inline_act rhs
   = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) 
     (do {
 	-- The arity should match the signature
@@ -246,13 +248,14 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
     ; let
 	work_rhs = work_fn rhs
 	work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs) 
-			`setInlinePragma` inline_prag
-				-- Any inline pragma (which sets when inlining is active) 
+			`setInlineActivation` inline_act
+				-- Any inline activation (which sets when inlining is active) 
 				-- on the original function is duplicated on the worker and wrapper
 				-- It *matters* that the pragma stays on the wrapper
 				-- It seems sensible to have it on the worker too, although we
 				-- can't think of a compelling reason. (In ptic, INLINE things are 
-				-- not w/wd)
+				-- not w/wd). However, the RuleMatchInfo is not transferred since
+                                -- it does not make sense for workers to be constructorlike.
 			`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
@@ -283,7 +286,7 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
 -- which is very annoying.
 get_one_shots :: Expr Var -> [Bool]
 get_one_shots (Lam b e)
-  | isIdVar b = isOneShotLambda b : get_one_shots e
+  | isId b    = isOneShotLambda b : get_one_shots e
   | otherwise = get_one_shots e
 get_one_shots (Note _ e) = get_one_shots e
 get_one_shots _    	 = noOneShotInfo