From: simonpj <unknown>
Date: Thu, 24 Nov 2005 09:46:01 +0000 (+0000)
Subject: [project @ 2005-11-24 09:46:01 by simonpj]
X-Git-Tag: Initial_conversion_from_CVS_complete~25
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=c76d8afbca85519fface96bd11009eccd959b93a;p=ghc-hetmet.git

[project @ 2005-11-24 09:46:01 by simonpj]
A patch to the already-somewhat-delicate machinery that deals with
pattern-matching on unboxed tuples.  This patch deals with pattern
matches that can fail, e.g.
	case f x of
	  (# Just x, Nothing #) -> ...

The fix is in desugaring of HsCase (DsExpr.lhs).

The test is dsrun013
---

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index ce5a9d8..04511ce 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -257,14 +257,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 ->