From: simonpj@microsoft.com Date: Thu, 9 Feb 2006 17:53:28 +0000 (+0000) Subject: Fix desugaring of unboxed tuples X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=3c245de9199f522f75ace92219256badbd928bd6 Fix desugaring of unboxed tuples This patch is a slightly-unsatisfactory fix to desugaring unboxed tuples; it fixes ds057 which has been failing for some time. Unsatisfactory because rather ad hoc -- but that applies to lots of the unboxed tuple stuff. --- diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 79303ef..406d793 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -8,14 +8,14 @@ module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where #include "HsVersions.h" -import Match ( matchWrapper, matchSimply, matchSinglePat ) +import Match ( matchWrapper, matchSinglePat, matchEquations ) import MatchLit ( dsLit, dsOverLit ) import DsBinds ( dsLHsBinds, dsCoercion ) import DsGRHSs ( dsGuarded ) import DsListComp ( dsListComp, dsPArrComp ) import DsUtils ( mkErrorAppDs, mkStringExpr, mkConsExpr, mkNilExpr, extractMatchResult, cantFailMatchResult, matchCanFail, - mkCoreTupTy, selectSimpleMatchVarL, lookupEvidence ) + mkCoreTupTy, selectSimpleMatchVarL, lookupEvidence, selectMatchVar ) import DsArrows ( dsProcExpr ) import DsMonad @@ -92,8 +92,9 @@ ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr 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 + isBangHsBind bind + || isUnboxedTupleBind bind + || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports] = let body_w_exports = foldr bind_export body exports bind_export (tvs, g, l, _) body = ASSERT( null tvs ) @@ -113,16 +114,19 @@ ds_val_bind (NonRecursive, hsbinds) body 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 + -> -- let C x# y# = rhs in body + -- ==> case rhs of C x# y# -> body + putSrcSpanDs loc $ + do { rhs <- dsGuarded grhss ty + ; let upat = unLoc pat + eqn = EqnInfo { eqn_wrap = idWrapper, eqn_pats = [upat], + eqn_rhs = cantFailMatchResult body_w_exports } + ; var <- selectMatchVar upat ty + ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) + ; return (scrungleMatch var rhs result) } 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 @@ -141,6 +145,35 @@ ds_val_bind (is_rec, binds) body -- -- NB The previous case dealt with unlifted bindings, so we -- only have to deal with lifted ones now; so Rec is ok + +isUnboxedTupleBind :: HsBind Id -> Bool +isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty +isUnboxedTupleBind other = False + +scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr +-- Returns something like (let var = scrut in body) +-- but if var is an unboxed-tuple type, it inlines it in a fragile way +-- 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. + +scrungleMatch var scrut body + | isUnboxedTupleType (idType var) = scrungle body + | otherwise = bindNonRec var scrut body + where + scrungle (Case (Var x) bndr ty alts) + | x == var = Case scrut bndr ty alts + scrungle (Let binds body) = Let binds (scrungle body) + scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other)) \end{code} %************************************************************************ @@ -248,35 +281,10 @@ dsExpr (HsCoreAnn fs expr) = dsLExpr expr `thenDs` \ core_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) -> - 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 -> matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) -> - returnDs (bindNonRec discrim_var core_discrim matching_code) + returnDs (scrungleMatch discrim_var core_discrim matching_code) dsExpr (HsLet binds body) = dsLExpr body `thenDs` \ body' -> diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 2c43a54..f24dee4 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -69,7 +69,7 @@ infixr 9 `thenDs` \begin{code} data DsMatchContext - = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan + = DsMatchContext (HsMatchContext Name) SrcSpan | NoMatchContext deriving () diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index b42bd7d..29e7773 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -31,7 +31,7 @@ module DsUtils ( dsSyntaxTable, lookupEvidence, - selectSimpleMatchVarL, selectMatchVars + selectSimpleMatchVarL, selectMatchVars, selectMatchVar ) where #include "HsVersions.h" diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index bbc37b3..d72d6ad 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -4,7 +4,7 @@ \section[Main_match]{The @match@ function} \begin{code} -module Match ( match, matchWrapper, matchSimply, matchSinglePat ) where +module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where #include "HsVersions.h" @@ -69,7 +69,7 @@ matchCheck_really dflags ctx vars ty qs where (pats, eqns_shadow) = check qs incomplete = want_incomplete && (notNull pats) want_incomplete = case ctx of - DsMatchContext RecUpd _ _ -> + DsMatchContext RecUpd _ -> dopt Opt_WarnIncompletePatternsRecUpd dflags _ -> dopt Opt_WarnIncompletePatterns dflags @@ -90,7 +90,7 @@ The next two functions create the warning message. \begin{code} dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM () -dsShadowWarn ctx@(DsMatchContext kind _ loc) qs +dsShadowWarn ctx@(DsMatchContext kind loc) qs = putSrcSpanDs loc (dsWarn warn) where warn | qs `lengthExceeds` maximum_output @@ -103,7 +103,7 @@ dsShadowWarn ctx@(DsMatchContext kind _ loc) qs dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM () -dsIncompleteWarn ctx@(DsMatchContext kind _ loc) pats +dsIncompleteWarn ctx@(DsMatchContext kind loc) pats = putSrcSpanDs loc (dsWarn warn) where warn = pp_context ctx (ptext SLIT("are non-exhaustive")) @@ -115,7 +115,7 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ loc) pats dots | pats `lengthExceeds` maximum_output = ptext SLIT("...") | otherwise = empty -pp_context (DsMatchContext kind pats _loc) msg rest_of_msg_fun +pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun = vcat [ptext SLIT("Pattern match(es)") <+> msg, sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]] where @@ -650,19 +650,11 @@ JJQC 30-Nov-1997 \begin{code} matchWrapper ctxt (MatchGroup matches match_ty) - = do { eqns_info <- mapM mk_eqn_info matches - ; dflags <- getDOptsDs - ; locn <- getSrcSpanDs - ; let ds_ctxt = DsMatchContext ctxt arg_pats locn - error_string = matchContextErrString ctxt - - ; new_vars <- selectMatchVars arg_pats pat_tys - ; match_result <- match_fun dflags ds_ctxt new_vars rhs_ty eqns_info - - ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string - ; result_expr <- extractMatchResult match_result fail_expr + = do { eqns_info <- mapM mk_eqn_info matches + ; new_vars <- selectMatchVars arg_pats pat_tys + ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty ; return (new_vars, result_expr) } - where + where arg_pats = map unLoc (hsLMatchPats (head matches)) n_pats = length arg_pats (pat_tys, rhs_ty) = splitFunTysN n_pats match_ty @@ -672,8 +664,23 @@ matchWrapper ctxt (MatchGroup matches match_ty) ; match_result <- dsGRHSs ctxt upats grhss rhs_ty ; return (EqnInfo { eqn_wrap = idWrapper, eqn_pats = upats, - eqn_rhs = match_result}) } + eqn_rhs = match_result}) } + +matchEquations :: HsMatchContext Name + -> [Id] -> [EquationInfo] -> Type + -> DsM CoreExpr +matchEquations ctxt vars eqns_info rhs_ty + = do { dflags <- getDOptsDs + ; locn <- getSrcSpanDs + ; let ds_ctxt = DsMatchContext ctxt locn + error_string = matchContextErrString ctxt + + ; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info + + ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string + ; extractMatchResult match_result fail_expr } + where match_fun dflags ds_ctxt = case ctxt of LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt @@ -719,7 +726,7 @@ matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx | otherwise = match where - ds_ctx = DsMatchContext hs_ctx [pat] locn + ds_ctx = DsMatchContext hs_ctx locn in match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper, eqn_pats = [pat], diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index c938a76..c2355a0 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -72,7 +72,7 @@ mkVanillaTuplePat pats box = TuplePat pats box (mkTupleTy box (length pats) (map hsPatType pats)) hsPatType :: OutPat Id -> Type -hsPatType pat = pat_type (unLoc pat) +hsPatType (L _ pat) = pat_type pat pat_type (ParPat pat) = hsPatType pat pat_type (WildPat ty) = ty