X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecConstr.lhs;h=8bba247a531dc3a14506c54103b6db4b9d16dd99;hb=a3995529c5dc1e4970b1245764ffd3d51a2db25a;hp=cc020961f2911045c6ce44bc09a45de552702fbc;hpb=a174d117a539dc1e4bbb6f9bef63851f6985611f;p=ghc-hetmet.git

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index cc02096..8bba247 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -14,14 +14,12 @@ import CoreSyn
 import CoreLint		( showPass, endPass )
 import CoreUtils	( exprType, mkPiTypes )
 import CoreFVs 		( exprsFreeVars )
-import CoreSubst	( Subst, mkSubst, substExpr )
 import CoreTidy		( tidyRules )
 import PprCore		( pprRules )
 import WwLib		( mkWorkerArgs )
-import DataCon		( dataConRepArity, isVanillaDataCon, dataConTyVars )
-import Type		( tyConAppArgs, tyVarsOfTypes )
+import DataCon		( dataConRepArity, dataConUnivTyVars )
+import Type		( Type, tyConAppArgs )
 import Rules		( matchN )
-import Unify		( coreRefineTys )
 import Id		( Id, idName, idType, isDataConWorkId_maybe, 
 			  mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
 import Var		( Var )
@@ -429,12 +427,6 @@ data ConValue  = CV AltCon [CoreArg]
 instance Outputable ConValue where
    ppr (CV con args) = ppr con <+> interpp'SP args
 
-refineConstrEnv :: Subst -> ConstrEnv -> ConstrEnv
--- The substitution is a type substitution only
-refineConstrEnv subst env = mapVarEnv refine_con_value env
-  where
-    refine_con_value (CV con args) = CV con (map (substExpr subst) args)
-
 emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv }
 
 data HowBound = RecFun	-- These are the recursive functions for which 
@@ -483,28 +475,11 @@ extendCaseBndrs env case_bndr scrut con alt_bndrs
 		  Var v -> lookupVarEnv cur_scope v `orElse` Other
 		  other -> Other
 
-    extend_data_con data_con
-	| isVanillaDataCon data_con = extendCons env1 scrut case_bndr (CV con vanilla_args)
-	| otherwise		    = extendCons env2 scrut case_bndr (CV con gadt_args)
-		-- Note env2 for GADTs
+    extend_data_con data_con = 
+      extendCons env1 scrut case_bndr (CV con vanilla_args)
 	where
-    
 	    vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
-			   map varToCoreExpr alt_bndrs
-
-	    gadt_args = map (substExpr subst . varToCoreExpr) alt_bndrs
-		-- This call generates some bogus warnings from substExpr,
-		-- because it's inconvenient to put all the Ids in scope
-		-- Will be fixed when we move to FC
-
-	    (alt_tvs, _) = span isTyVar alt_bndrs
-	    Just (tv_subst, is_local) = coreRefineTys data_con alt_tvs (idType case_bndr)
-	    subst = mkSubst in_scope tv_subst emptyVarEnv	-- No Id substitition
-	    in_scope = mkInScopeSet (tyVarsOfTypes (varEnvElts tv_subst))
-	
-	    env2 | is_local  = env1
-		 | otherwise = env1 { cons = refineConstrEnv subst (cons env) }
-
+			   varsToCoreExprs alt_bndrs
 
 extendCons :: ScEnv -> CoreExpr -> Id -> ConValue -> ScEnv
 extendCons env scrut case_bndr val
@@ -588,7 +563,7 @@ A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
 -}
 
 instance Outputable ArgOcc where
-  ppr (ScrutOcc xs) = ptext SLIT("scrut-occ") <+> ppr xs
+  ppr (ScrutOcc xs) = ptext SLIT("scrut-occ") <> parens (ppr xs)
   ppr UnkOcc 	    = ptext SLIT("unk-occ")
   ppr BothOcc 	    = ptext SLIT("both-occ")
   ppr NoOcc    	    = ptext SLIT("no-occ")
@@ -608,10 +583,7 @@ conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
 
 conArgOccs (ScrutOcc fm) (DataAlt dc) 
   | Just pat_arg_occs <- lookupUFM fm dc
-  = tyvar_unks ++ pat_arg_occs
-  where
-    tyvar_unks | isVanillaDataCon dc = [UnkOcc | tv <- dataConTyVars dc]
-	       | otherwise	     = []
+  = [UnkOcc | tv <- dataConUnivTyVars dc] ++ pat_arg_occs
 
 conArgOccs other con = repeat UnkOcc
 \end{code}
