Fix desugaring of unboxed tuples
authorsimonpj@microsoft.com <unknown>
Thu, 9 Feb 2006 17:53:28 +0000 (17:53 +0000)
committersimonpj@microsoft.com <unknown>
Thu, 9 Feb 2006 17:53:28 +0000 (17:53 +0000)
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.

ghc/compiler/deSugar/DsExpr.lhs
ghc/compiler/deSugar/DsMonad.lhs
ghc/compiler/deSugar/DsUtils.lhs
ghc/compiler/deSugar/Match.lhs
ghc/compiler/typecheck/TcHsSyn.lhs

index 79303ef..406d793 100644 (file)
@@ -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' ->
index 2c43a54..f24dee4 100644 (file)
@@ -69,7 +69,7 @@ infixr 9 `thenDs`
 
 \begin{code}
 data DsMatchContext
-  = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan
+  = DsMatchContext (HsMatchContext Name) SrcSpan
   | NoMatchContext
   deriving ()
 
index b42bd7d..29e7773 100644 (file)
@@ -31,7 +31,7 @@ module DsUtils (
        
        dsSyntaxTable, lookupEvidence,
 
-       selectSimpleMatchVarL, selectMatchVars
+       selectSimpleMatchVarL, selectMatchVars, selectMatchVar
     ) where
 
 #include "HsVersions.h"
index bbc37b3..d72d6ad 100644 (file)
@@ -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],
index c938a76..c2355a0 100644 (file)
@@ -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