X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsUtils.lhs;h=008cebf6bf33c46077ecc97c7dac315a46654773;hb=a3837710367a206fa63fe82ae0d269f424fd2dcf;hp=9ecbae905b2bf6eec03d5601a65ef77cf0b4482d;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 9ecbae9..008cebf 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -10,13 +10,18 @@ module DsUtils ( CanItFail(..), EquationInfo(..), MatchResult(..), EqnNo, EqnSet, + tidyLitPat, tidyNPat, + + mkDsLet, mkDsLets, + cantFailMatchResult, extractMatchResult, combineMatchResults, adjustMatchResult, adjustMatchResultDs, mkCoLetsMatchResult, mkGuardedMatchResult, mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, - mkErrorAppDs, + mkErrorAppDs, mkNilExpr, mkConsExpr, + mkStringLit, mkStringLitFS, mkIntegerLit, mkSelectorBinds, mkTupleExpr, mkTupleSelector, @@ -27,31 +32,103 @@ module DsUtils ( import {-# SOURCE #-} Match ( matchSimply ) -import HsSyn ( OutPat(..) ) -import TcHsSyn ( TypecheckedPat ) -import DsHsSyn ( outPatType, collectTypedPatBinders ) +import HsSyn +import TcHsSyn ( TypecheckedPat, outPatType, collectTypedPatBinders ) import CoreSyn import DsMonad -import CoreUtils ( coreExprType ) -import PrelVals ( iRREFUT_PAT_ERROR_ID ) +import CoreUtils ( exprType, mkIfThenElse ) +import PrelInfo ( iRREFUT_PAT_ERROR_ID ) +import MkId ( rebuildConArgs ) import Id ( idType, Id, mkWildId ) -import Const ( Literal(..), Con(..) ) -import TyCon ( isNewTyCon, tyConDataCons ) -import DataCon ( DataCon ) -import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, - Type +import Literal ( Literal(..), inIntRange, tARGET_MAX_INT ) +import TyCon ( isNewTyCon, tyConDataCons, isRecursiveTyCon ) +import DataCon ( DataCon, dataConStrictMarks, dataConId ) +import Type ( mkFunTy, isUnLiftedType, Type ) +import TcType ( tcTyConAppTyCon, isIntTy, isFloatTy, isDoubleTy ) +import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy ) +import TysWiredIn ( nilDataCon, consDataCon, + tupleCon, + unitDataConId, unitTy, + charTy, charDataCon, + intDataCon, smallIntegerDataCon, + floatDataCon, + doubleDataCon, + stringTy ) -import TysWiredIn ( unitDataCon, tupleCon, stringTy, unitTy, unitDataCon ) +import BasicTypes ( Boxity(..) ) import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet ) +import PrelNames ( unpackCStringName, unpackCStringUtf8Name, + plusIntegerName, timesIntegerName ) import Outputable +import UnicodeUtil ( stringToUtf8 ) +\end{code} + + + +%************************************************************************ +%* * +\subsection{Tidying lit pats} +%* * +%************************************************************************ + +\begin{code} +tidyLitPat :: HsLit -> TypecheckedPat -> TypecheckedPat +tidyLitPat (HsChar c) pat = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy] +tidyLitPat lit pat = pat + +tidyNPat :: HsLit -> Type -> TypecheckedPat -> TypecheckedPat +tidyNPat (HsString s) _ pat + | _LENGTH_ s <= 1 -- Short string literals only + = foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat]) + (ConPat nilDataCon stringTy [] [] []) (_UNPK_INT_ s) + -- The stringTy is the type of the whole pattern, not + -- the type to instantiate (:) or [] with! + where + mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy] + +tidyNPat lit lit_ty default_pat + | isIntTy lit_ty = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy] + | isFloatTy lit_ty = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy] + | isDoubleTy lit_ty = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy] + | otherwise = default_pat + + where + mk_int (HsInteger i) = HsIntPrim i + + mk_float (HsInteger i) = HsFloatPrim (fromInteger i) + mk_float (HsRat f _) = HsFloatPrim f + + mk_double (HsInteger i) = HsDoublePrim (fromInteger i) + mk_double (HsRat f _) = HsDoublePrim f \end{code} %************************************************************************ %* * -%* Selecting match variables +\subsection{Building lets} +%* * +%************************************************************************ + +Use case, not let for unlifted types. The simplifier will turn some +back again. + +\begin{code} +mkDsLet :: CoreBind -> CoreExpr -> CoreExpr +mkDsLet (NonRec bndr rhs) body + | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)] +mkDsLet bind body + = Let bind body + +mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr +mkDsLets binds body = foldr mkDsLet body binds +\end{code} + + +%************************************************************************ +%* * +\subsection{ Selecting match variables} %* * %************************************************************************ @@ -62,10 +139,10 @@ otherwise, make one up. \begin{code} selectMatchVar :: TypecheckedPat -> DsM Id -selectMatchVar (VarPat var) = returnDs var -selectMatchVar (AsPat var pat) = returnDs var -selectMatchVar (LazyPat pat) = selectMatchVar pat -selectMatchVar other_pat = newSysLocalDs (outPatType other_pat) -- OK, better make up one... +selectMatchVar (VarPat var) = returnDs var +selectMatchVar (AsPat var pat) = returnDs var +selectMatchVar (LazyPat pat) = selectMatchVar pat +selectMatchVar other_pat = newSysLocalDs (outPatType other_pat) -- OK, better make up one... \end{code} @@ -126,7 +203,7 @@ extractMatchResult (MatchResult CantFail match_fn) fail_expr extractMatchResult (MatchResult CanFail match_fn) fail_expr = mkFailurePair fail_expr `thenDs` \ (fail_bind, if_it_fails) -> match_fn if_it_fails `thenDs` \ body -> - returnDs (Let fail_bind body) + returnDs (mkDsLet fail_bind body) combineMatchResults :: MatchResult -> MatchResult -> MatchResult @@ -156,7 +233,7 @@ adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn) mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult mkCoLetsMatchResult binds match_result - = adjustMatchResult (mkLets binds) match_result + = adjustMatchResult (mkDsLets binds) match_result mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult @@ -172,10 +249,10 @@ mkCoPrimCaseMatchResult var match_alts where mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts -> - returnDs (Case (Var var) var (alts ++ [(DEFAULT, [], fail)])) + returnDs (Case (Var var) var ((DEFAULT, [], fail) : alts)) mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body -> - returnDs (Literal lit, [], body) + returnDs (LitAlt lit, [], body) mkCoAlgCaseMatchResult :: Id -- Scrutinee @@ -184,22 +261,25 @@ mkCoAlgCaseMatchResult :: Id -- Scrutinee mkCoAlgCaseMatchResult var match_alts | isNewTyCon tycon -- Newtype case; use a let - = ASSERT( newtype_sanity ) - mkCoLetsMatchResult [coercion_bind] match_result + = ASSERT( null (tail match_alts) && null (tail arg_ids) ) + mkCoLetsMatchResult [NonRec arg_id newtype_rhs] match_result | otherwise -- Datatype case; use a case = MatchResult fail_flag mk_case where -- Common stuff scrut_ty = idType var - (tycon, tycon_arg_tys, _) = splitAlgTyConApp scrut_ty + tycon = tcTyConAppTyCon scrut_ty -- Newtypes must be opaque here -- Stuff for newtype - (con_id, arg_ids, match_result) = head match_alts - arg_id = head arg_ids - coercion_bind = NonRec arg_id (Note (Coerce (idType arg_id) scrut_ty) (Var var)) - newtype_sanity = null (tail match_alts) && null (tail arg_ids) - + (_, arg_ids, match_result) = head match_alts + arg_id = head arg_ids + + newtype_rhs | isRecursiveTyCon tycon -- Recursive case; need a case + = Note (Coerce (idType arg_id) scrut_ty) (Var var) + | otherwise -- Normal case (newtype is transparent) + = Var var + -- Stuff for data types data_cons = tyConDataCons tycon @@ -212,11 +292,15 @@ mkCoAlgCaseMatchResult var match_alts wild_var = mkWildId (idType var) mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts -> - returnDs (Case (Var var) wild_var (alts ++ mk_default fail)) + returnDs (Case (Var var) wild_var (mk_default fail ++ alts)) mk_alt fail (con, args, MatchResult _ body_fn) - = body_fn fail `thenDs` \ body -> - returnDs (DataCon con, args, body) + = body_fn fail `thenDs` \ body -> + getUniquesDs `thenDs` \ us -> + let + (binds, real_args) = rebuildConArgs args (dataConStrictMarks con) us + in + returnDs (DataAlt con, real_args, mkDsLets binds body) mk_default fail | exhaustive_case = [] | otherwise = [(DEFAULT, [], fail)] @@ -224,10 +308,9 @@ mkCoAlgCaseMatchResult var match_alts un_mentioned_constructors = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts] exhaustive_case = isEmptyUniqSet un_mentioned_constructors - - \end{code} + %************************************************************************ %* * \subsection{Desugarer's versions of some Core functions} @@ -245,9 +328,77 @@ mkErrorAppDs err_id ty msg let full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg]) in - returnDs (mkApps (Var err_id) [Type ty, mkStringLit full_msg]) + mkStringLit full_msg `thenDs` \ core_msg -> + returnDs (mkApps (Var err_id) [Type ty, core_msg]) +\end{code} + + +************************************************************* +%* * +\subsection{Making literals} +%* * +%************************************************************************ + +\begin{code} +mkIntegerLit :: Integer -> DsM CoreExpr +mkIntegerLit i + | inIntRange i -- Small enough, so start from an Int + = returnDs (mkSmallIntegerLit i) + +-- Special case for integral literals with a large magnitude: +-- They are transformed into an expression involving only smaller +-- integral literals. This improves constant folding. + + | otherwise -- Big, so start from a string + = dsLookupGlobalValue plusIntegerName `thenDs` \ plus_id -> + dsLookupGlobalValue timesIntegerName `thenDs` \ times_id -> + let + plus a b = Var plus_id `App` a `App` b + times a b = Var times_id `App` a `App` b + + -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b + horner :: Integer -> Integer -> CoreExpr + horner b i | abs q <= 1 = if r == 0 || r == i + then mkSmallIntegerLit i + else mkSmallIntegerLit r `plus` mkSmallIntegerLit (i-r) + | r == 0 = horner b q `times` mkSmallIntegerLit b + | otherwise = mkSmallIntegerLit r `plus` (horner b q `times` mkSmallIntegerLit b) + where + (q,r) = i `quotRem` b + + in + returnDs (horner tARGET_MAX_INT i) + +mkSmallIntegerLit i = mkConApp smallIntegerDataCon [mkIntLit i] + +mkStringLit :: String -> DsM CoreExpr +mkStringLit str = mkStringLitFS (_PK_ str) + +mkStringLitFS :: FAST_STRING -> DsM CoreExpr +mkStringLitFS str + | _NULL_ str + = returnDs (mkNilExpr charTy) + + | _LENGTH_ str == 1 + = let + the_char = mkConApp charDataCon [mkLit (MachChar (_HEAD_INT_ str))] + in + returnDs (mkConsExpr charTy the_char (mkNilExpr charTy)) + + | all safeChar chars + = dsLookupGlobalValue unpackCStringName `thenDs` \ unpack_id -> + returnDs (App (Var unpack_id) (Lit (MachStr str))) + + | otherwise + = dsLookupGlobalValue unpackCStringUtf8Name `thenDs` \ unpack_id -> + returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (stringToUtf8 chars))))) + + where + chars = _UNPK_INT_ str + safeChar c = c >= 1 && c <= 0xFF \end{code} + %************************************************************************ %* * \subsection[mkSelectorBind]{Make a selector bind} @@ -256,10 +407,10 @@ mkErrorAppDs err_id ty msg This is used in various places to do with lazy patterns. For each binder $b$ in the pattern, we create a binding: - +\begin{verbatim} b = case v of pat' -> b' - -where pat' is pat with each binder b cloned into b'. +\end{verbatim} +where @pat'@ is @pat@ with each binder @b@ cloned into @b'@. ToDo: making these bindings should really depend on whether there's much work to be done per binding. If the pattern is complex, it @@ -280,7 +431,7 @@ mkSelectorBinds (VarPat v) val_expr mkSelectorBinds pat val_expr | length binders == 1 || is_simple_pat pat - = newSysLocalDs (coreExprType val_expr) `thenDs` \ val_var -> + = newSysLocalDs (exprType val_expr) `thenDs` \ val_var -> -- For the error message we don't use mkErrorAppDs to avoid -- duplicating the string literal each time @@ -289,37 +440,42 @@ mkSelectorBinds pat val_expr let full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat]) in + mkStringLit full_msg `thenDs` \ core_msg -> mapDs (mk_bind val_var msg_var) binders `thenDs` \ binds -> returnDs ( (val_var, val_expr) : - (msg_var, mkStringLit full_msg) : + (msg_var, core_msg) : binds ) | otherwise - = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat)) `thenDs` \ error_expr -> - matchSimply val_expr LetMatch pat local_tuple error_expr `thenDs` \ tuple_expr -> - newSysLocalDs tuple_ty `thenDs` \ tuple_var -> + = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat)) + `thenDs` \ error_expr -> + matchSimply val_expr PatBindRhs pat local_tuple error_expr + `thenDs` \ tuple_expr -> + newSysLocalDs tuple_ty + `thenDs` \ tuple_var -> let - mk_tup_bind binder = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var)) + mk_tup_bind binder = + (binder, mkTupleSelector binders binder tuple_var (Var tuple_var)) in returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders ) where binders = collectTypedPatBinders pat local_tuple = mkTupleExpr binders - tuple_ty = coreExprType local_tuple + tuple_ty = exprType local_tuple mk_bind scrut_var msg_var bndr_var -- (mk_bind sv bv) generates -- bv = case sv of { pat -> bv; other -> error-msg } -- Remember, pat binds bv - = matchSimply (Var scrut_var) LetMatch pat + = matchSimply (Var scrut_var) PatBindRhs pat (Var bndr_var) error_expr `thenDs` \ rhs_expr -> returnDs (bndr_var, rhs_expr) where binder_ty = idType bndr_var error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var] - is_simple_pat (TuplePat ps True{-boxed-}) = all is_triv_pat ps + is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps is_simple_pat (VarPat _) = True is_simple_pat (RecPat _ _ _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps] @@ -337,9 +493,9 @@ has only one element, it is the identity function. \begin{code} mkTupleExpr :: [Id] -> CoreExpr -mkTupleExpr [] = mkConApp unitDataCon [] +mkTupleExpr [] = Var unitDataConId mkTupleExpr [id] = Var id -mkTupleExpr ids = mkConApp (tupleCon (length ids)) +mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids)) (map (Type . idType) ids ++ [ Var i | i <- ids ]) \end{code} @@ -354,10 +510,10 @@ If there is just one id in the ``tuple'', then the selector is just the identity. \begin{code} -mkTupleSelector :: [Id] -- The tuple args - -> Id -- The selected one - -> Id -- A variable of the same type as the scrutinee - -> CoreExpr -- Scrutinee +mkTupleSelector :: [Id] -- The tuple args + -> Id -- The selected one + -> Id -- A variable of the same type as the scrutinee + -> CoreExpr -- Scrutinee -> CoreExpr mkTupleSelector [var] should_be_the_same_var scrut_var scrut @@ -366,7 +522,25 @@ mkTupleSelector [var] should_be_the_same_var scrut_var scrut mkTupleSelector vars the_var scrut_var scrut = ASSERT( not (null vars) ) - Case scrut scrut_var [(DataCon (tupleCon (length vars)), vars, Var the_var)] + Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)] +\end{code} + + +%************************************************************************ +%* * +\subsection[mkFailurePair]{Code for pattern-matching and other failures} +%* * +%************************************************************************ + +Call the constructor Ids when building explicit lists, so that they +interact well with rules. + +\begin{code} +mkNilExpr :: Type -> CoreExpr +mkNilExpr ty = App (Var (dataConId nilDataCon)) (Type ty) + +mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr +mkConsExpr ty hd tl = mkApps (Var (dataConId consDataCon)) [Type ty, hd, tl] \end{code} @@ -390,7 +564,7 @@ fail-variable, and use that variable if the thing fails: Then \begin{itemize} \item -If the case can't fail, then there'll be no mention of fail.33, and the +If the case can't fail, then there'll be no mention of @fail.33@, and the simplifier will later discard it. \item @@ -401,7 +575,7 @@ Only if it is used more than once will the let-binding remain. \end{itemize} There's a problem when the result of the case expression is of -unboxed type. Then the type of fail.33 is unboxed too, and +unboxed type. Then the type of @fail.33@ is unboxed too, and there is every chance that someone will change the let into a case: \begin{verbatim} case error "Help" of @@ -422,7 +596,7 @@ for the primitive case: p4 -> ... \end{verbatim} -Now fail.33 is a function, so it can be let-bound. +Now @fail.33@ is a function, so it can be let-bound. \begin{code} mkFailurePair :: CoreExpr -- Result type of the whole case expression @@ -435,14 +609,13 @@ mkFailurePair expr = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var -> newSysLocalDs unitTy `thenDs` \ fail_fun_arg -> returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr), - App (Var fail_fun_var) (mkConApp unitDataCon [])) + App (Var fail_fun_var) (Var unitDataConId)) | otherwise = newFailLocalDs ty `thenDs` \ fail_var -> returnDs (NonRec fail_var expr, Var fail_var) where - ty = coreExprType expr + ty = exprType expr \end{code} -