%
+% (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 ( hsPatType, 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 ( funArgTy, 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, iRREFUT_PAT_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}
-------------------------
dsIPBinds (IPBinds ip_binds dict_binds) body
= do { prs <- dsLHsBinds dict_binds
- ; let inner = foldr (\(x,r) e -> Let (NonRec x r) e) body prs
+ ; let inner = Let (Rec prs) body
+ -- The dict bindings may not be in
+ -- dependency order; hence Rec
; foldrDs ds_ip_bind inner ip_binds }
where
ds_ip_bind (L _ (IPBind n e)) 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
putSrcSpanDs loc $
do { rhs <- dsGuarded grhss ty
; let upat = unLoc pat
- eqn = EqnInfo { eqn_wrap = idWrapper, eqn_pats = [upat],
+ eqn = EqnInfo { eqn_pats = [upat],
eqn_rhs = cantFailMatchResult body_w_exports }
- ; var <- selectMatchVar upat ty
+ ; var <- selectMatchVar upat
; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
; return (scrungleMatch var rhs result) }
dsExpr (HsIPVar ip) = returnDs (Var (ipNameName ip))
dsExpr (HsLit lit) = dsLit lit
dsExpr (HsOverLit lit) = dsOverLit lit
+dsExpr (HsWrap co_fn e) = dsCoercion co_fn (dsExpr e)
dsExpr (NegApp expr neg_expr)
= do { core_expr <- dsLExpr expr
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)
- = do dsWarn (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids))
+ = do warnDs (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids))
stablePtr <- ioToIOEnv $ newStablePtr ids
-- Yes, I know... I'm gonna burn in hell.
let Ptr addr# = castStablePtrToPtr stablePtr
extractIds (HsApp fn arg)
| HsVar argId <- unLoc arg
= argId:extractIds (unLoc fn)
- | TyApp arg' ts <- unLoc arg
- , HsVar argId <- unLoc arg'
- = error (showSDoc (ppr ts)) -- argId:extractIds (unLoc fn)
+ | 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 = []
extractHVals ids = ExplicitList unitTy (map (L loc . HsVar) ids)
-- checks for tyvars and unlifted kinds.
dsLExpr e2 `thenDs` \ y_core ->
returnDs (mkApps core_op [x_core, y_core])
-dsExpr (SectionL expr op)
- = dsLExpr op `thenDs` \ core_op ->
- -- for the type of y, we need the type of op's 2nd argument
- let
- (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
- -- Must look through an implicit-parameter type;
- -- newtype impossible; hence Type.splitFunTys
- in
- dsLExpr expr `thenDs` \ x_core ->
- newSysLocalDs x_ty `thenDs` \ x_id ->
- newSysLocalDs y_ty `thenDs` \ y_id ->
-
- returnDs (bindNonRec x_id x_core $
- Lam y_id (mkApps core_op [Var x_id, Var y_id]))
+dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
+ = dsLExpr op `thenDs` \ core_op ->
+ dsLExpr expr `thenDs` \ x_core ->
+ returnDs (App core_op x_core)
-- dsLExpr (SectionR op expr) -- \ x -> op x expr
dsExpr (SectionR op expr)
\noindent
-\underline{\bf Type lambda and application}
-% ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-\begin{code}
-dsExpr (TyLam tyvars expr)
- = dsLExpr expr `thenDs` \ core_expr ->
- returnDs (mkLams tyvars core_expr)
-
-dsExpr (TyApp expr tys)
- = dsLExpr expr `thenDs` \ core_expr ->
- returnDs (mkTyApps core_expr tys)
-\end{code}
-
-
-\noindent
\underline{\bf Various data construction things}
% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
[] -> nlHsVar old_arg_id
mk_alt con
- = newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids ->
+ = ASSERT( isVanillaDataCon con )
+ newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids ->
-- This call to dataConInstOrigArgTys won't work for existentials
-- but existentials don't have record types anyway
let
val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
(dataConFieldLabels con) arg_ids
rhs = foldl (\a b -> nlHsApp a b)
- (noLoc $ TyApp (nlHsVar (dataConWrapId con))
- out_inst_tys)
- val_args
+ (nlHsTyApp (dataConWrapId con) out_inst_tys)
+ val_args
in
- returnDs (mkSimpleMatch [noLoc $ ConPatOut (noLoc con) [] [] emptyLHsBinds
- (PrefixCon (map nlVarPat arg_ids)) record_in_ty]
- rhs)
+ returnDs (mkSimpleMatch [mkPrefixConPat con (map nlVarPat arg_ids) record_in_ty] rhs)
in
-- Record stuff doesn't work for existentials
-- The type checker checks for this, but we need
con_fields = dataConFieldLabels con_id
\end{code}
-
-\noindent
-\underline{\bf Dictionary lambda and application}
-% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-@DictLam@ and @DictApp@ turn into the regular old things.
-(OLD:) @DictFunApp@ also becomes a curried application, albeit slightly more
-complicated; reminiscent of fully-applied constructors.
-\begin{code}
-dsExpr (DictLam dictvars expr)
- = dsLExpr expr `thenDs` \ core_expr ->
- returnDs (mkLams dictvars core_expr)
-
-------------------
-
-dsExpr (DictApp expr dicts) -- becomes a curried application
- = dsLExpr expr `thenDs` \ core_expr ->
- returnDs (foldl (\f d -> f `App` (Var d)) core_expr dicts)
-
-dsExpr (HsCoerce co_fn e) = dsCoercion co_fn (dsExpr e)
-\end{code}
-
Here is where we desugar the Template Haskell brackets and escapes
\begin{code}
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}
; match_code <- extractMatchResult match fail_expr
; rhs' <- dsLExpr rhs
- ; returnDs (mkApps (Var bind_id) [Type (hsPatType pat), Type b_ty,
+ ; returnDs (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
rhs', Lam var match_code]) }
go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
later_ids' = filter (`notElem` mono_rec_ids) later_ids
mono_rec_ids = [ id | HsVar id <- rec_rets ]
- mfix_app = nlHsApp (noLoc $ TyApp (nlHsVar mfix_id) [tup_ty]) mfix_arg
+ mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
(mkFunTy tup_ty body_ty))
tup_ty = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
-- mkCoreTupTy deals with singleton case
- return_app = nlHsApp (noLoc $ TyApp (nlHsVar return_id) [tup_ty])
+ return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
(mk_ret_tup rets)
mk_wild_pat :: Id -> LPat Id