- -- Dump any dictionary bindings (and call instances)
- -- from the scope which mention things bound here
- (binds_here, final_uds) = dumpUDs body_uds False False [] new_ids []
- in
- returnSM (new_ids, mkCoLetsNoUnboxed binds_here body, final_uds)
- )
-
--- ToDo: Opportunity here to common-up dictionaries with same type,
--- thus avoiding recomputation.
-\end{code}
-
-A variable bound in a lambda or case is normally monomorphic so no
-specialised versions will be required. This is just as well since we
-do not know what code to specialise!
-
-Unfortunately this is not always the case. For example a class Foo
-with polymorphic methods gives rise to a dictionary with polymorphic
-components as follows:
-
-\begin{verbatim}
-class Foo a where
- op1 :: a -> b -> a
- op2 :: a -> c -> a
-
-instance Foo Int where
- op1 = op1Int
- op2 = op2Int
-
-... op1 1 3# ...
-
-==>
-
-d.Foo.Int :: ( \/b . Int -> b -> Int, \/c . Int -> c -> Int )
-d.Foo.Int = (op1_Int, op2_Int)
-
-op1 = /\ a b -> \ dFoo -> case dFoo of (meth1, _) -> meth1 b
-
-... op1 {Int Int#} d.Foo.Int 1 3# ...
-\end{verbatim}
-
-N.B. The type of the dictionary is not Hindley Milner!
-
-Now we must specialise op1 at {* Int#} which requires a version of
-meth1 at {Int#}. But since meth1 was extracted from a dictionary we do
-not have access to its code to create the specialised version.
-
-If we specialise on overloaded types as well we specialise op1 at
-{Int Int#} d.Foo.Int:
-
-op1_Int_Int# = case d.Foo.Int of (meth1, _) -> meth1 {Int#}
-
-Though this is still invalid, after further simplification we get:
-
-op1_Int_Int# = opInt1 {Int#}
-
-Another round of specialisation will result in the specialised
-version of op1Int being called directly.
-
-For now we PANIC if a polymorphic lambda/case bound variable is found
-in a call instance with an unboxed type. Other call instances, arising
-from overloaded type arguments, are discarded since the unspecialised
-version extracted from the method can be called as normal.
-
-ToDo: Implement and test second round of specialisation.
-
-
-%************************************************************************
-%* *
-\subsubsection{Specialising case alternatives}
-%* *
-%************************************************************************
-
-
-\begin{code}
-specAlts (AlgAlts alts deflt) scrutinee_ty args
- = mapSM specTy ty_args `thenSM` \ ty_args ->
- mapAndUnzipSM (specAlgAlt ty_args) alts `thenSM` \ (alts, alts_uds_s) ->
- specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
- returnSM (AlgAlts alts deflt,
- unionUDList alts_uds_s `unionUDs` deflt_uds)
- where
- -- We use ty_args of scrutinee type to identify specialisation of
- -- alternatives:
-
- (_, ty_args, _) = getAppDataTyCon scrutinee_ty
-
- specAlgAlt ty_args (con,binders,rhs)
- = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) ->
- mkTyConInstance con ty_args `thenSM` \ con_uds ->
- returnSM ((con,binders,rhs), rhs_uds `unionUDs` con_uds)
-
-specAlts (PrimAlts alts deflt) scrutinee_ty args
- = mapAndUnzipSM specPrimAlt alts `thenSM` \ (alts, alts_uds_s) ->
- specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
- returnSM (PrimAlts alts deflt,
- unionUDList alts_uds_s `unionUDs` deflt_uds)
- where
- specPrimAlt (lit,rhs) = specExpr rhs args `thenSM` \ (rhs, uds) ->
- returnSM ((lit,rhs), uds)
-
-
-specDeflt NoDefault args = returnSM (NoDefault, emptyUDs)
-specDeflt (BindDefault binder rhs) args
- = specLambdaOrCaseBody [binder] rhs args `thenSM` \ ([binder], rhs, uds) ->
- returnSM (BindDefault binder rhs, uds)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection{Specialising an atom}
-%* *
-%************************************************************************
-
-\begin{code}
-partition_args :: [CoreArg] -> ([CoreArg], [CoreArg])
-partition_args args
- = span is_ty_arg args
- where
- is_ty_arg (TyArg _) = True
- is_ty_arg _ = False
-
-----------
-preSpecArg :: CoreArg -> SpecM CoreArg -- diddle TyArgs, but nothing else
-
-preSpecArg (TyArg ty)
- = specTy ty `thenSM` \ new_ty ->
- returnSM (TyArg new_ty)
-
-preSpecArg other = returnSM other
-
---------------------
-specValArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
- CoreExpr -> CoreExpr)
-
-specValArg (LitArg lit)
- = returnSM (LitArg lit, emptyUDs, id)
-
-specValArg (VarArg v)
- = lookupId v `thenSM` \ vlookup ->
- case vlookup of
- Lifted vl vu
- -> returnSM (VarArg vu, singleFvUDs (VarArg vl), bindUnlift vl vu)
-
- NoLift vatom
- -> returnSM (vatom, singleFvUDs vatom, id)
-
-
-------------------
-specTyArg (TyArg ty)
- = specTy ty `thenSM` \ new_ty ->
- returnSM (TyArg new_ty, new_ty)
-
---------------
-specOutArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
- CoreExpr -> CoreExpr)
-
-specOutArg (TyArg ty) -- already speced; no action
- = returnSM (TyArg ty, emptyUDs, id)
-
-specOutArg other_arg -- unprocessed; spec the atom
- = specValArg other_arg
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection{Specialising bindings}
-%* *
-%************************************************************************
-
-A classic case of when having a polymorphic recursive function would help!
-
-\begin{code}
-data BindsOrExpr = ItsABinds [CoreBinding]
- | ItsAnExpr CoreExpr
-\end{code}
-
-\begin{code}
-specBindAndScope
- :: Bool -- True <=> a top level group
- -> CoreBinding -- As yet unprocessed
- -> SpecM (BindsOrExpr, UsageDetails) -- Something to do the scope of the bindings
- -> SpecM ([CoreBinding], -- Processed
- BindsOrExpr, -- Combined result
- UsageDetails) -- Usage details of the whole lot
-
-specBindAndScope top_lev bind scopeM
- = cloneLetBinders top_lev (is_rec bind) binders
- `thenSM` \ (new_binders, clone_infos) ->
-
- -- Two cases now: either this is a bunch of local dictionaries,
- -- in which case we float them; or its a bunch of other values,
- -- in which case we see if they correspond to any call-instances
- -- we have from processing the scope
-
- if not top_lev && all (isDictTy . idType) binders
- then
- -- Ha! A group of local dictionary bindings
-
- bindIds binders clone_infos (
-
- -- Process the dictionary bindings themselves
- specBind False True new_binders [] bind `thenSM` \ (bind, rhs_uds) ->
-
- -- Process their scope
- scopeM `thenSM` \ (thing, scope_uds) ->