X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=f5df3ed225042d3533440093de37a4c38688a79d;hb=90dc9026b091be5cca5da4c6cbd3713ecc493361;hp=5ffae6dcf241df8389307b2aacd1d718a69c6f32;hpb=f1c0fd99f16322fe222c6fcf4626a6162ad0a466;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 5ffae6d..f5df3ed 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -1,66 +1,55 @@ % +% (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 #ifdef GHCI +import PrelNames +import DsBreakpoint -- Template Haskell stuff iff bootstrapped -import DsMeta ( dsBracket ) +import DsMeta +#else +import DsBreakpoint #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 TyCon +import TysWiredIn +import BasicTypes +import PrelNames +import SrcLoc +import Util +import Bag import Outputable import FastString \end{code} @@ -118,11 +107,12 @@ ds_val_bind (NonRecursive, hsbinds) 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 @@ -185,6 +175,7 @@ scrungleMatch var scrut 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} %************************************************************************ @@ -195,17 +186,28 @@ scrungleMatch var scrut body \begin{code} dsLExpr :: LHsExpr Id -> DsM CoreExpr + +#if defined(GHCI) +dsLExpr (L loc expr@(HsWrap w (HsVar v))) + | idName v `elem` [breakpointName, breakpointCondName, breakpointAutoName] + = do areBreakpointsEnabled <- breakpoints_enabled + if areBreakpointsEnabled + then do + L _ breakpointExpr <- mkBreakpointExpr loc v + dsLExpr (L loc $ HsWrap w breakpointExpr) + else putSrcSpanDs loc $ dsExpr expr +#endif + 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 (HsCoerce 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 @@ -216,37 +218,6 @@ 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 (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) - | HsCoerce 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 -> @@ -319,8 +290,11 @@ dsExpr (HsCase discrim matches) 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' -> + = (bindLocalsDs (map unLoc $ collectLocalBinders binds) $ + dsAndThenMaybeInsertBreakpoint body) `thenDs` \ body' -> dsLocalBinds binds body' -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) @@ -577,6 +551,26 @@ dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s) 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} @@ -602,25 +596,30 @@ dsDo :: [LStmt Id] dsDo stmts body result_ty = go (map unLoc stmts) where - go [] = dsLExpr body + go [] = dsAndThenMaybeInsertBreakpoint body go (ExprStmt rhs then_expr _ : stmts) - = do { rhs2 <- dsLExpr rhs + = do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs ; then_expr2 <- dsExpr then_expr ; rest <- go stmts ; returnDs (mkApps then_expr2 [rhs2, rest]) } go (LetStmt binds : stmts) - = do { rest <- go stmts + = do { rest <- bindLocalsDs (map unLoc$ collectLocalBinders binds) $ + go stmts ; dsLocalBinds binds rest } - + + -- Notice how due to the placement of bindLocals, binders in this stmt + -- are available in posterior stmts but Not in this one rhs. + -- This is to avoid silliness in breakpoints go (BindStmt pat rhs bind_op fail_op : stmts) - = do { body <- go stmts + = + do { body <- bindLocalsDs (collectPatBinders pat) $ 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' <- dsAndThenMaybeInsertBreakpoint rhs ; bind_op' <- dsExpr bind_op ; returnDs (mkApps bind_op' [rhs', Lam var match_code]) } @@ -670,12 +669,12 @@ dsMDo tbl stmts body result_ty ; dsLocalBinds binds rest } go (ExprStmt rhs _ rhs_ty : stmts) - = do { rhs2 <- dsLExpr rhs + = do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs ; rest <- go stmts ; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) } go (BindStmt pat rhs _ _ : stmts) - = do { body <- go stmts + = do { body <- bindLocalsDs (collectPatBinders pat) $ go stmts ; var <- selectSimpleMatchVarL pat ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat result_ty (cantFailMatchResult body) @@ -683,7 +682,7 @@ dsMDo tbl stmts body result_ty ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg] ; match_code <- extractMatchResult match fail_expr - ; rhs' <- dsLExpr rhs + ; rhs' <- dsAndThenMaybeInsertBreakpoint rhs ; returnDs (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty, rhs', Lam var match_code]) }