X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsExpr.lhs;h=79303efa86ca3f5fe29bf643a9b5cf176175216f;hb=5d3051c66796dcf884b052f9e4afc3ed19b9f514;hp=2e215380017a1a51d5e0b4dcca59e852e4eb8534;hpb=a7ecdf96844404b7bc8273d4ff6d85759278427c;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 2e21538..79303ef 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -8,10 +8,9 @@ module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where #include "HsVersions.h" - import Match ( matchWrapper, matchSimply, matchSinglePat ) import MatchLit ( dsLit, dsOverLit ) -import DsBinds ( dsLHsBinds ) +import DsBinds ( dsLHsBinds, dsCoercion ) import DsGRHSs ( dsGuarded ) import DsListComp ( dsListComp, dsPArrComp ) import DsUtils ( mkErrorAppDs, mkStringExpr, mkConsExpr, mkNilExpr, @@ -26,7 +25,7 @@ import DsMeta ( dsBracket ) #endif import HsSyn -import TcHsSyn ( hsPatType ) +import TcHsSyn ( hsPatType, mkVanillaTuplePat ) -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types (newtypes etc), and sometimes not @@ -60,21 +59,10 @@ import FastString %************************************************************************ %* * -\subsection{dsLet} + dsLocalBinds, dsValBinds %* * %************************************************************************ -@dsLet@ is a match-result transformer, taking the @MatchResult@ for the body -and transforming it into one for the let-bindings enclosing the body. - -This may seem a bit odd, but (source) let bindings can contain unboxed -binds like -\begin{verbatim} - C x# = e -\end{verbatim} -This must be transformed to a case expression and, if the type has -more than one constructor, may fail. - \begin{code} dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr dsLocalBinds EmptyLocalBinds body = return body @@ -83,7 +71,7 @@ dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body ------------------------- dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr -dsValBinds (ValBindsOut binds) body = foldrDs ds_val_bind body binds +dsValBinds (ValBindsOut binds _) body = foldrDs ds_val_bind body binds ------------------------- dsIPBinds (IPBinds ip_binds dict_binds) body @@ -101,44 +89,48 @@ ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr -- 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 (is_rec, hsbinds) body +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] - = ASSERT (case is_rec of {NonRecursive -> True; other -> False}) - -- Unlifted bindings are always non-recursive - -- and are always a Fun or Pat monobind - -- - -- 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.) - let + || 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 - - mk_error_app pat = mkErrorAppDs iRREFUT_PAT_ERROR_ID - (exprType body) - (showSDoc (ppr pat)) in - case bagToList binds of - [L loc (FunBind (L _ fun) _ matches _)] - -> putSrcSpanDs loc $ - matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) -> + 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) - [L loc (PatBind pat grhss ty _)] + 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 +-- Ordinary case for bindings; none should be unlifted ds_val_bind (is_rec, binds) body - = dsLHsBinds binds `thenDs` \ prs -> - returnDs (Let (Rec prs) 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 @@ -257,14 +249,29 @@ dsExpr (HsCoreAnn fs expr) returnDs (Note (CoreNote $ unpackFS fs) core_expr) -- Special case to handle unboxed tuple patterns; they can't appear nested +-- The idea is that +-- case e of (# p1, p2 #) -> rhs +-- should desugar to +-- case e of (# x1, x2 #) -> ... match p1, p2 ... +-- NOT +-- let x = e in case x of .... +-- +-- But there may be a big +-- let fail = ... in case e of ... +-- wrapping the whole case, which complicates matters slightly +-- It all seems a bit fragile. Test is dsrun013. + dsExpr (HsCase discrim matches@(MatchGroup _ ty)) | isUnboxedTupleType (funArgTy ty) = dsLExpr discrim `thenDs` \ core_discrim -> matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) -> - case matching_code of - Case (Var x) bndr ty alts | x == discrim_var -> - returnDs (Case core_discrim bndr ty alts) - _ -> panic ("dsLExpr: tuple pattern:\n" ++ showSDoc (ppr matching_code)) + let + scrungle (Case (Var x) bndr ty alts) + | x == discrim_var = Case core_discrim bndr ty alts + scrungle (Let binds body) = Let binds (scrungle body) + scrungle other = panic ("dsLExpr: tuple pattern:\n" ++ showSDoc (ppr other)) + in + returnDs (scrungle matching_code) dsExpr (HsCase discrim matches) = dsLExpr discrim `thenDs` \ core_discrim -> @@ -484,7 +491,7 @@ dsExpr expr@(RecordUpd record_expr rbinds record_in_ty record_out_ty) mk_alt con = newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids -> - -- This call to dataConArgTys won't work for existentials + -- This call to dataConInstOrigArgTys won't work for existentials -- but existentials don't have record types anyway let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg @@ -548,6 +555,8 @@ dsExpr (DictLam dictvars expr) dsExpr (DictApp expr dicts) -- becomes a curried application = dsLExpr expr `thenDs` \ core_expr -> returnDs (foldl (\f d -> f `App` (Var d)) core_expr dicts) + +dsExpr (HsCoerce co_fn e) = dsCoercion co_fn (dsExpr e) \end{code} Here is where we desugar the Template Haskell brackets and escapes @@ -680,7 +689,7 @@ dsMDo tbl stmts body result_ty go (new_bind_stmt : let_stmt : stmts) where new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app - let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)])) + let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] [])) -- Remove the later_ids that appear (without fancy coercions) @@ -718,7 +727,7 @@ dsMDo tbl stmts body result_ty mk_tup_pat :: [LPat Id] -> LPat Id mk_tup_pat [p] = p - mk_tup_pat ps = noLoc $ TuplePat ps Boxed + mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id mk_ret_tup [r] = r