projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
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
ba1a638
..
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,
module DsUtils (
EquationInfo(..),
firstPat, shiftEqns,
-
+
mkDsLet, mkDsLets,
MatchResult(..), CanItFail(..),
mkDsLet, mkDsLets,
MatchResult(..), CanItFail(..),
@@
-27,11
+27,11
@@
module DsUtils (
mkSelectorBinds, mkTupleExpr, mkTupleSelector,
mkTupleType, mkTupleCase, mkBigCoreTup,
mkSelectorBinds, mkTupleExpr, mkTupleSelector,
mkTupleType, mkTupleCase, mkBigCoreTup,
- mkCoreTup, mkCoreTupTy,
+ mkCoreTup, mkCoreTupTy, seqVar,
dsSyntaxTable, lookupEvidence,
dsSyntaxTable, lookupEvidence,
- selectSimpleMatchVarL, selectMatchVars
+ selectSimpleMatchVarL, selectMatchVars, selectMatchVar
) where
#include "HsVersions.h"
) where
#include "HsVersions.h"
@@
-70,11
+70,14
@@
import PrelNames ( unpackCStringName, unpackCStringUtf8Name,
lengthPName, indexPName )
import Outputable
import SrcLoc ( Located(..), unLoc )
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 ListSetOps ( assocDefault )
import FastString
-
import Data.Char ( ord )
import Data.Char ( ord )
+
+#ifdef DEBUG
+import Util ( notNull ) -- Used in an assertion
+#endif
\end{code}
\end{code}
@@
-166,6
+169,7
@@
selectMatchVars (p:ps) (ty:tys) = do { v <- selectMatchVar p ty
; vs <- selectMatchVars ps tys
; return (v:vs) }
; 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
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
| 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
mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
mkCoLetMatchResult bind match_result
= adjustMatchResult (mkDsLet bind) match_result
@@
-583,7
+591,7
@@
mkSelectorBinds pat val_expr
is_simple_lpat p = is_simple_pat (unLoc p)
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
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