%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[DsExpr]{Matching expressions (Exprs)}
+
+Desugaring exporessions.
\begin{code}
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
+-- 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 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(..) )
-#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 ( 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 DynFlags
+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}
-------------------------
dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
-dsValBinds (ValBindsOut binds _) body = foldrDs ds_val_bind body binds
+dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
-------------------------
+dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
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
- ; foldrDs ds_ip_bind inner ip_binds }
+ ; let inner = Let (Rec prs) body
+ -- The dict bindings may not be in
+ -- dependency order; hence Rec
+ ; foldrM ds_ip_bind inner ip_binds }
where
ds_ip_bind (L _ (IPBind n e)) body
- = dsLExpr e `thenDs` \ e' ->
- returnDs (Let (NonRec (ipNameName n) e') body)
+ = do e' <- dsLExpr e
+ return (Let (NonRec (ipNameName n) e') body)
-------------------------
ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
-- 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) ->
- ASSERT( null args ) -- Functions aren't lifted
- ASSERT( isIdCoercion co_fn )
- returnDs (bindNonRec fun rhs body_w_exports)
+ FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn,
+ fun_tick = tick, fun_infix = inf }
+ -> do (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
+ MASSERT( null args ) -- Functions aren't lifted
+ MASSERT( isIdHsWrapper co_fn )
+ rhs' <- mkOptTickBox tick rhs
+ return (bindNonRec fun rhs' body_w_exports)
PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
-> -- let C x# y# = rhs in body
-- ==> case rhs of C x# y# -> body
putSrcSpanDs loc $
- do { rhs <- dsGuarded grhss ty
- ; let upat = unLoc pat
- eqn = EqnInfo { eqn_wrap = idWrapper, eqn_pats = [upat],
- eqn_rhs = cantFailMatchResult body_w_exports }
- ; var <- selectMatchVar upat ty
- ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
- ; return (scrungleMatch var rhs result) }
+ do { rhs <- dsGuarded grhss ty
+ ; let upat = unLoc pat
+ eqn = EqnInfo { eqn_pats = [upat],
+ eqn_rhs = cantFailMatchResult body_w_exports }
+ ; var <- selectMatchVar upat
+ ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
+ ; return (scrungleMatch var rhs result) }
- other -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
+ _ -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
-- Ordinary case for bindings; none should be unlifted
-ds_val_bind (is_rec, binds) body
+ds_val_bind (_is_rec, binds) body
= do { prs <- dsLHsBinds binds
; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
case prs of
- [] -> return body
- other -> return (Let (Rec prs) body) }
+ [] -> return body
+ _ -> return (Let (Rec prs) body) }
-- Use a Rec regardless of is_rec.
-- Why? Because it allows the binds to be all
-- mixed up, which is what happens in one rare case
isUnboxedTupleBind :: HsBind Id -> Bool
isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
-isUnboxedTupleBind other = False
+isUnboxedTupleBind _ = False
scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
-- Returns something like (let var = scrut 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}
+
+\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 (HsVar var) = return (Var var)
+dsExpr (HsIPVar ip) = return (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
- ; core_neg <- dsExpr neg_expr
- ; return (core_neg `App` core_expr) }
-
-dsExpr expr@(HsLam a_Match)
- = matchWrapper LambdaExpr a_Match `thenDs` \ (binders, matching_code) ->
- returnDs (mkLams binders matching_code)
-
-#if defined(GHCI) && defined(BREAKPOINT)
-dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _)
- | HsVar funId <- fun
- , idName funId `elem` [breakpointJumpName, breakpointCondJumpName]
- , ids <- filter (not.hasTyVar.idType) (extractIds arg)
- = do dsWarn (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)
- | TyApp arg' ts <- unLoc arg
- , HsVar argId <- unLoc arg'
- = error (showSDoc (ppr ts)) -- argId:extractIds (unLoc fn)
- extractIds x = []
- extractHVals ids = ExplicitList unitTy (map (L loc . HsVar) ids)
- hasTyVar (TyVarTy _) = True
- hasTyVar (FunTy a b) = hasTyVar a || hasTyVar b
- hasTyVar (NoteTy _ t) = hasTyVar t
- hasTyVar (AppTy a b) = hasTyVar a || hasTyVar b
- hasTyVar (TyConApp _ ts) = any hasTyVar ts
- hasTyVar _ = False
-#endif
+ = App <$> dsExpr neg_expr <*> dsLExpr expr
+
+dsExpr (HsLam a_Match)
+ = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
-dsExpr expr@(HsApp fun arg)
- = dsLExpr fun `thenDs` \ core_fun ->
- dsLExpr arg `thenDs` \ core_arg ->
- returnDs (core_fun `App` core_arg)
+dsExpr (HsApp fun arg)
+ = mkDsApp <$> dsLExpr fun <*> dsLExpr arg
\end{code}
Operator sections. At first it looks as if we can convert
\begin{code}
dsExpr (OpApp e1 op _ e2)
- = dsLExpr op `thenDs` \ core_op ->
- -- 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])
+ = -- for the type of y, we need the type of op's 2nd argument
+ mkDsApps <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
-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)
+ = mkDsApp <$> dsLExpr op <*> dsLExpr expr
-- dsLExpr (SectionR op expr) -- \ x -> op x expr
-dsExpr (SectionR op expr)
- = dsLExpr op `thenDs` \ core_op ->
+dsExpr (SectionR op expr) = do
+ core_op <- dsLExpr op
-- for the type of x, we need the type of op's 2nd argument
- let
- (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
- -- See comment with SectionL
- in
- dsLExpr expr `thenDs` \ y_core ->
- newSysLocalDs x_ty `thenDs` \ x_id ->
- newSysLocalDs y_ty `thenDs` \ y_id ->
-
- returnDs (bindNonRec y_id y_core $
- Lam x_id (mkApps core_op [Var x_id, Var y_id]))
+ let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
+ -- See comment with SectionL
+ y_core <- dsLExpr expr
+ x_id <- newSysLocalDs x_ty
+ y_id <- newSysLocalDs y_ty
+ return (bindNonRec y_id y_core $
+ Lam x_id (mkDsApps core_op [Var x_id, Var y_id]))
-dsExpr (HsSCC cc expr)
- = dsLExpr expr `thenDs` \ core_expr ->
- getModuleDs `thenDs` \ mod_name ->
- returnDs (Note (SCC (mkUserCC cc mod_name)) core_expr)
+dsExpr (HsSCC cc expr) = do
+ mod_name <- getModuleDs
+ Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
-- hdaume: core annotation
dsExpr (HsCoreAnn fs expr)
- = dsLExpr expr `thenDs` \ core_expr ->
- returnDs (Note (CoreNote $ unpackFS fs) core_expr)
+ = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
-dsExpr (HsCase discrim matches)
- = dsLExpr discrim `thenDs` \ core_discrim ->
- matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) ->
- returnDs (scrungleMatch discrim_var core_discrim matching_code)
+dsExpr (HsCase discrim matches) = do
+ core_discrim <- dsLExpr discrim
+ ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
+ return (scrungleMatch discrim_var core_discrim matching_code)
-dsExpr (HsLet binds body)
- = dsLExpr body `thenDs` \ body' ->
+-- 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) = do
+ body' <- dsLExpr body
dsLocalBinds binds body'
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
[elt_ty] = tcTyConAppArgs result_ty
dsExpr (HsIf guard_expr then_expr else_expr)
- = dsLExpr guard_expr `thenDs` \ core_guard ->
- dsLExpr then_expr `thenDs` \ core_then ->
- dsLExpr else_expr `thenDs` \ core_else ->
- returnDs (mkIfThenElse core_guard core_then core_else)
-\end{code}
-
-
-\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)
+ = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr
\end{code}
\underline{\bf Various data construction things}
% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-dsExpr (ExplicitList ty xs)
- = go xs
- where
- go [] = returnDs (mkNilExpr ty)
- go (x:xs) = dsLExpr x `thenDs` \ core_x ->
- go xs `thenDs` \ core_xs ->
- returnDs (mkConsExpr ty core_x core_xs)
+dsExpr (ExplicitList elt_ty xs)
+ = dsExplicitList elt_ty xs
-- we create a list from the array elements and convert them into a list using
-- `PrelPArr.toP'
-- that we can exploit the fact that we already know the length of the array
-- here at compile time
--
-dsExpr (ExplicitPArr ty xs)
- = dsLookupGlobalId toPName `thenDs` \toP ->
- dsExpr (ExplicitList ty xs) `thenDs` \coreList ->
- returnDs (mkApps (Var toP) [Type ty, coreList])
+dsExpr (ExplicitPArr ty xs) = do
+ toP <- dsLookupGlobalId toPName
+ coreList <- dsExpr (ExplicitList ty xs)
+ return (mkApps (Var toP) [Type ty, coreList])
-dsExpr (ExplicitTuple expr_list boxity)
- = mappM dsLExpr expr_list `thenDs` \ core_exprs ->
- returnDs (mkConApp (tupleCon boxity (length expr_list))
- (map (Type . exprType) core_exprs ++ core_exprs))
+dsExpr (ExplicitTuple expr_list boxity) = do
+ core_exprs <- mapM dsLExpr expr_list
+ return (mkConApp (tupleCon boxity (length expr_list))
+ (map (Type . exprType) core_exprs ++ core_exprs))
dsExpr (ArithSeq expr (From from))
- = dsExpr expr `thenDs` \ expr2 ->
- dsLExpr from `thenDs` \ from2 ->
- returnDs (App expr2 from2)
+ = App <$> dsExpr expr <*> dsLExpr from
-dsExpr (ArithSeq expr (FromTo from two))
- = dsExpr expr `thenDs` \ expr2 ->
- dsLExpr from `thenDs` \ from2 ->
- dsLExpr two `thenDs` \ two2 ->
- returnDs (mkApps expr2 [from2, two2])
+dsExpr (ArithSeq expr (FromTo from to))
+ = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
dsExpr (ArithSeq expr (FromThen from thn))
- = dsExpr expr `thenDs` \ expr2 ->
- dsLExpr from `thenDs` \ from2 ->
- dsLExpr thn `thenDs` \ thn2 ->
- returnDs (mkApps expr2 [from2, thn2])
-
-dsExpr (ArithSeq expr (FromThenTo from thn two))
- = dsExpr expr `thenDs` \ expr2 ->
- dsLExpr from `thenDs` \ from2 ->
- dsLExpr thn `thenDs` \ thn2 ->
- dsLExpr two `thenDs` \ two2 ->
- returnDs (mkApps expr2 [from2, thn2, two2])
-
-dsExpr (PArrSeq expr (FromTo from two))
- = dsExpr expr `thenDs` \ expr2 ->
- dsLExpr from `thenDs` \ from2 ->
- dsLExpr two `thenDs` \ two2 ->
- returnDs (mkApps expr2 [from2, two2])
-
-dsExpr (PArrSeq expr (FromThenTo from thn two))
- = dsExpr expr `thenDs` \ expr2 ->
- dsLExpr from `thenDs` \ from2 ->
- dsLExpr thn `thenDs` \ thn2 ->
- dsLExpr two `thenDs` \ two2 ->
- returnDs (mkApps expr2 [from2, thn2, two2])
-
-dsExpr (PArrSeq expr _)
+ = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
+
+dsExpr (ArithSeq expr (FromThenTo from thn to))
+ = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
+
+dsExpr (PArrSeq expr (FromTo from to))
+ = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
+
+dsExpr (PArrSeq expr (FromThenTo from thn to))
+ = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
+
+dsExpr (PArrSeq _ _)
= panic "DsExpr.dsExpr: Infinite parallel array!"
-- the parser shouldn't have generated it and the renamer and typechecker
-- shouldn't have let it through
constructor @C@, setting all of @C@'s fields to bottom.
\begin{code}
-dsExpr (RecordCon (L _ data_con_id) con_expr rbinds)
- = dsExpr con_expr `thenDs` \ con_expr' ->
+dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
+ con_expr' <- dsExpr con_expr
let
- (arg_tys, _) = tcSplitFunTys (exprType con_expr')
- -- A newtype in the corner should be opaque;
- -- 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
- (rhs:rhss) -> ASSERT( null rhss )
- dsLExpr rhs
- [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
- unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty ""
-
- labels = dataConFieldLabels (idDataCon data_con_id)
- -- The data_con_id is guaranteed to be the wrapper id of the constructor
- in
-
- (if null labels
- then mappM unlabelled_bottom arg_tys
- else mappM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels))
- `thenDs` \ con_args ->
-
- returnDs (mkApps con_expr' con_args)
+ (arg_tys, _) = tcSplitFunTys (exprType con_expr')
+ -- A newtype in the corner should be opaque;
+ -- hence TcType.tcSplitFunTys
+
+ mk_arg (arg_ty, lbl) -- Selector id has the field label as its name
+ = case findField (rec_flds rbinds) lbl of
+ (rhs:rhss) -> ASSERT( null rhss )
+ dsLExpr rhs
+ [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
+ unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty ""
+
+ labels = dataConFieldLabels (idDataCon data_con_id)
+ -- The data_con_id is guaranteed to be the wrapper id of the constructor
+
+ con_args <- if null labels
+ then mapM unlabelled_bottom arg_tys
+ else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
+
+ return (mkApps con_expr' con_args)
\end{code}
Record update is a little harder. Suppose we have the decl:
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
- = 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
- in
- returnDs (mkSimpleMatch [noLoc $ ConPatOut (noLoc con) [] [] emptyLHsBinds
- (PrefixCon (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)
-
- 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
-\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)
+ ; alts <- mapM mk_alt cons_to_upd
+ ; ([discrim_var], matching_code) <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
-dsExpr (HsCoerce co_fn e) = dsCoercion co_fn (dsExpr e)
+ ; 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}
%--------------------------------------------------------------------
+Note [Desugaring explicit lists]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Explicit lists are desugared in a cleverer way to prevent some
+fruitless allocations. Essentially, whenever we see a list literal
+[x_1, ..., x_n] we:
+
+1. Find the tail of the list that can be allocated statically (say
+ [x_k, ..., x_n]) by later stages and ensure we desugar that
+ normally: this makes sure that we don't cause a code size increase
+ by having the cons in that expression fused (see later) and hence
+ being unable to statically allocate any more
+
+2. For the prefix of the list which cannot be allocated statically,
+ say [x_1, ..., x_(k-1)], we turn it into an expression involving
+ build so that if we find any foldrs over it it will fuse away
+ entirely!
+
+ So in this example we will desugar to:
+ build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
+
+ If fusion fails to occur then build will get inlined and (since we
+ defined a RULE for foldr (:) []) we will get back exactly the
+ normal desugaring for an explicit list.
+
+This optimisation can be worth a lot: up to 25% of the total
+allocation in some nofib programs. Specifically
+
+ Program Size Allocs Runtime CompTime
+ rewrite +0.0% -26.3% 0.02 -1.8%
+ ansi -0.3% -13.8% 0.00 +0.0%
+ lift +0.0% -8.7% 0.00 -2.3%
+
+Of course, if rules aren't turned on then there is pretty much no
+point doing this fancy stuff, and it may even be harmful.
+\begin{code}
+
+dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
+-- See Note [Desugaring explicit lists]
+dsExplicitList elt_ty xs = do
+ dflags <- getDOptsDs
+ xs' <- mapM dsLExpr xs
+ if not (dopt Opt_RewriteRules dflags)
+ then return $ mkListExpr elt_ty xs'
+ else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
+ where
+ mkSplitExplicitList this_package xs' (c, _) (n, n_ty) = do
+ let (dynamic_prefix, static_suffix) = spanTail (rhsIsStatic this_package) xs'
+ static_suffix' = mkListExpr elt_ty static_suffix
+
+ folded_static_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) static_suffix'
+ let build_body = foldr (App . App (Var c)) folded_static_suffix dynamic_prefix
+ return build_body
+
+spanTail :: (a -> Bool) -> [a] -> ([a], [a])
+spanTail f xs = (reverse rejected, reverse satisfying)
+ where (satisfying, rejected) = span f $ reverse xs
+\end{code}
+
Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
handled in DsListComp). Basically does the translation given in the
Haskell 98 report:
-> Type -- Type of the whole expression
-> DsM CoreExpr
-dsDo stmts body result_ty
+dsDo stmts body _result_ty
= go (map unLoc stmts)
where
go [] = dsLExpr body
= do { rhs2 <- dsLExpr rhs
; then_expr2 <- dsExpr then_expr
; rest <- go stmts
- ; returnDs (mkApps then_expr2 [rhs2, rest]) }
+ ; return (mkApps then_expr2 [rhs2, rest]) }
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
+ ; rhs' <- dsLExpr rhs
+ ; bind_op' <- dsExpr bind_op
; var <- selectSimpleMatchVarL pat
+ ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
+ res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
- result_ty (cantFailMatchResult body)
+ res1_ty (cantFailMatchResult body)
; match_code <- handle_failure pat match fail_op
- ; rhs' <- dsLExpr rhs
- ; bind_op' <- dsExpr bind_op
- ; returnDs (mkApps bind_op' [rhs', Lam var match_code]) }
+ ; return (mkApps bind_op' [rhs', Lam var match_code]) }
-- In a do expression, pattern-match failure just calls
-- the monadic 'fail' rather than throwing an exception
| otherwise
= extractMatchResult match (error "It can't fail")
+mk_fail_msg :: Located e -> String
mk_fail_msg pat = "Pattern match failure in do expression at " ++
showSDoc (ppr (getLoc pat))
\end{code}
go (ExprStmt rhs _ rhs_ty : stmts)
= do { rhs2 <- dsLExpr rhs
; rest <- go stmts
- ; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
+ ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
go (BindStmt pat rhs _ _ : stmts)
= do { body <- go stmts
; match_code <- extractMatchResult match fail_expr
; rhs' <- dsLExpr rhs
- ; returnDs (mkApps (Var bind_id) [Type (hsPatType pat), Type b_ty,
+ ; return (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