+dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
+dsLocalBinds EmptyLocalBinds body = return body
+dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
+dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body
+
+-------------------------
+dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
+dsValBinds (ValBindsOut binds _) body = foldrDs ds_val_bind body binds
+
+-------------------------
+dsIPBinds (IPBinds ip_binds dict_binds) body
+ = do { prs <- dsLHsBinds dict_binds
+ ; let inner = foldr (\(x,r) e -> Let (NonRec x r) e) body prs
+ ; foldrDs ds_ip_bind inner ip_binds }
+ where
+ ds_ip_bind (L _ (IPBind n e)) body
+ = dsLExpr e `thenDs` \ e' ->
+ returnDs (Let (NonRec (ipNameName n) e') body)
+
+-------------------------
+ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
+-- Special case for bindings which bind unlifted variables
+-- We need to do a case right away, rather than building
+-- a tuple and doing selections.
+-- Silently ignore INLINE and SPECIALISE pragmas...
+ds_val_bind (NonRecursive, hsbinds) body
+ | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
+ (L loc bind : null_binds) <- bagToList binds,
+ or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
+ || isBangHsBind bind
+ = let
+ body_w_exports = foldr bind_export body exports
+ bind_export (tvs, g, l, _) body = ASSERT( null tvs )
+ bindNonRec g (Var l) body
+ in
+ ASSERT (null null_binds)
+ -- Non-recursive, non-overloaded bindings only come in ones
+ -- ToDo: in some bizarre case it's conceivable that there
+ -- could be dict binds in the 'binds'. (See the notes
+ -- below. Then pattern-match would fail. Urk.)
+ putSrcSpanDs loc $
+ case bind of
+ FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn }
+ -> matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) ->
+ ASSERT( null args ) -- Functions aren't lifted
+ ASSERT( isIdCoercion co_fn )
+ returnDs (bindNonRec fun rhs body_w_exports)
+
+ PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
+ -> putSrcSpanDs loc $
+ dsGuarded grhss ty `thenDs` \ rhs ->
+ mk_error_app pat `thenDs` \ error_expr ->
+ matchSimply rhs PatBindRhs pat body_w_exports error_expr
+
+ other -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
+ where
+ mk_error_app pat = mkErrorAppDs iRREFUT_PAT_ERROR_ID
+ (exprType body)
+ (showSDoc (ppr pat))
+
+-- Ordinary case for bindings; none should be unlifted
+ds_val_bind (is_rec, binds) body
+ = do { prs <- dsLHsBinds binds
+ ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
+ case prs of
+ [] -> return body
+ other -> return (Let (Rec prs) body) }
+ -- Use a Rec regardless of is_rec.
+ -- Why? Because it allows the binds to be all
+ -- mixed up, which is what happens in one rare case
+ -- Namely, for an AbsBind with no tyvars and no dicts,
+ -- but which does have dictionary bindings.
+ -- See notes with TcSimplify.inferLoop [NO TYVARS]
+ -- It turned out that wrapping a Rec here was the easiest solution
+ --
+ -- NB The previous case dealt with unlifted bindings, so we
+ -- only have to deal with lifted ones now; so Rec is ok
+\end{code}