X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsUtils.lhs;h=29e7773bb8c49bdc0838970314fd51999aa00ed4;hb=3c245de9199f522f75ace92219256badbd928bd6;hp=11aa01b8c81d0e23a45af71ff6cda4ab6d246275;hpb=853e20a3eb86137cdb8accf69c6caa9db83a3d34;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 11aa01b..29e7773 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -9,15 +9,15 @@ This module exports some utility functions of no great interest.
 module DsUtils (
 	EquationInfo(..), 
 	firstPat, shiftEqns,
-
+	
 	mkDsLet, mkDsLets,
 
 	MatchResult(..), CanItFail(..), 
 	cantFailMatchResult, alwaysFailMatchResult,
 	extractMatchResult, combineMatchResults, 
 	adjustMatchResult,  adjustMatchResultDs,
-	mkCoLetMatchResult,
-	mkGuardedMatchResult, 
+	mkCoLetMatchResult, mkGuardedMatchResult, 
+	matchCanFail,
 	mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
 	wrapBind, wrapBinds,
 
@@ -27,11 +27,11 @@ module DsUtils (
 
 	mkSelectorBinds, mkTupleExpr, mkTupleSelector, 
 	mkTupleType, mkTupleCase, mkBigCoreTup,
-	mkCoreTup, mkCoreTupTy,
+	mkCoreTup, mkCoreTupTy, seqVar,
 	
-	dsReboundNames, lookupReboundName,
+	dsSyntaxTable, lookupEvidence,
 
-	selectSimpleMatchVarL, selectMatchVars
+	selectSimpleMatchVarL, selectMatchVars, selectMatchVar
     ) where
 
 #include "HsVersions.h"
@@ -69,11 +69,15 @@ import PrelNames	( unpackCStringName, unpackCStringUtf8Name,
 			  plusIntegerName, timesIntegerName, smallIntegerDataConName, 
 			  lengthPName, indexPName )
 import Outputable
-import UnicodeUtil      ( intsToUtf8 )
 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}
 
 
@@ -85,11 +89,11 @@ import FastString
 %************************************************************************
 
 \begin{code}
-dsReboundNames :: ReboundNames Id 
+dsSyntaxTable :: SyntaxTable Id 
 	       -> DsM ([CoreBind], 	-- Auxiliary bindings
 		       [(Name,Id)])	-- Maps the standard name to its value
 
-dsReboundNames rebound_ids
+dsSyntaxTable rebound_ids
   = mapAndUnzipDs mk_bind rebound_ids	`thenDs` \ (binds_s, prs) ->
     return (concat binds_s, prs)
   where
@@ -101,11 +105,11 @@ dsReboundNames rebound_ids
      	   newSysLocalDs (exprType rhs)		`thenDs` \ id ->
      	   return ([NonRec id rhs], (std_name, id))
 
-lookupReboundName :: [(Name,Id)] -> Name -> CoreExpr
-lookupReboundName prs std_name
-  = Var (assocDefault (mk_panic std_name) prs std_name)
+lookupEvidence :: [(Name, Id)] -> Name -> Id
+lookupEvidence prs std_name
+  = assocDefault (mk_panic std_name) prs std_name
   where
-    mk_panic std_name = pprPanic "dsReboundNames" (ptext SLIT("Not found:") <+> ppr std_name)
+    mk_panic std_name = pprPanic "dsSyntaxTable" (ptext SLIT("Not found:") <+> ppr std_name)
 \end{code}
 
 
@@ -165,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
@@ -198,6 +203,10 @@ shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
 Functions on MatchResults
 
 \begin{code}
+matchCanFail :: MatchResult -> Bool
+matchCanFail (MatchResult CanFail _)  = True
+matchCanFail (MatchResult CantFail _) = False
+
 alwaysFailMatchResult :: MatchResult
 alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail)
 
@@ -247,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
@@ -407,6 +420,7 @@ mkErrorAppDs err_id ty msg
     let
 	full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
 	core_msg = Lit (mkStringLit full_msg)
+	-- mkStringLit returns a result of type String#
     in
     returnDs (mkApps (Var err_id) [Type ty, core_msg])
 \end{code}
@@ -464,7 +478,7 @@ mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mk
 mkStringExpr str = mkStringExprFS (mkFastString str)
 
 mkStringExprFS str
-  | nullFastString str
+  | nullFS str
   = returnDs (mkNilExpr charTy)
 
   | lengthFS str == 1
@@ -473,17 +487,17 @@ mkStringExprFS str
     in
     returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
 
-  | all safeChar int_chars
+  | all safeChar chars
   = dsLookupGlobalId unpackCStringName	`thenDs` \ unpack_id ->
     returnDs (App (Var unpack_id) (Lit (MachStr str)))
 
   | otherwise
   = dsLookupGlobalId unpackCStringUtf8Name	`thenDs` \ unpack_id ->
-    returnDs (App (Var unpack_id) (Lit (MachStr (mkFastString (intsToUtf8 int_chars)))))
+    returnDs (App (Var unpack_id) (Lit (MachStr str)))
 
   where
-    int_chars = unpackIntFS str
-    safeChar c = c >= 1 && c <= 0xFF
+    chars = unpackFS str
+    safeChar c = ord c >= 1 && ord c <= 0x7F
 \end{code}
 
 
@@ -577,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