Fix desugaring of unboxed tuples

[ghc-hetmet.git] / ghc / compiler / deSugar / DsUtils.lhs

diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 1465554..29e7773 100644 (file)
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -9,7 +9,7 @@ This module exports some utility functions of no great interest.
 module DsUtils (
        EquationInfo(..), 
        firstPat, shiftEqns,
-
+       
        mkDsLet, mkDsLets,
 
        MatchResult(..), CanItFail(..), 
@@ -27,11 +27,11 @@ module DsUtils (
 
        mkSelectorBinds, mkTupleExpr, mkTupleSelector, 
        mkTupleType, mkTupleCase, mkBigCoreTup,
-       mkCoreTup, mkCoreTupTy,
+       mkCoreTup, mkCoreTupTy, seqVar,
        
        dsSyntaxTable, lookupEvidence,
 
-       selectSimpleMatchVarL, selectMatchVars
+       selectSimpleMatchVarL, selectMatchVars, selectMatchVar
     ) where
 
 #include "HsVersions.h"
@@ -70,11 +70,14 @@ import PrelNames    ( unpackCStringName, unpackCStringUtf8Name,
                          lengthPName, indexPName )
 import Outputable
 import SrcLoc          ( Located(..), unLoc )
-import Util             ( isSingleton, notNull, zipEqual, sortWith )
+import Util             ( isSingleton, zipEqual, sortWith )
 import ListSetOps      ( assocDefault )
 import FastString
-
 import Data.Char       ( ord )
+
+#ifdef DEBUG
+import Util            ( notNull )     -- Used in an assertion
+#endif
 \end{code}
 
 
@@ -166,6 +169,7 @@ selectMatchVars (p:ps) (ty:tys) = do { v  <- selectMatchVar  p  ty
                                     ; vs <- selectMatchVars ps tys
                                     ; return (v:vs) }
 
+selectMatchVar (BangPat pat)   pat_ty  = selectMatchVar (unLoc pat) pat_ty
 selectMatchVar (LazyPat pat)   pat_ty  = selectMatchVar (unLoc pat) pat_ty
 selectMatchVar (VarPat var)    pat_ty  = try_for var        pat_ty
 selectMatchVar (AsPat var pat) pat_ty  = try_for (unLoc var) pat_ty
@@ -252,6 +256,10 @@ wrapBind new old body
   | isTyVar new = App (Lam new body) (Type (mkTyVarTy old))
   | otherwise   = Let (NonRec new (Var old)) body
 
+seqVar :: Var -> CoreExpr -> CoreExpr
+seqVar var body = Case (Var var) var (exprType body)
+                       [(DEFAULT, [], body)]
+
 mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
 mkCoLetMatchResult bind match_result
   = adjustMatchResult (mkDsLet bind) match_result
@@ -489,7 +497,7 @@ mkStringExprFS str
 
   where
     chars = unpackFS str
-    safeChar c = ord c >= 1 && ord c <= 0xFF
+    safeChar c = ord c >= 1 && ord c <= 0x7F
 \end{code}
 
 
@@ -583,7 +591,7 @@ mkSelectorBinds pat val_expr
 
     is_simple_lpat p = is_simple_pat (unLoc p)
 
-    is_simple_pat (TuplePat ps Boxed)      = all is_triv_lpat ps
+    is_simple_pat (TuplePat ps Boxed _)    = all is_triv_lpat ps
     is_simple_pat (ConPatOut _ _ _ _ ps _) = all is_triv_lpat (hsConArgs ps)
     is_simple_pat (VarPat _)              = True
     is_simple_pat (ParPat p)              = is_simple_lpat p