X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsUtils.lhs;h=cf670cdf3790b29ad3792265e7568a53da5734da;hb=779da8c0c28d06746b672a9bf113fe29d690a081;hp=27e0be4d38fd7c7d176e748e000904dee9b1f0b0;hpb=67cb409159fa9136dff942b8baaec25909416022;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 27e0be4..cf670cd 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -27,6 +27,7 @@ module DsUtils ( mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr, mkIntExpr, mkCharExpr, mkStringExpr, mkStringExprFS, mkIntegerExpr, + mkBuildExpr, mkFoldrExpr, seqVar, @@ -100,17 +101,17 @@ dsSyntaxTable :: SyntaxTable Id -> DsM ([CoreBind], -- Auxiliary bindings [(Name,Id)]) -- Maps the standard name to its value -dsSyntaxTable rebound_ids - = mapAndUnzipDs mk_bind rebound_ids `thenDs` \ (binds_s, prs) -> +dsSyntaxTable rebound_ids = do + (binds_s, prs) <- mapAndUnzipM mk_bind rebound_ids return (concat binds_s, prs) where - -- The cheapo special case can happen when we - -- make an intermediate HsDo when desugaring a RecStmt + -- The cheapo special case can happen when we + -- make an intermediate HsDo when desugaring a RecStmt mk_bind (std_name, HsVar id) = return ([], (std_name, id)) - mk_bind (std_name, expr) - = dsExpr expr `thenDs` \ rhs -> - newSysLocalDs (exprType rhs) `thenDs` \ id -> - return ([NonRec id rhs], (std_name, id)) + mk_bind (std_name, expr) = do + rhs <- dsExpr expr + id <- newSysLocalDs (exprType rhs) + return ([NonRec id rhs], (std_name, id)) lookupEvidence :: [(Name, Id)] -> Name -> Id lookupEvidence prs std_name @@ -270,43 +271,41 @@ matchCanFail (MatchResult CanFail _) = True matchCanFail (MatchResult CantFail _) = False alwaysFailMatchResult :: MatchResult -alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail) +alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail) cantFailMatchResult :: CoreExpr -> MatchResult -cantFailMatchResult expr = MatchResult CantFail (\_ -> returnDs expr) +cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr) extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr extractMatchResult (MatchResult CantFail match_fn) _ = match_fn (error "It can't fail!") -extractMatchResult (MatchResult CanFail match_fn) fail_expr - = mkFailurePair fail_expr `thenDs` \ (fail_bind, if_it_fails) -> - match_fn if_it_fails `thenDs` \ body -> - returnDs (mkDsLet fail_bind body) +extractMatchResult (MatchResult CanFail match_fn) fail_expr = do + (fail_bind, if_it_fails) <- mkFailurePair fail_expr + body <- match_fn if_it_fails + return (mkDsLet fail_bind body) combineMatchResults :: MatchResult -> MatchResult -> MatchResult combineMatchResults (MatchResult CanFail body_fn1) - (MatchResult can_it_fail2 body_fn2) + (MatchResult can_it_fail2 body_fn2) = MatchResult can_it_fail2 body_fn where - body_fn fail = body_fn2 fail `thenDs` \ body2 -> - mkFailurePair body2 `thenDs` \ (fail_bind, duplicatable_expr) -> - body_fn1 duplicatable_expr `thenDs` \ body1 -> - returnDs (Let fail_bind body1) + body_fn fail = do body2 <- body_fn2 fail + (fail_bind, duplicatable_expr) <- mkFailurePair body2 + body1 <- body_fn1 duplicatable_expr + return (Let fail_bind body1) combineMatchResults match_result1@(MatchResult CantFail _) _ = match_result1 adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult adjustMatchResult encl_fn (MatchResult can_it_fail body_fn) - = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body -> - returnDs (encl_fn body)) + = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail) adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn) - = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body -> - encl_fn body) + = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail) wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr wrapBinds [] e = e @@ -337,8 +336,8 @@ mkEvalMatchResult var ty mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult mkGuardedMatchResult pred_expr (MatchResult _ body_fn) - = MatchResult CanFail (\fail -> body_fn fail `thenDs` \ body -> - returnDs (mkIfThenElse pred_expr body fail)) + = MatchResult CanFail (\fail -> do body <- body_fn fail + return (mkIfThenElse pred_expr body fail)) mkCoPrimCaseMatchResult :: Id -- Scrutinee -> Type -- Type of the case @@ -347,13 +346,13 @@ mkCoPrimCaseMatchResult :: Id -- Scrutinee mkCoPrimCaseMatchResult var ty match_alts = MatchResult CanFail mk_case where - mk_case fail - = mappM (mk_alt fail) sorted_alts `thenDs` \ alts -> - returnDs (Case (Var var) var ty ((DEFAULT, [], fail) : alts)) + mk_case fail = do + alts <- mapM (mk_alt fail) sorted_alts + return (Case (Var var) var ty ((DEFAULT, [], fail) : alts)) sorted_alts = sortWith fst match_alts -- Right order for a Case - mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body -> - returnDs (LitAlt lit, [], body) + mk_alt fail (lit, MatchResult _ body_fn) = do body <- body_fn fail + return (LitAlt lit, [], body) mkCoAlgCaseMatchResult :: Id -- Scrutinee @@ -394,13 +393,13 @@ mkCoAlgCaseMatchResult var ty match_alts wild_var = mkWildId (idType var) sorted_alts = sortWith get_tag match_alts get_tag (con, _, _) = dataConTag con - mk_case fail = mappM (mk_alt fail) sorted_alts `thenDs` \ alts -> - returnDs (Case (Var var) wild_var ty (mk_default fail ++ alts)) + mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts + return (Case (Var var) wild_var ty (mk_default fail ++ alts)) - mk_alt fail (con, args, MatchResult _ body_fn) - = body_fn fail `thenDs` \ body -> - newUniqueSupply `thenDs` \ us -> - returnDs (mkReboxingAlt (uniqsFromSupply us) con args body) + mk_alt fail (con, args, MatchResult _ body_fn) = do + body <- body_fn fail + us <- newUniqueSupply + return (mkReboxingAlt (uniqsFromSupply us) con args body) mk_default fail | exhaustive_case = [] | otherwise = [(DEFAULT, [], fail)] @@ -439,10 +438,10 @@ mkCoAlgCaseMatchResult var ty match_alts _ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns" isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives" -- - mk_parrCase fail = - dsLookupGlobalId lengthPName `thenDs` \lengthP -> - unboxAlt `thenDs` \alt -> - returnDs (Case (len lengthP) (mkWildId intTy) ty [alt]) + mk_parrCase fail = do + lengthP <- dsLookupGlobalId lengthPName + alt <- unboxAlt + return (Case (len lengthP) (mkWildId intTy) ty [alt]) where elemTy = case splitTyConApp (idType var) of (_, [elemTy]) -> elemTy @@ -450,11 +449,11 @@ mkCoAlgCaseMatchResult var ty match_alts panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?" len lengthP = mkApps (Var lengthP) [Type elemTy, Var var] -- - unboxAlt = - newSysLocalDs intPrimTy `thenDs` \l -> - dsLookupGlobalId indexPName `thenDs` \indexP -> - mappM (mkAlt indexP) sorted_alts `thenDs` \alts -> - returnDs (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts))) + unboxAlt = do + l <- newSysLocalDs intPrimTy + indexP <- dsLookupGlobalId indexPName + alts <- mapM (mkAlt indexP) sorted_alts + return (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts))) where wild = mkWildId intPrimTy dft = (DEFAULT, [], fail) @@ -465,9 +464,9 @@ mkCoAlgCaseMatchResult var ty match_alts -- constructor argument, which are bound to array elements starting -- with the first -- - mkAlt indexP (con, args, MatchResult _ bodyFun) = - bodyFun fail `thenDs` \body -> - returnDs (LitAlt lit, [], mkDsLets binds body) + mkAlt indexP (con, args, MatchResult _ bodyFun) = do + body <- bodyFun fail + return (LitAlt lit, [], mkDsLets binds body) where lit = MachInt $ toInteger (dataConSourceArity con) binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args] @@ -488,14 +487,13 @@ mkErrorAppDs :: Id -- The error function -> String -- The error message string to pass -> DsM CoreExpr -mkErrorAppDs err_id ty msg - = getSrcSpanDs `thenDs` \ src_loc -> +mkErrorAppDs err_id ty msg = do + src_loc <- getSrcSpanDs let - full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg]) - core_msg = Lit (mkStringLit full_msg) - -- mkStringLit returns a result of type String# - in - returnDs (mkApps (Var err_id) [Type ty, core_msg]) + full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg]) + core_msg = Lit (mkStringLit full_msg) + -- mkStringLit returns a result of type String# + return (mkApps (Var err_id) [Type ty, core_msg]) \end{code} @@ -516,58 +514,55 @@ mkIntExpr i = mkConApp intDataCon [mkIntLit i] mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)] mkIntegerExpr i - | inIntRange i -- Small enough, so start from an Int - = dsLookupDataCon smallIntegerDataConName `thenDs` \ integer_dc -> - returnDs (mkSmallIntegerLit integer_dc i) + | inIntRange i -- Small enough, so start from an Int + = do integer_id <- dsLookupGlobalId smallIntegerName + return (mkSmallIntegerLit integer_id i) -- Special case for integral literals with a large magnitude: -- They are transformed into an expression involving only smaller -- integral literals. This improves constant folding. - | otherwise -- Big, so start from a string - = dsLookupGlobalId plusIntegerName `thenDs` \ plus_id -> - dsLookupGlobalId timesIntegerName `thenDs` \ times_id -> - dsLookupDataCon smallIntegerDataConName `thenDs` \ integer_dc -> - let - lit i = mkSmallIntegerLit integer_dc i - plus a b = Var plus_id `App` a `App` b - times a b = Var times_id `App` a `App` b - - -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b - horner :: Integer -> Integer -> CoreExpr - horner b i | abs q <= 1 = if r == 0 || r == i - then lit i - else lit r `plus` lit (i-r) - | r == 0 = horner b q `times` lit b - | otherwise = lit r `plus` (horner b q `times` lit b) - where - (q,r) = i `quotRem` b - - in - returnDs (horner tARGET_MAX_INT i) - -mkSmallIntegerLit :: DataCon -> Integer -> CoreExpr -mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mkIntLit i] + | otherwise = do -- Big, so start from a string + plus_id <- dsLookupGlobalId plusIntegerName + times_id <- dsLookupGlobalId timesIntegerName + integer_id <- dsLookupGlobalId smallIntegerName + let + lit i = mkSmallIntegerLit integer_id i + plus a b = Var plus_id `App` a `App` b + times a b = Var times_id `App` a `App` b + + -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b + horner :: Integer -> Integer -> CoreExpr + horner b i | abs q <= 1 = if r == 0 || r == i + then lit i + else lit r `plus` lit (i-r) + | r == 0 = horner b q `times` lit b + | otherwise = lit r `plus` (horner b q `times` lit b) + where + (q,r) = i `quotRem` b + + return (horner tARGET_MAX_INT i) + +mkSmallIntegerLit :: Id -> Integer -> CoreExpr +mkSmallIntegerLit small_integer i = mkApps (Var small_integer) [mkIntLit i] mkStringExpr str = mkStringExprFS (mkFastString str) mkStringExprFS str | nullFS str - = returnDs (mkNilExpr charTy) + = return (mkNilExpr charTy) | lengthFS str == 1 - = let - the_char = mkCharExpr (headFS str) - in - returnDs (mkConsExpr charTy the_char (mkNilExpr charTy)) + = do let the_char = mkCharExpr (headFS str) + return (mkConsExpr charTy the_char (mkNilExpr charTy)) | all safeChar chars - = dsLookupGlobalId unpackCStringName `thenDs` \ unpack_id -> - returnDs (App (Var unpack_id) (Lit (MachStr str))) + = do unpack_id <- dsLookupGlobalId unpackCStringName + return (App (Var unpack_id) (Lit (MachStr str))) | otherwise - = dsLookupGlobalId unpackCStringUtf8Name `thenDs` \ unpack_id -> - returnDs (App (Var unpack_id) (Lit (MachStr str))) + = do unpack_id <- dsLookupGlobalId unpackCStringUtf8Name + return (App (Var unpack_id) (Lit (MachStr str))) where chars = unpackFS str @@ -603,63 +598,60 @@ mkSelectorBinds :: LPat Id -- The pattern -> DsM [(Id,CoreExpr)] mkSelectorBinds (L _ (VarPat v)) val_expr - = returnDs [(v, val_expr)] + = return [(v, val_expr)] mkSelectorBinds pat val_expr - | isSingleton binders || is_simple_lpat pat - = -- Given p = e, where p binds x,y - -- we are going to make - -- v = p (where v is fresh) - -- x = case v of p -> x - -- y = case v of p -> x - - -- Make up 'v' - -- NB: give it the type of *pattern* p, not the type of the *rhs* e. - -- This does not matter after desugaring, but there's a subtle - -- issue with implicit parameters. Consider - -- (x,y) = ?i - -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque - -- to the desugarer. (Why opaque? Because newtypes have to be. Why - -- does it get that type? So that when we abstract over it we get the - -- right top-level type (?i::Int) => ...) - -- - -- So to get the type of 'v', use the pattern not the rhs. Often more - -- efficient too. - newSysLocalDs (hsLPatType pat) `thenDs` \ val_var -> - - -- For the error message we make one error-app, to avoid duplication. - -- But we need it at different types... so we use coerce for that - mkErrorAppDs iRREFUT_PAT_ERROR_ID - unitTy (showSDoc (ppr pat)) `thenDs` \ err_expr -> - newSysLocalDs unitTy `thenDs` \ err_var -> - mappM (mk_bind val_var err_var) binders `thenDs` \ binds -> - returnDs ( (val_var, val_expr) : - (err_var, err_expr) : - binds ) - - - | otherwise - = mkErrorAppDs iRREFUT_PAT_ERROR_ID - tuple_ty (showSDoc (ppr pat)) `thenDs` \ error_expr -> - matchSimply val_expr PatBindRhs pat local_tuple error_expr `thenDs` \ tuple_expr -> - newSysLocalDs tuple_ty `thenDs` \ tuple_var -> - let - mk_tup_bind binder - = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var)) - in - returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders ) + | isSingleton binders || is_simple_lpat pat = do + -- Given p = e, where p binds x,y + -- we are going to make + -- v = p (where v is fresh) + -- x = case v of p -> x + -- y = case v of p -> x + + -- Make up 'v' + -- NB: give it the type of *pattern* p, not the type of the *rhs* e. + -- This does not matter after desugaring, but there's a subtle + -- issue with implicit parameters. Consider + -- (x,y) = ?i + -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque + -- to the desugarer. (Why opaque? Because newtypes have to be. Why + -- does it get that type? So that when we abstract over it we get the + -- right top-level type (?i::Int) => ...) + -- + -- So to get the type of 'v', use the pattern not the rhs. Often more + -- efficient too. + val_var <- newSysLocalDs (hsLPatType pat) + + -- For the error message we make one error-app, to avoid duplication. + -- But we need it at different types... so we use coerce for that + err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (showSDoc (ppr pat)) + err_var <- newSysLocalDs unitTy + binds <- mapM (mk_bind val_var err_var) binders + return ( (val_var, val_expr) : + (err_var, err_expr) : + binds ) + + + | otherwise = do + error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat)) + tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr + tuple_var <- newSysLocalDs tuple_ty + let + mk_tup_bind binder + = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var)) + return ( (tuple_var, tuple_expr) : map mk_tup_bind binders ) where - binders = collectPatBinders pat + binders = collectPatBinders pat local_tuple = mkBigCoreVarTup binders tuple_ty = exprType local_tuple - mk_bind scrut_var err_var bndr_var + mk_bind scrut_var err_var bndr_var = do -- (mk_bind sv err_var) generates - -- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var } + -- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var } -- Remember, pat binds bv - = matchSimply (Var scrut_var) PatBindRhs pat - (Var bndr_var) error_expr `thenDs` \ rhs_expr -> - returnDs (bndr_var, rhs_expr) + rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat + (Var bndr_var) error_expr + return (bndr_var, rhs_expr) where error_expr = mkCoerce co (Var err_var) co = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var) @@ -668,9 +660,9 @@ mkSelectorBinds pat val_expr is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConPatArgs ps) - is_simple_pat (VarPat _) = True - is_simple_pat (ParPat p) = is_simple_lpat p - is_simple_pat _ = False + is_simple_pat (VarPat _) = True + is_simple_pat (ParPat p) = is_simple_lpat p + is_simple_pat _ = False is_triv_lpat p = is_triv_pat (unLoc p) @@ -922,6 +914,27 @@ mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl] mkListExpr :: Type -> [CoreExpr] -> CoreExpr mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs +mkFoldrExpr :: PostTcType -> PostTcType -> CoreExpr -> CoreExpr -> CoreExpr -> DsM CoreExpr +mkFoldrExpr elt_ty result_ty c n list = do + foldr_id <- dsLookupGlobalId foldrName + return (Var foldr_id `App` Type elt_ty + `App` Type result_ty + `App` c + `App` n + `App` list) + +mkBuildExpr :: Type -> ((Id, Type) -> (Id, Type) -> DsM CoreExpr) -> DsM CoreExpr +mkBuildExpr elt_ty mk_build_inside = do + [n_tyvar] <- newTyVarsDs [alphaTyVar] + let n_ty = mkTyVarTy n_tyvar + c_ty = mkFunTys [elt_ty, n_ty] n_ty + [c, n] <- newSysLocalsDs [c_ty, n_ty] + + build_inside <- mk_build_inside (c, c_ty) (n, n_ty) + + build_id <- dsLookupGlobalId buildName + return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside + mkCoreSel :: [Id] -- The tuple args -> Id -- The selected one -> Id -- A variable of the same type as the scrutinee @@ -1003,15 +1016,15 @@ mkFailurePair :: CoreExpr -- Result type of the whole case expression CoreExpr) -- Either the fail variable, or fail variable -- applied to unit tuple mkFailurePair expr - | isUnLiftedType ty - = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var -> - newSysLocalDs unitTy `thenDs` \ fail_fun_arg -> - returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr), - App (Var fail_fun_var) (Var unitDataConId)) - - | otherwise - = newFailLocalDs ty `thenDs` \ fail_var -> - returnDs (NonRec fail_var expr, Var fail_var) + | isUnLiftedType ty = do + fail_fun_var <- newFailLocalDs (unitTy `mkFunTy` ty) + fail_fun_arg <- newSysLocalDs unitTy + return (NonRec fail_fun_var (Lam fail_fun_arg expr), + App (Var fail_fun_var) (Var unitDataConId)) + + | otherwise = do + fail_var <- newFailLocalDs ty + return (NonRec fail_var expr, Var fail_var) where ty = exprType expr \end{code}