X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsUtils.lhs;h=c96665f7f79beaca488b980e28655dc4d62b9d1a;hb=0d61ee90a6c181b18345174f20bd6506456db442;hp=e289d2439f1a72744bd55df7112569b8f84987f7;hpb=69e14f75a4b031e489b7774914e5a176409cea78;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index e289d24..c96665f 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -10,6 +10,8 @@ module DsUtils ( CanItFail(..), EquationInfo(..), MatchResult(..), EqnNo, EqnSet, + tidyLitPat, + mkDsLet, mkDsLets, cantFailMatchResult, extractMatchResult, @@ -19,6 +21,7 @@ module DsUtils ( mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkErrorAppDs, mkNilExpr, mkConsExpr, + mkStringLit, mkStringLitFS, mkSelectorBinds, mkTupleExpr, mkTupleSelector, @@ -29,35 +32,106 @@ 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 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, StrictnessMark, maybeMarkedUnboxed, dataConStrictMarks, - dataConArgTys, dataConId +import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed, + dataConStrictMarks, dataConId, splitProductType_maybe ) import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy, Type ) -import TysWiredIn ( unitDataCon, tupleCon, stringTy, unitTy, unitDataCon, - nilDataCon, consDataCon +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} + + %************************************************************************ %* * -%* Building lets +\subsection{Building lets} %* * %************************************************************************ @@ -78,7 +152,7 @@ mkDsLets binds body = foldr mkDsLet body binds %************************************************************************ %* * -%* Selecting match variables +\subsection{ Selecting match variables} %* * %************************************************************************ @@ -202,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 @@ -219,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 @@ -245,7 +321,7 @@ mkCoAlgCaseMatchResult var match_alts = body_fn fail `thenDs` \ body -> rebuildConArgs con args (dataConStrictMarks con) body `thenDs` \ (body', real_args) -> - returnDs (DataCon con, real_args, body') + returnDs (DataAlt con, real_args, body') mk_default fail | exhaustive_case = [] | otherwise = [(DEFAULT, [], fail)] @@ -253,10 +329,12 @@ mkCoAlgCaseMatchResult var match_alts un_mentioned_constructors = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts] exhaustive_case = isEmptyUniqSet un_mentioned_constructors - --- for each constructor we match on, we might need to re-pack some --- of the strict fields if they are unpacked in the constructor. - +\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 @@ -271,18 +349,19 @@ rebuildConArgs con (arg:args) stricts body | isTyVar arg rebuildConArgs con (arg:args) (str:stricts) body = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) -> case maybeMarkedUnboxed str of - Just (pack_con, tys) -> - let id_tys = dataConArgTys pack_con ty_args in - newSysLocalsDs id_tys `thenDs` \ unpacked_args -> - returnDs ( - mkDsLet (NonRec arg (Con (DataCon pack_con) - (map Type ty_args ++ - map Var unpacked_args))) body', - unpacked_args ++ real_args - ) + 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) - - where ty_args = case splitAlgTyConApp (idType arg) of { (_,args,_) -> args } \end{code} %************************************************************************ @@ -302,8 +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 . unUsgTy) 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} %************************************************************************ @@ -314,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 @@ -338,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 @@ -347,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 @@ -377,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] @@ -396,9 +501,9 @@ 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)) +mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids)) (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ]) \end{code} @@ -413,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 @@ -425,7 +530,7 @@ 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} @@ -467,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 @@ -478,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 @@ -499,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 @@ -512,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}