X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsExpr.lhs;h=e8e9e7b37000c4cf0b7548afac96cd9535a9a984;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=9c1bcdf0473cf40f25ef7959cb000b7f2595cde0;hpb=d551dbfef0b710f5ede21ee0c54ee7e80dd53b64;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 9c1bcdf..e8e9e7b 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -4,19 +4,26 @@ \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 @@ -26,25 +33,24 @@ import DsMeta ( dsBracket ) #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 ) @@ -53,7 +59,6 @@ import PrelNames ( toPName, mfixName ) import SrcLoc ( Located(..), unLoc, getLoc, noLoc ) import Util ( zipEqual, zipWithEqual ) -import Maybe ( fromJust ) import Bag ( bagToList ) import Outputable import FastString @@ -62,75 +67,82 @@ 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 @@ -141,6 +153,35 @@ dsBindGroup body (HsBindGroup binds sigs is_rec) -- -- 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} %************************************************************************ @@ -171,6 +212,36 @@ 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 == 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 -> @@ -248,24 +319,14 @@ dsExpr (HsCoreAnn fs expr) = 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. @@ -421,8 +482,8 @@ dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) [] -> 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 @@ -476,7 +537,7 @@ dsExpr expr@(RecordUpd record_expr rbinds record_in_ty record_out_ty) 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 @@ -540,6 +601,8 @@ dsExpr (DictLam dictvars 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 @@ -591,7 +654,7 @@ dsDo stmts body result_ty 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 @@ -646,7 +709,7 @@ dsMDo tbl stmts body result_ty go (LetStmt binds : stmts) = do { rest <- go stmts - ; dsLet binds rest } + ; dsLocalBinds binds rest } go (ExprStmt rhs _ rhs_ty : stmts) = do { rhs2 <- dsLExpr rhs @@ -672,7 +735,7 @@ dsMDo tbl stmts body result_ty 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) @@ -710,7 +773,7 @@ dsMDo tbl stmts body result_ty 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