While I was looking at the rule binders generated in DsBinds for specialise pragmas,
I also looked at Specialise. It too was "cloning" the dictionary binders including
their IdInfo. In this case they should not have any, but its seems better to make
them completely fresh rather than substitute in existing (albeit non-existent) IdInfo.
ty_args = mk_ty_args call_ts
rhs_subst = CoreSubst.extendTvSubstList subst spec_tv_binds
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 $
-- Clone rhs_dicts, including instantiating their types
; let (rhs_subst2, dx_binds) = bindAuxiliaryDicts rhs_subst1 $
go subst binds ((d, dx_id, dx) : pairs)
| exprIsTrivial dx = go (extendIdSubst subst d dx) binds pairs
-- No auxiliary binding necessary
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
| otherwise = go subst_w_unf (NonRec dx_id dx : binds) pairs
where
dx_id1 = dx_id `setIdUnfolding` mkUnfolding False False dx
-- a consequent call (g d') with an auxiliary definition
-- d' = df dNumInt
-- We want that consequent call to look interesting
-- 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]
\end{code}
Note [From non-recursive to recursive]
let (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs)
return (subst', subst', Rec (bndrs' `zip` map snd pairs))
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
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}
; return new_id }
\end{code}