%
+% (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 )
-#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
+import Name
#ifdef GHCI
+import PrelNames
-- 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 TysWiredIn
+import BasicTypes
+import PrelNames
+import SrcLoc
+import Util
+import Bag
import Outputable
import FastString
\end{code}
-- 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 }
- -> matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) ->
+ FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn,
+ fun_tick = tick, fun_infix = inf }
+ -> matchWrapper (FunRhs (idName fun ) inf) matches `thenDs` \ (args, rhs) ->
ASSERT( null args ) -- Functions aren't lifted
ASSERT( isIdHsWrapper co_fn )
- returnDs (bindNonRec fun rhs body_w_exports)
+ 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
| x == var = Case scrut bndr ty alts
scrungle (Let binds body) = Let binds (scrungle body)
scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
+
\end{code}
%************************************************************************
\begin{code}
dsLExpr :: LHsExpr Id -> DsM CoreExpr
+
dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
dsExpr :: HsExpr Id -> DsM CoreExpr
-
dsExpr (HsPar e) = dsLExpr e
dsExpr (ExprWithTySigOut e _) = dsLExpr e
dsExpr (HsVar var) = returnDs (Var var)
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 (HsWrap co_fn e) = dsCoercion co_fn (dsExpr e)
dsExpr (NegApp expr neg_expr)
= do { core_expr <- dsLExpr expr
= matchWrapper LambdaExpr a_Match `thenDs` \ (binders, matching_code) ->
returnDs (mkLams binders matching_code)
-#if defined(GHCI) && defined(BREAKPOINT)
-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 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
- funCore <- dsLExpr realFun
- argCore <- dsLExpr (L loc (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#))))))
- hvalCore <- dsLExpr (L loc (extractHVals ids))
- return ((funCore `App` argCore) `App` hvalCore)
- where extractIds :: HsExpr Id -> [Id]
- extractIds (HsApp fn arg)
- | HsVar argId <- unLoc arg
- = 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.
- isValidType (TyVarTy _) = False
- isValidType (FunTy a b) = isValidType a && isValidType b
- isValidType (NoteTy _ t) = isValidType t
- isValidType (AppTy a b) = isValidType a && isValidType b
- isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) && all isValidType ts
- isValidType _ = True
-#endif
-
dsExpr expr@(HsApp fun arg)
= dsLExpr fun `thenDs` \ core_fun ->
dsLExpr arg `thenDs` \ core_arg ->
- returnDs (core_fun `App` core_arg)
+ returnDs (core_fun `mkDsApp` core_arg)
\end{code}
Operator sections. At first it looks as if we can convert
-- for the type of y, we need the type of op's 2nd argument
dsLExpr e1 `thenDs` \ x_core ->
dsLExpr e2 `thenDs` \ y_core ->
- returnDs (mkApps core_op [x_core, y_core])
+ returnDs (mkDsApps core_op [x_core, y_core])
dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
= dsLExpr op `thenDs` \ core_op ->
dsLExpr expr `thenDs` \ x_core ->
- returnDs (App core_op x_core)
+ returnDs (mkDsApp core_op x_core)
-- dsLExpr (SectionR op expr) -- \ x -> op x expr
dsExpr (SectionR op expr)
newSysLocalDs y_ty `thenDs` \ y_id ->
returnDs (bindNonRec y_id y_core $
- Lam x_id (mkApps core_op [Var x_id, Var y_id]))
+ Lam x_id (mkDsApps core_op [Var x_id, Var y_id]))
dsExpr (HsSCC cc expr)
= dsLExpr expr `thenDs` \ core_expr ->
matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) ->
returnDs (scrungleMatch discrim_var core_discrim matching_code)
+-- Pepe: The binds are in scope in the body but NOT in the binding group
+-- This is to avoid silliness in breakpoints
dsExpr (HsLet binds body)
- = dsLExpr body `thenDs` \ body' ->
+ = dsLExpr body `thenDs` \ body' ->
dsLocalBinds binds body'
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- hence TcType.tcSplitFunTys
mk_arg (arg_ty, lbl) -- Selector id has the field label as its name
- = case [rhs | (L _ sel_id, rhs) <- rbinds, lbl == idName sel_id] of
+ = case findField (rec_flds rbinds) lbl of
(rhs:rhss) -> ASSERT( null rhss )
dsLExpr rhs
[] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
dictionaries.
\begin{code}
-dsExpr (RecordUpd record_expr [] record_in_ty record_out_ty)
+dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
+ cons_to_upd in_inst_tys out_inst_tys)
+ | null fields
= dsLExpr record_expr
-
-dsExpr expr@(RecordUpd record_expr rbinds record_in_ty record_out_ty)
- = dsLExpr record_expr `thenDs` \ record_expr' ->
-
- -- Desugar the rbinds, and generate let-bindings if
- -- necessary so that we don't lose sharing
-
- let
- in_inst_tys = tcTyConAppArgs record_in_ty -- Newtype opaque
- out_inst_tys = tcTyConAppArgs record_out_ty -- Newtype opaque
- in_out_ty = mkFunTy record_in_ty record_out_ty
-
- mk_val_arg field old_arg_id
- = case [rhs | (L _ sel_id, rhs) <- rbinds, field == idName sel_id] of
- (rhs:rest) -> ASSERT(null rest) rhs
- [] -> nlHsVar old_arg_id
-
- mk_alt con
- = 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)
- (nlHsTyApp (dataConWrapId con) out_inst_tys)
- val_args
- in
- returnDs (mkSimpleMatch [mkPrefixConPat con (map nlVarPat arg_ids) record_in_ty] rhs)
- in
- -- Record stuff doesn't work for existentials
+ | otherwise
+ = -- Record stuff doesn't work for existentials
-- The type checker checks for this, but we need
-- worry only about the constructors that are to be updated
- ASSERT2( all isVanillaDataCon cons_to_upd, ppr expr )
+ ASSERT2( notNull cons_to_upd && all isVanillaDataCon cons_to_upd, ppr expr )
+
+ do { record_expr' <- dsLExpr record_expr
+ ; let -- Awkwardly, for families, the match goes
+ -- from instance type to family type
+ tycon = dataConTyCon (head cons_to_upd)
+ in_ty = mkTyConApp tycon in_inst_tys
+ in_out_ty = mkFunTy in_ty
+ (mkFamilyTyConApp tycon out_inst_tys)
+
+ mk_val_arg field old_arg_id
+ = case findField fields field of
+ (rhs:rest) -> ASSERT(null rest) rhs
+ [] -> nlHsVar old_arg_id
+
+ mk_alt con
+ = ASSERT( isVanillaDataCon con )
+ do { arg_ids <- newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys)
+ -- 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)
+ (nlHsTyApp (dataConWrapId con) out_inst_tys)
+ val_args
+ pat = mkPrefixConPat con (map nlVarPat arg_ids) in_ty
+
+ ; return (mkSimpleMatch [pat] rhs) }
-- It's important to generate the match with matchWrapper,
-- and the right hand sides with applications of the wrapper Id
-- so that everything works when we are doing fancy unboxing on the
-- constructor aguments.
- mappM mk_alt cons_to_upd `thenDs` \ alts ->
- matchWrapper RecUpd (MatchGroup alts in_out_ty) `thenDs` \ ([discrim_var], matching_code) ->
-
- returnDs (bindNonRec discrim_var record_expr' matching_code)
+ ; alts <- mapM mk_alt cons_to_upd
+ ; ([discrim_var], matching_code) <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
- where
- updated_fields :: [FieldLabel]
- updated_fields = [ idName sel_id | (L _ sel_id,_) <- rbinds]
-
- -- Get the type constructor from the record_in_ty
- -- so that we are sure it'll have all its DataCons
- -- (In GHCI, it's possible that some TyCons may not have all
- -- their constructors, in a module-loop situation.)
- tycon = tcTyConAppTyCon record_in_ty
- data_cons = tyConDataCons tycon
- cons_to_upd = filter has_all_fields data_cons
-
- has_all_fields :: DataCon -> Bool
- has_all_fields con_id
- = all (`elem` con_fields) updated_fields
- where
- con_fields = dataConFieldLabels con_id
+ ; return (bindNonRec discrim_var record_expr' matching_code) }
\end{code}
Here is where we desugar the Template Haskell brackets and escapes
dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
\end{code}
+Hpc Support
+
+\begin{code}
+dsExpr (HsTick ix vars e) = do
+ e' <- dsLExpr e
+ mkTickBox ix vars 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}
dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
#endif
+
+findField :: [HsRecField Id arg] -> Name -> [arg]
+findField rbinds lbl
+ = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
+ , lbl == idName (unLoc id) ]
\end{code}
%--------------------------------------------------------------------
go (LetStmt binds : stmts)
= do { rest <- go stmts
; dsLocalBinds binds rest }
-
+
go (BindStmt pat rhs bind_op fail_op : stmts)
- = do { body <- go stmts
+ =
+ do { body <- go stmts
; var <- selectSimpleMatchVarL pat
; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
result_ty (cantFailMatchResult body)
; match_code <- handle_failure pat match fail_op
- ; rhs' <- dsLExpr rhs
+ ; rhs' <- dsLExpr rhs
; bind_op' <- dsExpr bind_op
; returnDs (mkApps bind_op' [rhs', Lam var match_code]) }
projects / ghc-hetmet.git / blobdiff