@@ -636,6 +608,8 @@ scExpr env e@(Lit l)  = returnUs (nullUsage, e)
 scExpr env e@(Var v)  = returnUs (varUsage env v UnkOcc, e)
 scExpr env (Note n e) = scExpr env e	`thenUs` \ (usg,e') ->
 			returnUs (usg, Note n e')
+scExpr env (Cast e co)= scExpr env e	`thenUs` \ (usg,e') ->
+                        returnUs (usg, Cast e' co)
 scExpr env (Lam b e)  = scExpr (extendBndr env b) e	`thenUs` \ (usg,e') ->
 			returnUs (usg, Lam b e')
 
@@ -761,9 +735,8 @@ specialise env fn bndrs body body_usg
 			 [ exprsFreeVars pats `delVarSetList` vs 
 			 | (vs,pats) <- good_calls ]
 	      uniq_calls = nubBy (same_call in_scope) good_calls
-    in
-    mapAndUnzipUs (spec_one env fn (mkLams bndrs body)) 
-		  (uniq_calls `zip` [1..]) }
+	; mapAndUnzipUs (spec_one env fn (mkLams bndrs body)) 
+			(uniq_calls `zip` [1..]) }
   where
 	-- Two calls are the same if they match both ways
     same_call in_scope (vs1,as1)(vs2,as2)
@@ -864,23 +837,6 @@ specConstrActivation = ActiveAfter 0	-- Baked in; see comments above
 This code deals with analysing call-site arguments to see whether
 they are constructor applications.
 
----------------------
-good_arg :: ConstrEnv -> IdEnv ArgOcc -> (CoreBndr, CoreArg) -> Bool
--- See Note [Good arguments] above
-good_arg con_env arg_occs (bndr, arg)
-  = case is_con_app_maybe con_env arg of	
-	Just _ ->  bndr_usg_ok arg_occs bndr arg
-	other   -> False
-
-bndr_usg_ok :: IdEnv ArgOcc -> Var -> CoreArg -> Bool
-bndr_usg_ok arg_occs bndr arg
-  = case lookupVarEnv arg_occs bndr of
-	Just ScrutOcc -> True			-- Used only by case scrutiny
-	Just Both     -> case arg of		-- Used by case and elsewhere
-			    App _ _ -> True	-- so the arg should be an explicit con app
-			    other   -> False
-	other -> False				-- Not used, or used wonkily
-    
 
 \begin{code}
     -- argToPat takes an actual argument, and returns an abstracted
@@ -907,10 +863,17 @@ argToPat :: InScopeEnv			-- What's in scope at the fn defn site
 argToPat in_scope con_env arg@(Type ty) arg_occ
   = return (False, arg)
 
-argToPat in_scope con_env (Var v) arg_occ	-- Don't uniqify existing vars,
-  = return (interesting, Var v)	-- so that we can spot when we pass them twice
-  where
-    interesting = not (isLocalId v) || v `elemVarEnv` in_scope
+argToPat in_scope con_env (Var v) arg_occ
+  | not (isLocalId v) || v `elemVarEnv` in_scope
+  = 	-- The recursive call passes a variable that 
+	-- is in scope at the function definition site
+	-- It's worth specialising on this if
+	--	(a) it's used in an interesting way in the body
+	--	(b) we know what its value is
+    if    (case arg_occ of { UnkOcc -> False; other -> True })	-- (a)
+       && isValueUnfolding (idUnfolding v)			-- (b)
+    then return (True, Var v)
+    else wildCardPat (idType v)
 
 argToPat in_scope con_env arg arg_occ
   | is_value_lam arg
@@ -932,10 +895,20 @@ argToPat in_scope con_env arg arg_occ
   = do	{ args' <- argsToPats in_scope con_env (args `zip` conArgOccs arg_occ dc)
 	; return (True, mk_con_app dc (map snd args')) }
 
-argToPat in_scope con_env arg arg_occ
-  = do	{ uniq <- getUniqueUs
-	; let id = mkSysLocal FSLIT("sc") uniq (exprType arg)
-	; return (False, Var id) }
+argToPat in_scope con_env (Var v) arg_occ
+  = 	-- A variable bound inside the function. 
+	-- Don't make a wild-card, because we may usefully share
+	--	e.g.  f a = let x = ... in f (x,x)
+	-- NB: this case follows the lambda and con-app cases!!
+    return (False, Var v)
+
+-- The default case: make a wild-card
+argToPat in_scope con_env arg arg_occ = wildCardPat (exprType arg)
+
+wildCardPat :: Type -> UniqSM (Bool, CoreArg)
+wildCardPat ty = do { uniq <- getUniqueUs
+		    ; let id = mkSysLocal FSLIT("sc") uniq ty
+		    ; return (False, Var id) }
 
 argsToPats :: InScopeEnv -> ConstrEnv
 	   -> [(CoreArg, ArgOcc)]
@@ -980,4 +953,5 @@ is_con_app_maybe env expr
 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
 mk_con_app (LitAlt lit)  []   = Lit lit
 mk_con_app (DataAlt con) args = mkConApp con args
+mk_con_app other args = panic "SpecConstr.mk_con_app"
 \end{code}