\section[DsExpr]{Matching expressions (Exprs)}
\begin{code}
-module DsExpr ( dsExpr, dsLExpr, dsLet, dsLit ) where
+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 )
+import TysWiredIn ( unitTy )
+import TypeRep ( Type(..) )
+#endif
-
-import Match ( matchWrapper, matchSimply, matchSinglePat )
+import Match ( matchWrapper, matchSinglePat, matchEquations )
import MatchLit ( dsLit, dsOverLit )
-import DsBinds ( dsHsNestedBinds )
+import DsBinds ( dsLHsBinds, dsCoercion )
import DsGRHSs ( dsGuarded )
import DsListComp ( dsListComp, dsPArrComp )
import DsUtils ( mkErrorAppDs, mkStringExpr, mkConsExpr, mkNilExpr,
extractMatchResult, cantFailMatchResult, matchCanFail,
- mkCoreTupTy, selectSimpleMatchVarL, lookupEvidence )
+ mkCoreTupTy, selectSimpleMatchVarL, lookupEvidence, selectMatchVar )
import DsArrows ( dsProcExpr )
import DsMonad
#endif
import HsSyn
-import TcHsSyn ( hsPatType )
+import TcHsSyn ( hsPatType, mkVanillaTuplePat )
-- 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,
+import TcType ( tcSplitAppTy, tcSplitFunTys, tcTyConAppTyCon,
tcTyConAppArgs, isUnLiftedType, Type, mkAppTy )
import Type ( funArgTy, splitFunTys, isUnboxedTupleType, mkFunTy )
import CoreSyn
import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
import CostCentre ( mkUserCC )
-import Id ( Id, idType, idName, isDataConWorkId_maybe )
+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 Name ( Name )
import TyCon ( FieldLabel, tyConDataCons )
import TysWiredIn ( tupleCon )
import BasicTypes ( RecFlag(..), Boxity(..), ipNameName )
mfixName )
import SrcLoc ( Located(..), unLoc, getLoc, noLoc )
import Util ( zipEqual, zipWithEqual )
-import Maybe ( fromJust )
import Bag ( bagToList )
import Outputable
import FastString
%************************************************************************
%* *
-\subsection{dsLet}
+ dsLocalBinds, dsValBinds
%* *
%************************************************************************
-@dsLet@ is a match-result transformer, taking the @MatchResult@ for the body
-and transforming it into one for the let-bindings enclosing the body.
-
-This may seem a bit odd, but (source) let bindings can contain unboxed
-binds like
-\begin{verbatim}
- C x# = e
-\end{verbatim}
-This must be transformed to a case expression and, if the type has
-more than one constructor, may fail.
-
\begin{code}
-dsLet :: [HsBindGroup Id] -> CoreExpr -> DsM CoreExpr
-dsLet groups body = foldlDs dsBindGroup body (reverse groups)
-
-dsBindGroup :: CoreExpr -> HsBindGroup Id -> DsM CoreExpr
-dsBindGroup body (HsIPBinds binds)
- = foldlDs dsIPBind body binds
+dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
+dsLocalBinds EmptyLocalBinds body = return body
+dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
+dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body
+
+-------------------------
+dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
+dsValBinds (ValBindsOut binds _) body = foldrDs ds_val_bind body binds
+
+-------------------------
+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 }
where
- dsIPBind body (L _ (IPBind n e))
- = dsLExpr e `thenDs` \ e' ->
- returnDs (Let (NonRec (ipNameName n) e') body)
+ ds_ip_bind (L _ (IPBind n e)) body
+ = dsLExpr e `thenDs` \ e' ->
+ returnDs (Let (NonRec (ipNameName n) e') body)
+-------------------------
+ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
-- Special case for bindings which bind unlifted variables
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
--- Silently ignore INLINE pragmas...
-dsBindGroup body bind@(HsBindGroup hsbinds sigs is_rec)
- | [L _ (AbsBinds [] [] exports inlines binds)] <- bagToList hsbinds,
- or [isUnLiftedType (idType g) | (_, g, l) <- exports]
- = ASSERT (case is_rec of {NonRecursive -> True; other -> False})
- -- Unlifted bindings are always non-recursive
- -- and are always a Fun or Pat monobind
- --
+-- Silently ignore INLINE and SPECIALISE pragmas...
+ds_val_bind (NonRecursive, hsbinds) body
+ | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
+ (L loc bind : null_binds) <- bagToList binds,
+ isBangHsBind bind
+ || isUnboxedTupleBind bind
+ || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
+ = let
+ body_w_exports = foldr bind_export body exports
+ bind_export (tvs, g, l, _) body = ASSERT( null tvs )
+ bindNonRec g (Var l) body
+ in
+ ASSERT (null null_binds)
+ -- Non-recursive, non-overloaded bindings only come in ones
-- ToDo: in some bizarre case it's conceivable that there
-- could be dict binds in the 'binds'. (See the notes
-- below. Then pattern-match would fail. Urk.)
- let
- body_w_exports = foldr bind_export body exports
- bind_export (tvs, g, l) body = ASSERT( null tvs )
- bindNonRec g (Var l) body
-
- mk_error_app pat = mkErrorAppDs iRREFUT_PAT_ERROR_ID
- (exprType body)
- (showSDoc (ppr pat))
- in
- case bagToList binds of
- [L loc (FunBind (L _ fun) _ matches)]
- -> putSrcSpanDs loc $
- matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) ->
+ 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)
- [L loc (PatBind pat grhss ty)]
- -> putSrcSpanDs loc $
- dsGuarded grhss ty `thenDs` \ rhs ->
- mk_error_app pat `thenDs` \ error_expr ->
- matchSimply rhs PatBindRhs pat body_w_exports error_expr
-
- other -> pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
-
--- Ordinary case for bindings
-dsBindGroup body (HsBindGroup binds sigs is_rec)
- = dsHsNestedBinds binds `thenDs` \ prs ->
- returnDs (Let (Rec prs) body)
+ 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) }
+
+ other -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
+
+
+-- Ordinary case for bindings; none should be unlifted
+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) }
-- 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
--
-- NB The previous case dealt with unlifted bindings, so we
-- only have to deal with lifted ones now; so Rec is ok
+
+isUnboxedTupleBind :: HsBind Id -> Bool
+isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
+isUnboxedTupleBind other = False
+
+scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
+-- Returns something like (let var = scrut in body)
+-- but if var is an unboxed-tuple type, it inlines it in a fragile way
+-- Special case to handle unboxed tuple patterns; they can't appear nested
+-- The idea is that
+-- case e of (# p1, p2 #) -> rhs
+-- should desugar to
+-- case e of (# x1, x2 #) -> ... match p1, p2 ...
+-- NOT
+-- let x = e in case x of ....
+--
+-- But there may be a big
+-- let fail = ... in case e of ...
+-- wrapping the whole case, which complicates matters slightly
+-- It all seems a bit fragile. Test is dsrun013.
+
+scrungleMatch var scrut body
+ | isUnboxedTupleType (idType var) = scrungle body
+ | otherwise = bindNonRec var scrut body
+ where
+ scrungle (Case (Var x) bndr ty alts)
+ | 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}
%************************************************************************
= 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 == breakpointJumpName
+ , 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
+
dsExpr expr@(HsApp fun arg)
= dsLExpr fun `thenDs` \ core_fun ->
dsLExpr arg `thenDs` \ core_arg ->
= dsLExpr expr `thenDs` \ core_expr ->
returnDs (Note (CoreNote $ unpackFS fs) core_expr)
--- Special case to handle unboxed tuple patterns; they can't appear nested
-dsExpr (HsCase discrim matches@(MatchGroup _ ty))
- | isUnboxedTupleType (funArgTy ty)
- = dsLExpr discrim `thenDs` \ core_discrim ->
- matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) ->
- case matching_code of
- Case (Var x) bndr ty alts | x == discrim_var ->
- returnDs (Case core_discrim bndr ty alts)
- _ -> panic ("dsLExpr: tuple pattern:\n" ++ showSDoc (ppr matching_code))
-
dsExpr (HsCase discrim matches)
= dsLExpr discrim `thenDs` \ core_discrim ->
matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) ->
- returnDs (bindNonRec discrim_var core_discrim matching_code)
+ returnDs (scrungleMatch discrim_var core_discrim matching_code)
dsExpr (HsLet binds body)
= dsLExpr body `thenDs` \ body' ->
- dsLet binds body'
+ dsLocalBinds binds body'
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
[] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty ""
- labels = dataConFieldLabels (fromJust (isDataConWorkId_maybe data_con_id))
- -- The data_con_id is guaranteed to be the work id of the constructor
+ labels = dataConFieldLabels (idDataCon data_con_id)
+ -- The data_con_id is guaranteed to be the wrapper id of the constructor
in
(if null labels
mk_alt con
= newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids ->
- -- This call to dataConArgTys won't work for existentials
+ -- 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
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
go (LetStmt binds : stmts)
= do { rest <- go stmts
- ; dsLet binds rest }
+ ; dsLocalBinds binds rest }
go (BindStmt pat rhs bind_op fail_op : stmts)
= do { body <- go stmts
go (LetStmt binds : stmts)
= do { rest <- go stmts
- ; dsLet binds rest }
+ ; dsLocalBinds binds rest }
go (ExprStmt rhs _ rhs_ty : stmts)
= do { rhs2 <- dsLExpr rhs
go (new_bind_stmt : let_stmt : stmts)
where
new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
- let_stmt = LetStmt [HsBindGroup binds [] Recursive]
+ let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
-- Remove the later_ids that appear (without fancy coercions)
mk_tup_pat :: [LPat Id] -> LPat Id
mk_tup_pat [p] = p
- mk_tup_pat ps = noLoc $ TuplePat ps Boxed
+ mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
mk_ret_tup [r] = r
projects / ghc-hetmet.git / blobdiff