%
+% (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,
dsSyntaxTable, lookupEvidence,
- selectSimpleMatchVarL, selectMatchVars, selectMatchVar
+ selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
+ mkTickBox, mkOptTickBox, mkBinaryTickBox
) where
#include "HsVersions.h"
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}
\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.
+
%************************************************************************
%* *
\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
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)])
-- 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
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
[(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
\end{code}
-
%************************************************************************
%* *
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
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}
projects / ghc-hetmet.git / blobdiff