X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsUtils.lhs;h=70944f81591b24ff0acf836754702afa72de9a03;hb=04feba252e40d16101b92948cd1e13c7bc1f3062;hp=10fd4abb55d30c05c7a560a8a89a68062a5c1697;hpb=d7c402a3cedbe49345a34f2e58a3f3050638dcb4;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 10fd4ab..70944f8 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -9,17 +9,17 @@ This module exports some utility functions of no great interest. 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,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} @@ -187,47 +191,21 @@ The ``equation info'' used by @match@ is relatively complicated and worthy of a type synonym and a few handy functions. \begin{code} -data EquationInfo - = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn - eqn_rhs :: MatchResult } -- What to do after match - --- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult --- \fail. wrap (case vs of { pats -> rhs fail }) --- where vs are not in the domain of wrap - 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 -\end{code} - - -\begin{code} --- A MatchResult is an expression with a hole in it -data MatchResult - = MatchResult - CanItFail -- Tells whether the failure expression is used - (CoreExpr -> DsM CoreExpr) - -- Takes a expression to plug in at the - -- failure point(s). The expression should - -- be duplicatable! - -data CanItFail = CanFail | CantFail - -orFail CantFail CantFail = CantFail -orFail _ _ = CanFail +-- 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) @@ -267,24 +245,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 @@ -317,7 +287,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 @@ -363,13 +333,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 @@ -445,6 +415,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} @@ -502,7 +473,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 @@ -511,17 +482,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} @@ -615,7 +586,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