X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsUtils.lhs;h=1465554175fb7fc967410a49a80e7af88307e12d;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=4105c881252d3c4e1bef93976e54dcf3779db1e3;hpb=508a505e9853984bfdaa3ad855ae3fcbc6d31787;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 4105c88..1465554 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -10,16 +10,16 @@ module DsUtils ( EquationInfo(..), firstPat, shiftEqns, - mkDsLet, + mkDsLet, mkDsLets, MatchResult(..), CanItFail(..), cantFailMatchResult, alwaysFailMatchResult, extractMatchResult, combineMatchResults, adjustMatchResult, adjustMatchResultDs, - mkCoLetsMatchResult, mkCoLetMatchResult, - mkGuardedMatchResult, + mkCoLetMatchResult, mkGuardedMatchResult, + matchCanFail, mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, - bindInMatchResult, bindOneInMatchResult, + wrapBind, wrapBinds, mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr, mkIntExpr, mkCharExpr, @@ -29,7 +29,7 @@ module DsUtils ( mkTupleType, mkTupleCase, mkBigCoreTup, mkCoreTup, mkCoreTupTy, - dsReboundNames, lookupReboundName, + dsSyntaxTable, lookupEvidence, selectSimpleMatchVarL, selectMatchVars ) where @@ -69,11 +69,12 @@ 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 ListSetOps ( assocDefault ) import FastString + +import Data.Char ( ord ) \end{code} @@ -85,11 +86,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 +102,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} @@ -191,18 +192,17 @@ firstPat :: EquationInfo -> Pat Id firstPat eqn = head (eqn_pats eqn) shiftEqns :: [EquationInfo] -> [EquationInfo] --- Drop the outermost layer of the first pattern in each equation -shiftEqns eqns = [ eqn { eqn_pats = shiftPats (eqn_pats eqn) } - | eqn <- eqns ] - -shiftPats :: [Pat Id] -> [Pat Id] -shiftPats (ConPatOut _ _ _ _ (PrefixCon arg_pats) _ : pats) = map unLoc arg_pats ++ pats -shiftPats (pat_with_no_sub_pats : pats) = pats +-- Drop the first pattern in each equation +shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ] \end{code} Functions on MatchResults \begin{code} +matchCanFail :: MatchResult -> Bool +matchCanFail (MatchResult CanFail _) = True +matchCanFail (MatchResult CantFail _) = False + alwaysFailMatchResult :: MatchResult alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail) @@ -242,24 +242,16 @@ adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn) = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body -> encl_fn body) -bindInMatchResult :: [(Var,Var)] -> MatchResult -> MatchResult -bindInMatchResult binds = adjustMatchResult (\e -> foldr bind e binds) - where - bind (new,old) body = bindMR new old body +wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr +wrapBinds [] e = e +wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e) -bindOneInMatchResult :: Var -> Var -> MatchResult -> MatchResult -bindOneInMatchResult new old = adjustMatchResult (bindMR new old) - -bindMR :: Var -> Var -> CoreExpr -> CoreExpr -bindMR new old body +wrapBind :: Var -> Var -> CoreExpr -> CoreExpr +wrapBind new old body | new==old = body | isTyVar new = App (Lam new body) (Type (mkTyVarTy old)) | otherwise = Let (NonRec new (Var old)) body -mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult -mkCoLetsMatchResult binds match_result - = adjustMatchResult (mkDsLets binds) match_result - mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult mkCoLetMatchResult bind match_result = adjustMatchResult (mkDsLet bind) match_result @@ -292,7 +284,7 @@ mkCoAlgCaseMatchResult :: Id -- Scrutinee mkCoAlgCaseMatchResult var ty match_alts | isNewTyCon tycon -- Newtype case; use a let = ASSERT( null (tail match_alts) && null (tail arg_ids1) ) - mkCoLetsMatchResult [NonRec arg_id1 newtype_rhs] match_result1 + mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1 | isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case = MatchResult CanFail mk_parrCase @@ -338,13 +330,13 @@ mkCoAlgCaseMatchResult var ty match_alts -- Stuff for parallel arrays -- - -- * the following is to desugar cases over fake constructors for + -- * the following is to desugar cases over fake constructors for -- parallel arrays, which are introduced by `tidy1' in the `PArrPat' -- case -- -- Concerning `isPArrFakeAlts': -- - -- * it is *not* sufficient to just check the type of the type + -- * it is *not* sufficient to just check the type of the type -- constructor, as we have to be careful not to confuse the real -- representation of parallel arrays with the fake constructors; -- moreover, a list of alternatives must not mix fake and real @@ -420,6 +412,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} @@ -477,7 +470,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 @@ -486,17 +479,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 <= 0xFF \end{code}