X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsUtils.lhs;h=f27b78cc4e6eb655a2eb9fb7545b88bb91c8aef4;hb=9bb6b6d0fbca6c82040027fab9859c9fcbc1ef7e;hp=3c95d90ab6046bbc2151405957f88444c88e8261;hpb=a127213c1890584702075d732d7bb9887113e4ff;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 3c95d90..f27b78c 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, @@ -41,7 +42,7 @@ import DsMonad import CoreUtils ( exprType, mkIfThenElse ) import PrelInfo ( iRREFUT_PAT_ERROR_ID ) import Id ( idType, Id, mkWildId ) -import Literal ( Literal ) +import Literal ( Literal(..), inIntRange, tARGET_MAX_INT ) import TyCon ( isNewTyCon, tyConDataCons ) import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed, dataConStrictMarks, dataConId, splitProductType_maybe @@ -49,26 +50,23 @@ import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed, import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy, Type ) -import TysPrim ( intPrimTy, - charPrimTy, - floatPrimTy, - doublePrimTy, - addrPrimTy, - wordPrimTy - ) +import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy ) import TysWiredIn ( nilDataCon, consDataCon, tupleCon, stringTy, unitDataConId, unitTy, charTy, charDataCon, - intTy, intDataCon, + intTy, intDataCon, smallIntegerDataCon, floatTy, floatDataCon, - doubleTy, doubleDataCon, - addrTy, addrDataCon, - wordTy, wordDataCon + doubleTy, doubleDataCon, + stringTy ) +import BasicTypes ( Boxity(..) ) import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet ) +import PrelNames ( unpackCStringName, unpackCStringUtf8Name, + plusIntegerName, timesIntegerName ) import Outputable +import UnicodeUtil ( stringToUtf8 ) \end{code} @@ -80,47 +78,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_word l@(HsLitLit s) = l + mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy] - mk_addr l@(HsLitLit s) = l +tidyNPat lit lit_ty default_pat + | lit_ty == intTy = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy] + | lit_ty == floatTy = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy] + | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy] + | otherwise = default_pat - 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} @@ -288,14 +273,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 (unUsgTy (idType arg_id)) (unUsgTy 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 @@ -375,10 +361,78 @@ 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 \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} @@ -420,9 +474,10 @@ 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 ) @@ -454,7 +509,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] @@ -475,7 +530,7 @@ mkTupleExpr :: [Id] -> CoreExpr 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} @@ -502,7 +557,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}