X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsUtils.lhs;h=9bb99a65c5403dc167f6ddf751e86a6a0b3d4542;hb=76293b141bba4c15a6fd619dd980502e98614790;hp=c96665f7f79beaca488b980e28655dc4d62b9d1a;hpb=0d61ee90a6c181b18345174f20bd6506456db442;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index c96665f..9bb99a6 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,7 +21,7 @@ module DsUtils ( mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkErrorAppDs, mkNilExpr, mkConsExpr, - mkStringLit, mkStringLitFS, + mkStringLit, mkStringLitFS, mkIntegerLit, mkSelectorBinds, mkTupleExpr, mkTupleSelector, @@ -33,45 +33,38 @@ 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, + dataConSourceArity ) +import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp ) +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 - ) + intTy, intDataCon, smallIntegerDataCon, + floatDataCon, + doubleDataCon, + stringTy, isPArrFakeCon ) import BasicTypes ( Boxity(..) ) import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet ) -import Unique ( unpackCStringIdKey, unpackCString2IdKey ) +import PrelNames ( unpackCStringName, unpackCStringUtf8Name, + plusIntegerName, timesIntegerName, + lengthPName, indexPName ) import Outputable +import UnicodeUtil ( stringToUtf8 ) +import Util ( isSingleton ) \end{code} @@ -83,49 +76,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 literal patterns like "foo" to 'f':'o':'o':[] - | str_lit lit = mk_list lit - - | 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 + | 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_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 + where + mk_int (HsInteger i) = HsIntPrim i - mk_list (HsString s) = foldr - (\c pat -> ConPat consDataCon lit_ty [] [] [mk_char_lit c,pat]) - (ConPat nilDataCon lit_ty [] [] []) (_UNPK_ s) + mk_float (HsInteger i) = HsFloatPrim (fromInteger i) + mk_float (HsRat f _) = HsFloatPrim f - mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy] + mk_double (HsInteger i) = HsDoublePrim (fromInteger i) + mk_double (HsRat f _) = HsDoublePrim f \end{code} @@ -273,7 +251,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) @@ -285,24 +263,28 @@ 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 + + | isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case + = MatchResult CanFail mk_parrCase | 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 @@ -315,13 +297,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)] @@ -329,40 +313,74 @@ mkCoAlgCaseMatchResult var match_alts un_mentioned_constructors = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts] exhaustive_case = isEmptyUniqSet un_mentioned_constructors + + -- Stuff for parallel arrays + -- + -- * the following is to desugar cases over fake constructors for + -- parallel arrays, which are introduced by `tidy1' in the `PArrPat' + -- case + -- + -- Concerning `isPArrFakeAlts': + -- + -- * it is *not* sufficient to just check the type of the type + -- constructor, as we have to be careful not to confuse the real + -- representation of parallel arrays with the fake constructors; + -- moreover, a list of alternatives must not mix fake and real + -- constructors (this is checked earlier on) + -- + -- FIXME: We actually go through the whole list and make sure that + -- either all or none of the constructors are fake parallel + -- array constructors. This is to spot equations that mix fake + -- constructors with the real representation defined in + -- `PrelPArr'. It would be nicer to spot this situation + -- earlier and raise a proper error message, but it can really + -- only happen in `PrelPArr' anyway. + -- + isPArrFakeAlts [(dcon, _, _)] = isPArrFakeCon dcon + isPArrFakeAlts ((dcon, _, _):alts) = + case (isPArrFakeCon dcon, isPArrFakeAlts alts) of + (True , True ) -> True + (False, False) -> False + _ -> + panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns" + -- + mk_parrCase fail = + dsLookupGlobalValue lengthPName `thenDs` \lengthP -> + unboxAlt `thenDs` \alt -> + returnDs (Case (len lengthP) (mkWildId intTy) [alt]) + where + elemTy = case splitTyConApp (idType var) of + (_, [elemTy]) -> elemTy + _ -> panic panicMsg + panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?" + len lengthP = mkApps (Var lengthP) [Type elemTy, Var var] + -- + unboxAlt = + newSysLocalDs intPrimTy `thenDs` \l -> + dsLookupGlobalValue indexPName `thenDs` \indexP -> + mapDs (mkAlt indexP) match_alts `thenDs` \alts -> + returnDs (DataAlt intDataCon, [l], (Case (Var l) wild (dft : alts))) + where + wild = mkWildId intPrimTy + dft = (DEFAULT, [], fail) + -- + -- each alternative matches one array length (corresponding to one + -- fake array constructor), so the match is on a literal; each + -- alternative's body is extended by a local binding for each + -- constructor argument, which are bound to array elements starting + -- with the first + -- + mkAlt indexP (con, args, MatchResult _ bodyFun) = + bodyFun fail `thenDs` \body -> + returnDs (LitAlt lit, [], mkDsLets binds body) + where + lit = MachInt $ toInteger (dataConSourceArity con) + binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args] + -- + indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, toInt i] + toInt i = mkConApp intDataCon [Lit $ MachInt i] \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} + %************************************************************************ %* * @@ -382,30 +400,76 @@ mkErrorAppDs err_id ty msg full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg]) in mkStringLit full_msg `thenDs` \ core_msg -> - returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, core_msg]) - -- unUsgTy *required* -- KSW 1999-04-07 + 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 - | 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)]) + | _NULL_ str + = returnDs (mkNilExpr charTy) - | otherwise - = -- No NULs in the string - dsLookupGlobalValue unpackCStringIdKey `thenDs` \ unpack_id -> + | _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 - is_NUL c = c == '\0' + chars = _UNPK_INT_ str + safeChar c = c >= 1 && c <= 0xFF \end{code} + %************************************************************************ %* * \subsection[mkSelectorBind]{Make a selector bind} @@ -437,7 +501,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 @@ -455,15 +519,13 @@ mkSelectorBinds pat val_expr | 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 @@ -475,7 +537,7 @@ 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 @@ -495,8 +557,7 @@ 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 @@ -504,7 +565,7 @@ mkTupleExpr :: [Id] -> CoreExpr mkTupleExpr [] = Var unitDataConId mkTupleExpr [id] = Var id mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids)) - (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ]) + (map (Type . idType) ids ++ [ Var i | i <- ids ]) \end{code} @@ -627,4 +688,3 @@ mkFailurePair expr \end{code} -