- returnSM ([], thing, final_uds)
- )
- else
- -- Ho! A group of ordinary (non-dict) bindings
- fixSM (\ ~(_, _, _, rec_spec_infos) ->
-
- bindSpecIds binders clone_infos rec_spec_infos (
- -- It's ok to have new binders in scope in
- -- non-recursive decls too, cos name shadowing is gone by now
-
- -- Do the scope of the bindings
- scopeM `thenSM` \ (thing, scope_uds) ->
- let
- (call_insts_these_binders, gotci_scope_uds) = getCIs new_binders scope_uds
- in
-
- -- Do the bindings themselves
- specBind new_binders bind `thenSM` \ (spec_bind, spec_uds) ->
-
- -- Create any necessary instances
- instBind new_binders bind call_insts_these_binders
- `thenSM` \ (inst_binds, inst_uds, spec_infos) ->
-
- let
- -- Dump any dictionary bindings from the scope
- -- which mention things bound here
- (dict_binds, final_scope_uds) = dumpUDs gotci_scope_uds new_binders []
- -- The spec_ids can't appear anywhere in uds, because they only
- -- appear in SpecInfos.
-
- -- Build final binding group
- -- see note below about dependecies
- final_binds = [spec_bind,
- CoRec (pairsFromCoreBinds (inst_binds ++ dict_binds))
- ]
-
- in
- -- Combine the results together
- returnSM (final_binds,
- thing,
- spec_uds `unionUDs` final_scope_uds `unionUDs` inst_uds,
- -- inst_uds comes last, because there may be dict bindings
- -- floating outward in final_scope_uds which are mentioned
- -- in the call-instances, and hence in spec_uds.
- -- This ordering makes sure that the precedence order
- -- among the dict bindings finally floated out is maintained.
- spec_infos)
- )
- ) `thenSM` \ (binds, thing, final_uds, spec_infos) ->
- returnSM (binds, thing, final_uds)
- where
- binders = bindersOf bind
-\end{code}
-
-We place the spec_binds and dict_binds in a CoRec as there may be some
-nasty dependencies. These don't actually require a CoRec, but its the
-simplest solution. (The alternative would require some tricky dependency
-analysis.) We leave it to the real dependency analyser to sort it all
-out during a subsequent simplification pass.
-
-Where do these dependencies arise? Consider this case:
-
- data Foo a = ...
-
- {- instance Eq a => Eq (Foo a) where ... -}
- dfun.Eq.(Foo *) d.eq.a = <wurble>
-
- d2 = dfun.Eq.(Foo *) Char# d.Eq.Char#
- d1 = dfun.Eq.(Foo *) (Foo Char#) d2
-
-Now, when specialising we must write the Char# instance of dfun.Eq.(Foo *) before
-that for the (Foo Char#) instance:
-
- dfun.Eq.(Foo *) d.eq.a = <wurble>
-
- dfun.Eq.(Foo *)@Char# = <wurble>[d.Eq.Char#/d.eq.a]
- d2 = dfun.Eq.(Foo *)@Char#
-
- dfun.Eq.(Foo *)@(Foo Char#) = <wurble>[d2/d.eq.a]
- d1 = dfun.Eq.(Foo *)@(Foo Char#)
-
-The definition of dfun.Eq.(Foo *)@(Foo Char#) uses d2!!! So it must
-come after the definition of dfun.Eq.(Foo *)@Char#.
-AAARGH!
-
-
-
-\begin{code}
-specBind :: [Id] -> PlainCoreBinding -> SpecM (PlainCoreBinding, UsageDetails)
- -- The UsageDetails returned has already had stuff to do with this group
- -- of binders deleted; that's why new_binders is passed in.
-specBind new_binders (CoNonRec binder rhs)
- = specOneBinding new_binders (binder,rhs) `thenSM` \ ((binder,rhs), rhs_uds) ->
- returnSM (CoNonRec binder rhs, rhs_uds)
-
-specBind new_binders (CoRec pairs)
- = mapAndUnzipSM (specOneBinding new_binders) pairs `thenSM` \ (pairs, rhs_uds_s) ->
- returnSM (CoRec pairs, unionUDList rhs_uds_s)
-
-
-specOneBinding :: [Id] -> (Id,PlainCoreExpr) -> SpecM ((Id,PlainCoreExpr), UsageDetails)
-
-specOneBinding new_binders (binder, rhs)
- = lookupId binder `thenSM` \ blookup ->
- specExpr rhs [] `thenSM` \ (rhs, rhs_uds) ->
- let
- specid_maybe_maybe = isSpecPragmaId_maybe binder
- is_specid = maybeToBool specid_maybe_maybe
- Just specinfo_maybe = specid_maybe_maybe
- specid_with_info = maybeToBool specinfo_maybe
- Just spec_info = specinfo_maybe
-
- pragma_uds
- = if is_specid && specid_with_info then
- -- Have a SpecInfo stored in a SpecPragmaId binder
- -- This contains the SpecInfo for a specialisation pragma
- -- with an explicit SpecId specified
- -- We remove any cis for orig_id (there should only be one)
- -- and add the explicit ci to the usage details
- let
- (SpecInfo spec_tys _ spec_id) = spec_info
- Just (orig_id, _) = isSpecId_maybe spec_id
- in
- ASSERT(toplevelishId orig_id) -- must not be cloned!
- explicitCI orig_id spec_tys spec_info
- else
- emptyUDs
-
- (binds_here, final_uds) = dumpUDs rhs_uds new_binders []
- in
- case blookup of
- Lifted lift_binder unlift_binder
- -> -- We may need to record an unboxed instance of
- -- the _Lift data type in the usage details
- mkTyConInstance liftDataCon [getIdUniType unlift_binder]
- `thenSM` \ lift_uds ->
- returnSM ((lift_binder,
- mkCoLetsNoUnboxed binds_here (liftExpr unlift_binder rhs)),
- final_uds `unionUDs` pragma_uds `unionUDs` lift_uds)
-
- NoLift (CoVarAtom binder)
- -> returnSM ((binder, mkCoLetsNoUnboxed binds_here rhs),
- final_uds `unionUDs` pragma_uds)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{@instBind@}
-%* *
-%************************************************************************