X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsUtils.lhs;h=c96665f7f79beaca488b980e28655dc4d62b9d1a;hb=014a3451c3179b6c485e67dd1463966d588be96a;hp=a26082fb8348e49487232846f6a54e1f0168fc77;hpb=7e602b0a11e567fcb035d1afd34015aebcf9a577;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index a26082f..c96665f 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, + + mkDsLet, mkDsLets, + cantFailMatchResult, extractMatchResult, combineMatchResults, adjustMatchResult, adjustMatchResultDs, mkCoLetsMatchResult, mkGuardedMatchResult, mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, - mkErrorAppDs, + mkErrorAppDs, mkNilExpr, mkConsExpr, + mkStringLit, mkStringLitFS, mkSelectorBinds, mkTupleExpr, mkTupleSelector, @@ -27,31 +32,127 @@ module DsUtils ( import {-# SOURCE #-} Match ( matchSimply ) -import HsSyn ( OutPat(..) ) +import HsSyn import TcHsSyn ( TypecheckedPat ) import DsHsSyn ( 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 Id ( idType, Id, mkWildId ) -import Const ( Literal(..), Con(..) ) +import Literal ( Literal(..) ) import TyCon ( isNewTyCon, tyConDataCons ) -import DataCon ( DataCon ) -import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, +import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed, + dataConStrictMarks, dataConId, splitProductType_maybe + ) +import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy, Type ) -import TysWiredIn ( unitDataCon, tupleCon, stringTy, unitTy, unitDataCon ) +import TysPrim ( intPrimTy, + charPrimTy, + floatPrimTy, + doublePrimTy, + addrPrimTy, + wordPrimTy + ) +import TysWiredIn ( nilDataCon, consDataCon, + tupleCon, + stringTy, + unitDataConId, unitTy, + charTy, charDataCon, + intTy, intDataCon, + floatTy, floatDataCon, + doubleTy, doubleDataCon, + addrTy, addrDataCon, + wordTy, wordDataCon + ) +import BasicTypes ( Boxity(..) ) import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet ) +import Unique ( unpackCStringIdKey, unpackCString2IdKey ) import Outputable \end{code} + +%************************************************************************ +%* * +\subsection{Tidying lit pats} +%* * +%************************************************************************ + +\begin{code} +tidyLitPat lit lit_ty default_pat + | lit_ty == charTy = ConPat charDataCon lit_ty [] [] [LitPat (mk_char lit) charPrimTy] + | lit_ty == intTy = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy] + | lit_ty == wordTy = ConPat wordDataCon lit_ty [] [] [LitPat (mk_word lit) wordPrimTy] + | lit_ty == addrTy = ConPat addrDataCon lit_ty [] [] [LitPat (mk_addr lit) addrPrimTy] + | lit_ty == floatTy = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy] + | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy] + + -- Convert literal patterns like "foo" to 'f':'o':'o':[] + | str_lit lit = mk_list lit + + | otherwise = default_pat + + where + mk_int (HsInt i) = HsIntPrim i + mk_int l@(HsLitLit s) = l + + mk_char (HsChar c) = HsCharPrim c + mk_char l@(HsLitLit s) = l + + mk_word l@(HsLitLit s) = l + + mk_addr l@(HsLitLit s) = l + + mk_float (HsInt i) = HsFloatPrim (fromInteger i) + mk_float (HsFrac f) = HsFloatPrim f + mk_float l@(HsLitLit s) = l + + mk_double (HsInt i) = HsDoublePrim (fromInteger i) + mk_double (HsFrac f) = HsDoublePrim f + mk_double l@(HsLitLit s) = l + + null_str_lit (HsString s) = _NULL_ s + null_str_lit other_lit = False + + str_lit (HsString s) = True + str_lit _ = False + + mk_list (HsString s) = foldr + (\c pat -> ConPat consDataCon lit_ty [] [] [mk_char_lit c,pat]) + (ConPat nilDataCon lit_ty [] [] []) (_UNPK_ s) + + mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy] +\end{code} + + +%************************************************************************ +%* * +\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} + + %************************************************************************ %* * -%* Selecting match variables +\subsection{ Selecting match variables} %* * %************************************************************************ @@ -126,7 +227,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 +257,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 @@ -175,7 +276,7 @@ mkCoPrimCaseMatchResult var match_alts returnDs (Case (Var var) var (alts ++ [(DEFAULT, [], fail)])) mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body -> - returnDs (Literal lit, [], body) + returnDs (LitAlt lit, [], body) mkCoAlgCaseMatchResult :: Id -- Scrutinee @@ -192,13 +293,15 @@ mkCoAlgCaseMatchResult var match_alts where -- Common stuff scrut_ty = idType var - (tycon, tycon_arg_tys, _) = splitAlgTyConApp scrut_ty + (tycon, _, _) = splitAlgTyConApp scrut_ty -- 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 + coercion_bind = NonRec arg_id (Note (Coerce (unUsgTy (idType arg_id)) + (unUsgTy scrut_ty)) + (Var var)) + newtype_sanity = null (tail match_alts) && null (tail arg_ids) -- Stuff for data types data_cons = tyConDataCons tycon @@ -216,7 +319,9 @@ mkCoAlgCaseMatchResult var match_alts mk_alt fail (con, args, MatchResult _ body_fn) = body_fn fail `thenDs` \ body -> - returnDs (DataCon con, args, body) + rebuildConArgs con args (dataConStrictMarks con) body + `thenDs` \ (body', real_args) -> + returnDs (DataAlt con, real_args, body') mk_default fail | exhaustive_case = [] | otherwise = [(DEFAULT, [], fail)] @@ -224,8 +329,39 @@ mkCoAlgCaseMatchResult var match_alts un_mentioned_constructors = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts] exhaustive_case = isEmptyUniqSet un_mentioned_constructors - - +\end{code} +% +For each constructor we match on, we might need to re-pack some +of the strict fields if they are unpacked in the constructor. +% +\begin{code} +rebuildConArgs + :: DataCon -- the con we're matching on + -> [Id] -- the source-level args + -> [StrictnessMark] -- the strictness annotations (per-arg) + -> CoreExpr -- the body + -> DsM (CoreExpr, [Id]) + +rebuildConArgs con [] stricts body = returnDs (body, []) +rebuildConArgs con (arg:args) stricts body | isTyVar arg + = rebuildConArgs con args stricts body `thenDs` \ (body', args') -> + returnDs (body',arg:args') +rebuildConArgs con (arg:args) (str:stricts) body + = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) -> + case maybeMarkedUnboxed str of + Just (pack_con1, _) -> + case splitProductType_maybe (idType arg) of + Just (_, tycon_args, pack_con, con_arg_tys) -> + ASSERT( pack_con == pack_con1 ) + newSysLocalsDs con_arg_tys `thenDs` \ unpacked_args -> + returnDs ( + mkDsLet (NonRec arg (mkConApp pack_con + (map Type tycon_args ++ + map Var unpacked_args))) body', + unpacked_args ++ real_args + ) + + _ -> returnDs (body', arg:real_args) \end{code} %************************************************************************ @@ -245,7 +381,29 @@ 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 . unUsgTy) ty, core_msg]) + -- unUsgTy *required* -- KSW 1999-04-07 + +mkStringLit :: String -> DsM CoreExpr +mkStringLit str = mkStringLitFS (_PK_ str) + +mkStringLitFS :: FAST_STRING -> DsM CoreExpr +mkStringLitFS str + | any is_NUL (_UNPK_ str) + = -- Must cater for NULs in literal string + dsLookupGlobalValue unpackCString2IdKey `thenDs` \ unpack_id -> + returnDs (mkApps (Var unpack_id) + [Lit (MachStr str), + mkIntLitInt (_LENGTH_ str)]) + + | otherwise + = -- No NULs in the string + dsLookupGlobalValue unpackCStringIdKey `thenDs` \ unpack_id -> + returnDs (App (Var unpack_id) (Lit (MachStr str))) + + where + is_NUL c = c == '\0' \end{code} %************************************************************************ @@ -256,10 +414,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 +438,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,24 +447,29 @@ 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 LetMatch 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 @@ -319,7 +482,7 @@ mkSelectorBinds pat val_expr 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] @@ -332,15 +495,16 @@ mkSelectorBinds pat val_expr @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it -has only one element, it is the identity function. +has only one element, it is the identity function. Notice we must +throw out any usage annotation on the outside of an Id. \begin{code} mkTupleExpr :: [Id] -> CoreExpr -mkTupleExpr [] = mkConApp unitDataCon [] +mkTupleExpr [] = Var unitDataConId mkTupleExpr [id] = Var id -mkTupleExpr ids = mkConApp (tupleCon (length ids)) - (map (Type . idType) ids ++ [ Var i | i <- ids ]) +mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids)) + (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ]) \end{code} @@ -354,10 +518,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 +530,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 +572,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 +583,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 +604,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,13 +617,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}