X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecialise.lhs;h=fa067429abadcc24678b9284da7e2c9c34d74fea;hb=c6eadadbefe2ec5709e9d31893f79c4ff78754b4;hp=3646f916534fc9a95d95dc20abc3c4a5e65b6e94;hpb=8d227e35da15330084dccbd67069d0804adccf4c;p=ghc-hetmet.git

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 3646f91..fa06742 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -23,7 +23,7 @@ import VarSet
 import VarEnv
 import CoreSyn
 import CoreUtils	( applyTypeToArgs, mkPiTypes )
-import CoreFVs		( exprFreeVars, exprsFreeVars, idRuleVars )
+import CoreFVs		( exprFreeVars, exprsFreeVars, idFreeVars )
 import CoreTidy		( tidyRules )
 import CoreLint		( showPass, endPass )
 import Rules		( addIdSpecialisations, mkLocalRule, lookupRule, emptyRuleBase, rulesOfBinds )
@@ -32,7 +32,7 @@ import UniqSupply	( UniqSupply,
 			  UniqSM, initUs_, thenUs, returnUs, getUniqueUs, 
 			  getUs, mapUs
 			)
-import Name		( nameOccName, mkSpecOcc, getSrcLoc )
+import Name
 import MkId		( voidArgId, realWorldPrimId )
 import FiniteMap
 import Maybes		( catMaybes, maybeToBool )
@@ -624,7 +624,9 @@ specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
 specExpr subst (Type ty) = returnSM (Type (substTy subst ty), emptyUDs)
 specExpr subst (Var v)   = returnSM (specVar subst v,         emptyUDs)
 specExpr subst (Lit lit) = returnSM (Lit lit, 		      emptyUDs)
-
+specExpr subst (Cast e co) =
+  specExpr subst e              `thenSM` \ (e', uds) ->
+  returnSM ((Cast e' (substTy subst co)), uds)
 specExpr subst (Note note body)
   = specExpr subst body 	`thenSM` \ (body', uds) ->
     returnSM (Note (specNote subst note) body', uds)
@@ -688,7 +690,6 @@ specExpr subst (Let bind body)
     returnSM (foldr Let body' binds', uds)
 
 -- Must apply the type substitution to coerceions
-specNote subst (Coerce t1 t2) = Coerce (substTy subst t1) (substTy subst t2)
 specNote subst note	      = note
 \end{code}
 
@@ -782,8 +783,8 @@ specDefn :: Subst			-- Subst to use for RHS
 
 specDefn subst calls (fn, rhs)
 	-- The first case is the interesting one
-  |  rhs_tyvars `lengthIs` n_tyvars 	-- Rhs of fn's defn has right number of big lambdas
-  && rhs_bndrs  `lengthAtLeast` n_dicts	-- and enough dict args
+  |  rhs_tyvars `lengthIs`     n_tyvars -- Rhs of fn's defn has right number of big lambdas
+  && rhs_ids    `lengthAtLeast` n_dicts	-- and enough dict args
   && notNull calls_for_me		-- And there are some calls to specialise
 
 --   && not (certainlyWillInline (idUnfolding fn))	-- And it's not small
@@ -805,7 +806,9 @@ specDefn subst calls (fn, rhs)
 	      rhs_uds `plusUDs` plusUDList spec_uds)
 
   | otherwise	-- No calls or RHS doesn't fit our preconceptions
-  = specExpr subst rhs			`thenSM` \ (rhs', rhs_uds) ->
+  = WARN( notNull calls_for_me, ptext SLIT("Missed specialisation opportunity for") <+> ppr fn )
+	  -- Note [Specialisation shape]
+    specExpr subst rhs			`thenSM` \ (rhs', rhs_uds) ->
     returnSM ((fn, rhs'), [], rhs_uds)
   
   where
@@ -897,10 +900,42 @@ specDefn subst calls (fn, rhs)
 
       where
 	my_zipEqual doc xs ys 
-	 | not (equalLength xs ys) = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs)
+#ifdef DEBUG
+	 | not (equalLength xs ys) = pprPanic "my_zipEqual" (vcat 
+						[ ppr xs, ppr ys
+						, ppr fn <+> ppr call_ts
+						, ppr (idType fn), ppr theta
+						, ppr n_dicts, ppr rhs_dicts 
+						, ppr rhs])
+#endif
 	 | otherwise		   = zipEqual doc xs ys
 \end{code}
 
+Note [Specialisation shape]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We only specialise a function if it has visible top-level lambdas
+corresponding to its overloading.  E.g. if
+	f :: forall a. Eq a => ....
+then its body must look like
+	f = /\a. \d. ...
+
+Reason: when specialising the body for a call (f ty dexp), we want to
+substitute dexp for d, and pick up specialised calls in the body of f.
+
+This doesn't always work.  One example I came across was htis:
+	newtype Gen a = MkGen{ unGen :: Int -> a }
+
+	choose :: Eq a => a -> Gen a
+	choose n = MkGen (\r -> n)
+
+	oneof = choose (1::Int)
+
+It's a silly exapmle, but we get
+	choose = /\a. g `cast` co
+where choose doesn't have any dict arguments.  Thus far I have not
+tried to fix this (wait till there's a real example).
+
+
 Note [Inline specialisations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We transfer to the specialised function any INLINE stuff from the
@@ -1071,10 +1106,12 @@ bind_fvs (Rec prs)	   = foldl delVarSet rhs_fvs bndrs
 			     bndrs = map fst prs
 			     rhs_fvs = unionVarSets (map pair_fvs prs)
 
-pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idRuleVars bndr
+pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr
 	-- Don't forget variables mentioned in the
 	-- rules of the bndr.  C.f. OccAnal.addRuleUsage
-
+	-- Also tyvars mentioned in its type; they may not appear in the RHS
+	--	type T a = Int
+	--	x :: T a = 3
 
 addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds }
 
@@ -1181,7 +1218,7 @@ newIdSM old_id new_ty
     let 
 	-- Give the new Id a similar occurrence name to the old one
 	name   = idName old_id
-	new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcLoc name)
+	new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcSpan name)
     in
     returnSM new_id
 \end{code}