X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsUtils.lhs;h=9d787add263e25e9e29d67c6391bdeb66e244b5f;hp=4f44eb2db71f636b5a12f9603c4792c0252e3cc5;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hpb=a1433cc95b8165bab8c65090642577dd51720f1f diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 4f44eb2..9d787ad 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -1,22 +1,31 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[DsUtils]{Utilities for desugaring} + +Utilities for desugaring This module exports some utility functions of no great interest. \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module DsUtils ( EquationInfo(..), firstPat, shiftEqns, - mkDsLet, mkDsLets, + mkDsLet, mkDsLets, mkDsApp, mkDsApps, MatchResult(..), CanItFail(..), cantFailMatchResult, alwaysFailMatchResult, extractMatchResult, combineMatchResults, adjustMatchResult, adjustMatchResultDs, - mkCoLetMatchResult, mkGuardedMatchResult, + mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, matchCanFail, mkEvalMatchResult, mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, wrapBind, wrapBinds, @@ -31,7 +40,8 @@ module DsUtils ( dsSyntaxTable, lookupEvidence, - selectSimpleMatchVarL, selectMatchVars, selectMatchVar + selectSimpleMatchVarL, selectMatchVars, selectMatchVar, + mkTickBox, mkOptTickBox, mkBinaryTickBox ) where #include "HsVersions.h" @@ -40,46 +50,37 @@ import {-# SOURCE #-} Match ( matchSimply ) import {-# SOURCE #-} DsExpr( dsExpr ) import HsSyn -import TcHsSyn ( hsLPatType, hsPatType ) +import TcHsSyn import CoreSyn -import Constants ( mAX_TUPLE_SIZE ) +import Constants import DsMonad -import CoreUtils ( exprType, mkIfThenElse, mkCoerce, bindNonRec ) -import MkId ( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, unwrapNewTypeBody ) -import Id ( idType, Id, mkWildId, mkTemplateLocals, mkSysLocal ) -import Var ( Var ) -import Name ( Name ) -import Literal ( Literal(..), mkStringLit, inIntRange, tARGET_MAX_INT ) -import TyCon ( isNewTyCon, tyConDataCons, tyConArity ) -import DataCon ( DataCon, dataConSourceArity, dataConTyCon, dataConTag, dataConRepArgTys ) -import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp, mkTyVarTy, - splitNewTyConApp ) -import Coercion ( Coercion, mkUnsafeCoercion ) -import TcType ( tcEqType ) -import TysPrim ( intPrimTy ) -import TysWiredIn ( nilDataCon, consDataCon, - tupleCon, mkTupleTy, - unitDataConId, unitTy, - charTy, charDataCon, - intTy, intDataCon, - isPArrFakeCon ) -import BasicTypes ( Boxity(..) ) -import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet ) -import UniqSupply ( splitUniqSupply, uniqFromSupply, uniqsFromSupply ) -import PrelNames ( unpackCStringName, unpackCStringUtf8Name, - plusIntegerName, timesIntegerName, smallIntegerDataConName, - lengthPName, indexPName ) +import CoreUtils +import MkId +import Id +import Var +import Name +import Literal +import TyCon +import DataCon +import Type +import Coercion +import TysPrim +import TysWiredIn +import BasicTypes +import UniqSet +import UniqSupply +import PrelNames import Outputable -import SrcLoc ( Located(..), unLoc ) -import Util ( isSingleton, zipEqual, sortWith ) -import ListSetOps ( assocDefault ) +import SrcLoc +import Util +import ListSetOps import FastString -import Data.Char ( ord ) +import StaticFlags + +import Data.Char -#ifdef DEBUG -import Util ( notNull ) -- Used in an assertion -#endif +infixl 4 `mkDsApp`, `mkDsApps` \end{code} @@ -126,16 +127,71 @@ back again. \begin{code} mkDsLet :: CoreBind -> CoreExpr -> CoreExpr -mkDsLet (NonRec bndr rhs) body - | isUnLiftedType (idType bndr) +mkDsLet (NonRec bndr rhs) body -- See Note [CoreSyn let/app invariant] + | isUnLiftedType (idType bndr) && not (exprOkForSpeculation rhs) = Case rhs bndr (exprType body) [(DEFAULT,[],body)] mkDsLet bind body = Let bind body mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr mkDsLets binds body = foldr mkDsLet body binds + +----------- +mkDsApp :: CoreExpr -> CoreExpr -> CoreExpr +-- Check the invariant that the arg of an App is ok-for-speculation if unlifted +-- See CoreSyn Note [CoreSyn let/app invariant] +mkDsApp fun (Type ty) = App fun (Type ty) +mkDsApp fun arg = mk_val_app fun arg arg_ty res_ty + where + (arg_ty, res_ty) = splitFunTy (exprType fun) + +----------- +mkDsApps :: CoreExpr -> [CoreExpr] -> CoreExpr +-- Slightly more efficient version of (foldl mkDsApp) +mkDsApps fun args + = go fun (exprType fun) args + where + go fun fun_ty [] = fun + go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args + go fun fun_ty (arg : args) = go (mk_val_app fun arg arg_ty res_ty) res_ty args + where + (arg_ty, res_ty) = splitFunTy fun_ty +----------- +mk_val_app fun arg arg_ty res_ty -- See Note [CoreSyn let/app invariant] + | not (isUnLiftedType arg_ty) || exprOkForSpeculation arg + = App fun arg -- The vastly common case + +mk_val_app (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 _ res_ty + | f == seqId -- Note [Desugaring seq] + = Case arg1 (mkWildId ty1) res_ty [(DEFAULT,[],arg2)] + +mk_val_app fun arg arg_ty res_ty + = Case arg (mkWildId arg_ty) res_ty [(DEFAULT,[],App fun (Var arg_id))] + where + arg_id = mkWildId arg_ty -- Lots of shadowing, but it doesn't matter, + -- because 'fun ' should not have a free wild-id \end{code} +Note [Desugaring seq] cf Trac #1031 +~~~~~~~~~~~~~~~~~~~~~ + f x y = x `seq` (y `seq` (# x,y #)) + +The [CoreSyn let/app invariant] means that, other things being equal, because +the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus: + + f x y = case (y `seq` (# x,y #)) of v -> x `seq` v + +But that is bad for two reasons: + (a) we now evaluate y before x, and + (b) we can't bind v to an unboxed pair + +Seq is very, very special! So we recognise it right here, and desugar to + case x of _ -> case y of _ -> (# x,y #) + +The special case would be valid for all calls to 'seq', but it's only *necessary* +for ones whose second argument has an unlifted type. So we only catch the latter +case here, to avoid unnecessary tests. + %************************************************************************ %* * @@ -193,7 +249,7 @@ worthy of a type synonym and a few handy functions. \begin{code} firstPat :: EquationInfo -> Pat Id -firstPat eqn = head (eqn_pats eqn) +firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn) shiftEqns :: [EquationInfo] -> [EquationInfo] -- Drop the first pattern in each equation @@ -263,6 +319,12 @@ seqVar var body = Case (Var var) var (exprType body) mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult mkCoLetMatchResult bind = adjustMatchResult (mkDsLet bind) +-- (mkViewMatchResult var' viewExpr var mr) makes the expression +-- let var' = viewExpr var in mr +mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult +mkViewMatchResult var' viewExpr var = + adjustMatchResult (mkDsLet (NonRec var' (mkDsApp viewExpr (Var var)))) + mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult mkEvalMatchResult var ty = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)]) @@ -308,11 +370,11 @@ mkCoAlgCaseMatchResult var ty match_alts -- the scrutinised Id to be sufficiently refined to have a TyCon in it] -- Stuff for newtype - (con1, arg_ids1, match_result1) = head match_alts - arg_id1 = head arg_ids1 + (con1, arg_ids1, match_result1) = ASSERT( notNull match_alts ) head match_alts + arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1 var_ty = idType var (tc, ty_args) = splitNewTyConApp var_ty - newtype_rhs = unwrapNewTypeBody tycon ty_args (Var var) + newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) -- Stuff for data types data_cons = tyConDataCons tycon @@ -598,7 +660,7 @@ mkSelectorBinds pat val_expr is_simple_lpat p = is_simple_pat (unLoc p) is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps - is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConArgs ps) + is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConPatArgs ps) is_simple_pat (VarPat _) = True is_simple_pat (ParPat p) = is_simple_lpat p is_simple_pat other = False @@ -812,7 +874,6 @@ mkCoreSel vars the_var scrut_var scrut [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)] \end{code} - %************************************************************************ %* * \subsection[mkFailurePair]{Code for pattern-matching and other failures} @@ -887,4 +948,43 @@ mkFailurePair expr ty = exprType expr \end{code} - +\begin{code} +mkOptTickBox :: Maybe (Int,[Id]) -> CoreExpr -> DsM CoreExpr +mkOptTickBox Nothing e = return e +mkOptTickBox (Just (ix,ids)) e = mkTickBox ix ids e + +mkTickBox :: Int -> [Id] -> CoreExpr -> DsM CoreExpr +mkTickBox ix vars e = do + uq <- newUnique + mod <- getModuleDs + let tick | opt_Hpc = mkTickBoxOpId uq mod ix + | otherwise = mkBreakPointOpId uq mod ix + uq2 <- newUnique + let occName = mkVarOcc "tick" + let name = mkInternalName uq2 occName noSrcSpan -- use mkSysLocal? + let var = Id.mkLocalId name realWorldStatePrimTy + scrut <- + if opt_Hpc + then return (Var tick) + else do + let tickVar = Var tick + let tickType = mkFunTys (map idType vars) realWorldStatePrimTy + let scrutApTy = App tickVar (Type tickType) + return (mkApps scrutApTy (map Var vars) :: Expr Id) + return $ Case scrut var ty [(DEFAULT,[],e)] + where + ty = exprType e + +mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr +mkBinaryTickBox ixT ixF e = do + mod <- getModuleDs + uq <- newUnique + mod <- getModuleDs + let bndr1 = mkSysLocal FSLIT("t1") uq boolTy + falseBox <- mkTickBox ixF [] $ Var falseDataConId + trueBox <- mkTickBox ixT [] $ Var trueDataConId + return $ Case e bndr1 boolTy + [ (DataAlt falseDataCon, [], falseBox) + , (DataAlt trueDataCon, [], trueBox) + ] +\end{code}