- work_id wrapper_fn
- = case get_work_id wrapper_fn of
- [] -> case work_id_try2 wrapper_fn of
- [] -> pprPanic "getWorkerIdAndCons: can't find worker id" (ppr wrap_id)
- [id] -> id
- _ -> pprPanic "getWorkerIdAndCons: found too many worker ids" (ppr wrap_id)
- [id] -> id
- _ -> pprPanic "getWorkerIdAndCons: found too many worker ids" (ppr wrap_id)
-
- get_work_id (Lam _ body) = get_work_id body
- get_work_id (Case _ _ [(_,_,rhs@(Case _ _ _))]) = get_work_id rhs
- get_work_id (Case scrut _ [(_,_,rhs)]) = (get_work_id scrut) ++ (get_work_id rhs)
- get_work_id (Note _ body) = get_work_id body
- get_work_id (Let _ body) = get_work_id body
- get_work_id (App (Var work_id) _) = [work_id]
- get_work_id (App fn _) = get_work_id fn
- get_work_id (Var work_id) = []
- get_work_id other = []
-
- work_id_try2 (Lam _ body) = work_id_try2 body
- work_id_try2 (Note _ body) = work_id_try2 body
- work_id_try2 (Let _ body) = work_id_try2 body
- work_id_try2 (App fn _) = work_id_try2 fn
- work_id_try2 (Var work_id) = [work_id]
- work_id_try2 other = []
-
- get_cons (Lam _ body) = get_cons body
- get_cons (Let (NonRec _ rhs) body) = get_cons rhs `unionUniqSets` get_cons body
-
- get_cons (Case e _ [(DataCon dc,_,rhs)]) = (get_cons e `unionUniqSets` get_cons rhs)
- `addOneToUniqSet` dc
-
- -- Coercions don't mention the construtor now,
- -- but we must still put the constructor in the interface
- -- file so that the RHS of the newtype decl is imported
- get_cons (Note (Coerce to_ty from_ty) body)
- = get_cons body `addOneToUniqSet` con
- where
- con = case splitAlgTyConApp_maybe from_ty of
- Just (_, _, [con]) -> con
- other -> pprPanic "getWorkerIdAndCons" (ppr to_ty)
-
- get_cons other = emptyUniqSet
+%************************************************************************
+%* *
+\subsection{The worker wrapper core}
+%* *
+%************************************************************************
+
+@mkWrapper@ is called when importing a function. We have the type of
+the function and the name of its worker, and we want to make its body (the wrapper).
+
+\begin{code}
+mkWrapper :: Type -- Wrapper type
+ -> StrictSig -- Wrapper strictness info
+ -> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id
+
+mkWrapper fun_ty (StrictSig (DmdType _ demands res_info))
+ = mkWwBodies fun_ty demands res_info noOneShotInfo `thenUs` \ (_, wrap_fn, _) ->
+ returnUs wrap_fn
+
+noOneShotInfo = repeat False