X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecialise.lhs;h=849b6006acc1150bf649668b4e1c1427aafc8fe3;hb=f03b9562a92c6ef94c603a334d5d5e1cd2165c92;hp=5d780ea212cc267b49fc4d97cee5d01f3c9b0837;hpb=76dfa3944cbf149a30398d29e6762a44772c0174;p=ghc-hetmet.git

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 5d780ea..849b600 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -588,7 +588,7 @@ specProgram us binds = initSM us $
 
 \begin{code}
 specVar :: Subst -> Id -> CoreExpr
-specVar subst v = lookupIdSubst subst v
+specVar subst v = lookupIdSubst (text "specVar") subst v
 
 specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
 -- We carry a substitution down:
@@ -871,7 +871,7 @@ specDefn subst body_uds fn rhs
 	   	ty_args       = mk_ty_args call_ts
 	   	rhs_subst     = CoreSubst.extendTvSubstList subst spec_tv_binds
 
-	   ; (rhs_subst1, inst_dict_ids) <- cloneDictBndrs rhs_subst rhs_dict_ids
+	   ; (rhs_subst1, inst_dict_ids) <- newDictBndrs rhs_subst rhs_dict_ids
 	     		  -- Clone rhs_dicts, including instantiating their types
 
 	   ; let (rhs_subst2, dx_binds) = bindAuxiliaryDicts rhs_subst1 $
@@ -915,10 +915,15 @@ specDefn subst body_uds fn rhs
 
 		-- Add an InlineRule if the parent has one
 		-- See Note [Inline specialisations]
-		final_spec_f | Just sat <- fn_has_inline_rule
-			     = spec_f_w_arity `setIdUnfolding` mkInlineRule sat spec_rhs spec_arity
-			     | otherwise 
-			     = spec_f_w_arity
+		final_spec_f 
+                  | Just sat <- fn_has_inline_rule
+		  = let 
+                       mb_spec_arity = if sat then Just spec_arity else Nothing
+                    in 
+                    spec_f_w_arity `setIdUnfolding` mkInlineRule spec_rhs mb_spec_arity
+		  | otherwise 
+		  = spec_f_w_arity
+
 	   ; return (Just ((final_spec_f, spec_rhs), final_uds, spec_env_rule)) } }
       where
 	my_zipEqual xs ys zs
@@ -943,6 +948,9 @@ bindAuxiliaryDicts subst triples = go subst [] triples
     go subst binds ((d, dx_id, dx) : pairs)
       | exprIsTrivial dx = go (extendIdSubst subst d dx) binds pairs
              -- No auxiliary binding necessary
+	     -- Note that we bind the *original* dict in the substitution,
+	     -- overriding any d->dx_id binding put there by substBndrs
+
       | otherwise        = go subst_w_unf (NonRec dx_id dx : binds) pairs
       where
         dx_id1 = dx_id `setIdUnfolding` mkUnfolding False False dx
@@ -955,6 +963,9 @@ bindAuxiliaryDicts subst triples = go subst [] triples
 	     -- a consequent call (g d') with an auxiliary definition
 	     --	    d' = df dNumInt
   	     -- We want that consequent call to look interesting
+	     --
+	     -- Again, note that we bind the *original* dict in the substitution,
+	     -- overriding any d->dx_id binding put there by substBndrs
 \end{code}
 
 Note [From non-recursive to recursive]
@@ -1506,19 +1517,27 @@ cloneBindSM subst (Rec pairs) = do
     let (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs)
     return (subst', subst', Rec (bndrs' `zip` map snd pairs))
 
-cloneDictBndrs :: Subst -> [CoreBndr] -> SpecM (Subst, [CoreBndr])
-cloneDictBndrs subst bndrs 
-  = do { us <- getUniqueSupplyM
-       ; return (cloneIdBndrs subst us bndrs) }
+newDictBndrs :: Subst -> [CoreBndr] -> SpecM (Subst, [CoreBndr])
+-- Make up completely fresh binders for the dictionaries
+-- Their bindings are going to float outwards
+newDictBndrs subst bndrs 
+  = do { bndrs' <- mapM new bndrs
+       ; let subst' = extendIdSubstList subst 
+                        [(d, Var d') | (d,d') <- bndrs `zip` bndrs']
+       ; return (subst', bndrs' ) }
+  where
+    new b = do { uniq <- getUniqueM
+    	       ; let n   = idName b
+                     ty' = CoreSubst.substTy subst (idType b)
+               ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) }
 
 newSpecIdSM :: Id -> Type -> SpecM Id
     -- Give the new Id a similar occurrence name to the old one
 newSpecIdSM old_id new_ty
   = do	{ uniq <- getUniqueM
-    	; let 
-	    name    = idName old_id
-	    new_occ = mkSpecOcc (nameOccName name)
-	    new_id  = mkUserLocal new_occ uniq new_ty (getSrcSpan name)
+    	; let name    = idName old_id
+	      new_occ = mkSpecOcc (nameOccName name)
+	      new_id  = mkUserLocal new_occ uniq new_ty (getSrcSpan name)
         ; return new_id }
 \end{code}