X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FdeSugar%2FDsUtils.lhs;h=6b45c58108ee6e528a0ce79af831661bce4c5fe0;hb=5e3f005d3012472e422d4ffd7dca5c21a80fca80;hp=181beeb3dd41513a47ee7994310d831ce194bf19;hpb=bb91427f27c940e4dd0fc6c7360e7ef61264b240;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 181beeb..6b45c58 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -10,7 +10,7 @@ module DsUtils ( CanItFail(..), EquationInfo(..), MatchResult(..), EqnNo, EqnSet, - tidyLitPat, + tidyLitPat, tidyNPat, mkDsLet, mkDsLets, @@ -21,6 +21,7 @@ module DsUtils ( mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkErrorAppDs, mkNilExpr, mkConsExpr, + mkStringLit, mkStringLitFS, mkIntegerLit, mkSelectorBinds, mkTupleExpr, mkTupleSelector, @@ -32,43 +33,37 @@ module DsUtils ( import {-# SOURCE #-} Match ( matchSimply ) import HsSyn -import TcHsSyn ( TypecheckedPat ) -import DsHsSyn ( outPatType, collectTypedPatBinders ) +import TcHsSyn ( TypecheckedPat, outPatType, collectTypedPatBinders ) import CoreSyn import DsMonad import CoreUtils ( exprType, mkIfThenElse ) import PrelInfo ( iRREFUT_PAT_ERROR_ID ) +import MkId ( rebuildConArgs ) import Id ( idType, Id, mkWildId ) -import Literal ( Literal ) -import TyCon ( isNewTyCon, tyConDataCons ) -import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed, - dataConStrictMarks, dataConId, splitProductType_maybe - ) -import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy, - Type - ) -import TysPrim ( intPrimTy, - charPrimTy, - floatPrimTy, - doublePrimTy, - addrPrimTy, - wordPrimTy - ) +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, - stringTy, unitDataConId, unitTy, charTy, charDataCon, - intTy, intDataCon, - floatTy, floatDataCon, - doubleTy, doubleDataCon, - addrTy, addrDataCon, - wordTy, wordDataCon + intDataCon, smallIntegerDataCon, + floatDataCon, + doubleDataCon, + stringTy ) +import BasicTypes ( Boxity(..) ) import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet ) +import PrelNames ( unpackCStringName, unpackCStringUtf8Name, + plusIntegerName, timesIntegerName ) import Outputable +import UnicodeUtil ( stringToUtf8 ) +import Util ( isSingleton ) \end{code} @@ -80,47 +75,34 @@ import Outputable %************************************************************************ \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 the literal pattern "" to the constructor pattern []. - | null_str_lit lit = ConPat nilDataCon lit_ty [] [] [] - -- Similar special case for "x" - | one_str_lit lit = ConPat consDataCon lit_ty [] [] - [mk_first_char_lit lit, ConPat nilDataCon lit_ty [] [] []] - - | otherwise = default_pat - +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_int (HsInt i) = HsIntPrim i - mk_int l@(HsLitLit s) = l - - mk_char (HsChar c) = HsCharPrim c - mk_char l@(HsLitLit s) = l + mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy] - mk_word l@(HsLitLit s) = l +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 - 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 + where + mk_int (HsInteger i) = HsIntPrim i - null_str_lit (HsString s) = _NULL_ s - null_str_lit other_lit = False + mk_float (HsInteger i) = HsFloatPrim (fromInteger i) + mk_float (HsRat f _) = HsFloatPrim f - one_str_lit (HsString s) = _LENGTH_ s == (1::Int) - one_str_lit other_lit = False - mk_first_char_lit (HsString s) = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim (_HEAD_ s)) charPrimTy] + mk_double (HsInteger i) = HsDoublePrim (fromInteger i) + mk_double (HsRat f _) = HsDoublePrim f \end{code} @@ -268,7 +250,7 @@ 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 (LitAlt lit, [], body) @@ -280,24 +262,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, _, _) = splitAlgTyConApp scrut_ty + tycon = tcTyConAppTyCon scrut_ty -- Newtypes must be opaque here -- Stuff for newtype (_, 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) + 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 @@ -310,13 +293,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 -> - rebuildConArgs con args (dataConStrictMarks con) body - `thenDs` \ (body', real_args) -> - returnDs (DataAlt con, real_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)] @@ -325,39 +310,7 @@ mkCoAlgCaseMatchResult var match_alts = 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} + %************************************************************************ %* * @@ -376,10 +329,77 @@ 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]) - -- unUsgTy *required* -- KSW 1999-04-07 + 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} @@ -411,7 +431,7 @@ mkSelectorBinds (VarPat v) val_expr = returnDs [(v, val_expr)] mkSelectorBinds pat val_expr - | length binders == 1 || is_simple_pat pat + | isSingleton binders || is_simple_pat pat = newSysLocalDs (exprType val_expr) `thenDs` \ val_var -> -- For the error message we don't use mkErrorAppDs to avoid @@ -421,22 +441,21 @@ 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 @@ -448,14 +467,14 @@ mkSelectorBinds pat val_expr -- (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] @@ -468,16 +487,15 @@ mkSelectorBinds pat val_expr @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it -has only one element, it is the identity function. Notice we must -throw out any usage annotation on the outside of an Id. +has only one element, it is the identity function. \begin{code} mkTupleExpr :: [Id] -> CoreExpr mkTupleExpr [] = Var unitDataConId mkTupleExpr [id] = Var id -mkTupleExpr ids = mkConApp (tupleCon (length ids)) - (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ]) +mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids)) + (map (Type . idType) ids ++ [ Var i | i <- ids ]) \end{code} @@ -503,7 +521,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 [(DataAlt (tupleCon (length vars)), vars, Var the_var)] + Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)] \end{code} @@ -600,4 +618,3 @@ mkFailurePair expr \end{code} -