X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=2bb2cc43db1f3e3c7682ae10279c38007fbc209f;hb=680f11d3f1ad9065c4969ed5d9db857cc245d778;hp=5ffae6dcf241df8389307b2aacd1d718a69c6f32;hpb=f1c0fd99f16322fe222c6fcf4626a6162ad0a466;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 5ffae6d..2bb2cc4 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -1,66 +1,59 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[DsExpr]{Matching expressions (Exprs)}
+
+Desugaring exporessions.
 
 \begin{code}
 module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
 
 #include "HsVersions.h"
 #if defined(GHCI) && defined(BREAKPOINT)
-import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr )
-import GHC.Exts         ( Ptr(..), Int(..), addr2Int# )
-import IOEnv            ( ioToIOEnv )
-import PrelNames        ( breakpointJumpName, breakpointCondJumpName )
-import TysWiredIn       ( unitTy )
-import TypeRep          ( Type(..) )
-import TyCon            ( isUnLiftedTyCon )
+import Foreign.StablePtr
+import GHC.Exts
+import IOEnv
+import PrelNames
+import TysWiredIn
+import TypeRep
+import TyCon
 #endif
 
-import Match		( matchWrapper, matchSinglePat, matchEquations )
-import MatchLit		( dsLit, dsOverLit )
-import DsBinds		( dsLHsBinds, dsCoercion )
-import DsGRHSs		( dsGuarded )
-import DsListComp	( dsListComp, dsPArrComp )
-import DsUtils		( mkErrorAppDs, mkStringExpr, mkConsExpr, mkNilExpr,
-			  extractMatchResult, cantFailMatchResult, matchCanFail,
-			  mkCoreTupTy, selectSimpleMatchVarL, lookupEvidence, selectMatchVar )
-import DsArrows		( dsProcExpr )
+import Match
+import MatchLit
+import DsBinds
+import DsGRHSs
+import DsListComp
+import DsUtils
+import DsArrows
 import DsMonad
 
 #ifdef GHCI
 	-- Template Haskell stuff iff bootstrapped
-import DsMeta		( dsBracket )
+import DsMeta
 #endif
 
 import HsSyn
-import TcHsSyn		( hsLPatType, mkVanillaTuplePat )
+import TcHsSyn
 
 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
---     needs to see source types (newtypes etc), and sometimes not
---     So WATCH OUT; check each use of split*Ty functions.
--- Sigh.  This is a pain.
-
-import TcType		( tcSplitAppTy, tcSplitFunTys, tcTyConAppTyCon, 
-			  tcTyConAppArgs, isUnLiftedType, Type, mkAppTy )
-import Type		( splitFunTys, isUnboxedTupleType, mkFunTy )
+--     needs to see source types
+import TcType
+import Type
 import CoreSyn
-import CoreUtils	( exprType, mkIfThenElse, bindNonRec )
-
-import CostCentre	( mkUserCC )
-import Id		( Id, idType, idName, idDataCon )
-import PrelInfo		( rEC_CON_ERROR_ID )
-import DataCon		( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys )
-import DataCon		( isVanillaDataCon )
-import TyCon		( FieldLabel, tyConDataCons )
-import TysWiredIn	( tupleCon )
-import BasicTypes	( RecFlag(..), Boxity(..), ipNameName )
-import PrelNames	( toPName,
-			  returnMName, bindMName, thenMName, failMName,
-			  mfixName )
-import SrcLoc		( Located(..), unLoc, getLoc, noLoc )
-import Util		( zipEqual, zipWithEqual )
-import Bag		( bagToList )
+import CoreUtils
+
+import CostCentre
+import Id
+import PrelInfo
+import DataCon
+import TyCon
+import TysWiredIn
+import BasicTypes
+import PrelNames
+import SrcLoc
+import Util
+import Bag
 import Outputable
 import FastString
 \end{code}
@@ -118,11 +111,12 @@ ds_val_bind (NonRecursive, hsbinds) body
 	--	 below.  Then pattern-match would fail.  Urk.)
     putSrcSpanDs loc	$
     case bind of
-      FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn }
+      FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, fun_tick = tick }
 	-> matchWrapper (FunRhs (idName fun)) matches 	 	`thenDs` \ (args, rhs) ->
 	   ASSERT( null args )	-- Functions aren't lifted
-	   ASSERT( isIdCoercion co_fn )
-	   returnDs (bindNonRec fun rhs body_w_exports)
+	   ASSERT( isIdHsWrapper co_fn )
+           mkOptTickBox tick rhs 				`thenDs` \ rhs' ->
+	   returnDs (bindNonRec fun rhs' body_w_exports)
 
       PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
 	-> 	-- let C x# y# = rhs in body
@@ -205,7 +199,7 @@ dsExpr (HsVar var)     	      = returnDs (Var var)
 dsExpr (HsIPVar ip)    	      = returnDs (Var (ipNameName ip))
 dsExpr (HsLit lit)     	      = dsLit lit
 dsExpr (HsOverLit lit) 	      = dsOverLit lit
-dsExpr (HsCoerce co_fn e)     = dsCoercion co_fn (dsExpr e)
+dsExpr (HsWrap co_fn e)     = dsCoercion co_fn (dsExpr e)
 
 dsExpr (NegApp expr neg_expr) 
   = do	{ core_expr <- dsLExpr expr
@@ -217,7 +211,7 @@ dsExpr expr@(HsLam a_Match)
     returnDs (mkLams binders matching_code)
 
 #if defined(GHCI) && defined(BREAKPOINT)
-dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _)
+dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsWrap _ fun)) (L loc arg))) _)
     | HsVar funId <- fun
     , idName funId `elem` [breakpointJumpName, breakpointCondJumpName]
     , ids <- filter (isValidType . idType) (extractIds arg)
@@ -233,7 +227,7 @@ dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _)
           extractIds (HsApp fn arg)
               | HsVar argId <- unLoc arg
               = argId:extractIds (unLoc fn)
-              | HsCoerce co_fn arg' <- unLoc arg
+              | HsWrap co_fn arg' <- unLoc arg
               , HsVar argId <- arg'		-- SLPJ: not sure what is going on here
               = error (showSDoc (ppr co_fn)) -- argId:extractIds (unLoc fn)
           extractIds x = []
@@ -577,6 +571,26 @@ dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
 \end{code}
 
+Hpc Support 
+
+\begin{code}
+dsExpr (HsTick ix e) = do
+  e' <- dsLExpr e
+  mkTickBox ix e'
+
+-- There is a problem here. The then and else branches
+-- have no free variables, so they are open to lifting.
+-- We need someway of stopping this.
+-- This will make no difference to binary coverage
+-- (did you go here: YES or NO), but will effect accurate
+-- tick counting.
+
+dsExpr (HsBinTick ixT ixF e) = do
+  e2 <- dsLExpr e
+  do { ASSERT(exprType e2 `coreEqType` boolTy)
+       mkBinaryTickBox ixT ixF e2
+     }
+\end{code}
 
 \begin{code}