X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsUtils.lhs;h=5472d7b8fd2d27736829b27649024f2bf44d210c;hb=ac10f8408520a30e8437496d320b8b86afda2e8f;hp=931bcc9029fe563ed7af92eb78649a547fe78a9c;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 931bcc9..5472d7b 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 @@ -52,9 +52,9 @@ import Var ( Var ) import Name ( Name ) import Literal ( Literal(..), mkStringLit, inIntRange, tARGET_MAX_INT ) import TyCon ( isNewTyCon, tyConDataCons ) -import DataCon ( DataCon, dataConSourceArity, dataConTyCon ) +import DataCon ( DataCon, dataConSourceArity, dataConTyCon, dataConTag ) import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp, mkTyVarTy ) -import TcType ( tcTyConAppTyCon, tcEqType ) +import TcType ( tcEqType ) import TysPrim ( intPrimTy ) import TysWiredIn ( nilDataCon, consDataCon, tupleCon, mkTupleTy, @@ -69,11 +69,15 @@ import PrelNames ( unpackCStringName, unpackCStringUtf8Name, plusIntegerName, timesIntegerName, smallIntegerDataConName, lengthPName, indexPName ) import Outputable -import UnicodeUtil ( intsToUtf8 ) -import SrcLoc ( Located(..), unLoc, noLoc ) -import Util ( isSingleton, notNull, zipEqual ) +import SrcLoc ( Located(..), unLoc ) +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 @@ -302,9 +272,10 @@ mkCoPrimCaseMatchResult var ty match_alts = MatchResult CanFail mk_case where mk_case fail - = mappM (mk_alt fail) match_alts `thenDs` \ alts -> + = mappM (mk_alt fail) sorted_alts `thenDs` \ alts -> returnDs (Case (Var var) var ty ((DEFAULT, [], fail) : alts)) + sorted_alts = sortWith fst match_alts -- Right order for a Case mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body -> returnDs (LitAlt lit, [], body) @@ -316,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 @@ -343,7 +314,9 @@ mkCoAlgCaseMatchResult var ty match_alts = CanFail wild_var = mkWildId (idType var) - mk_case fail = mappM (mk_alt fail) match_alts `thenDs` \ alts -> + sorted_alts = sortWith get_tag match_alts + get_tag (con, _, _) = dataConTag con + mk_case fail = mappM (mk_alt fail) sorted_alts `thenDs` \ alts -> returnDs (Case (Var var) wild_var ty (mk_default fail ++ alts)) mk_alt fail (con, args, MatchResult _ body_fn) @@ -360,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 @@ -401,8 +374,8 @@ mkCoAlgCaseMatchResult var ty match_alts -- unboxAlt = newSysLocalDs intPrimTy `thenDs` \l -> - dsLookupGlobalId indexPName `thenDs` \indexP -> - mappM (mkAlt indexP) match_alts `thenDs` \alts -> + dsLookupGlobalId indexPName `thenDs` \indexP -> + mappM (mkAlt indexP) sorted_alts `thenDs` \alts -> returnDs (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts))) where wild = mkWildId intPrimTy @@ -442,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} @@ -499,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 @@ -508,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} @@ -772,7 +746,6 @@ mkSmallTupleCase mkSmallTupleCase [var] body _scrut_var scrut = bindNonRec var scrut body mkSmallTupleCase vars body scrut_var scrut --- gaw 2004 -- One branch no refinement? = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon Boxed (length vars)), vars, body)] \end{code} @@ -824,7 +797,6 @@ mkCoreSel [var] should_be_the_same_var scrut_var scrut mkCoreSel vars the_var scrut_var scrut = ASSERT( notNull vars ) --- gaw 2004 Case scrut scrut_var (idType the_var) [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)] \end{code}