Commit 3c245de9 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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. 
parent febd6d9a
......@@ -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' ->
......
......@@ -69,7 +69,7 @@ infixr 9 `thenDs`
\begin{code}
data DsMatchContext
= DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan
= DsMatchContext (HsMatchContext Name) SrcSpan
| NoMatchContext
deriving ()
......
......@@ -31,7 +31,7 @@ module DsUtils (
dsSyntaxTable, lookupEvidence,
selectSimpleMatchVarL, selectMatchVars
selectSimpleMatchVarL, selectMatchVars, selectMatchVar
) where
#include "HsVersions.h"
......
......@@ -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],
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment