X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsArrows.lhs;h=48700f67730fe95d102574c72950973a8eb83880;hb=6f8ff0bbad3b9fa389c960ad1b5a267a1ae502f1;hp=46a80491ea663b0abc45ee3dac724c642644d2cd;hpb=682cf829945240fffc199bee3fe469131d5bf4b8;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 46a8049..48700f6 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -6,13 +6,6 @@ Desugaring arrow commands \begin{code} -{-# OPTIONS -w #-} --- 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 DsArrows ( dsProcExpr ) where #include "HsVersions.h" @@ -37,15 +30,17 @@ import Type import CoreSyn import CoreFVs import CoreUtils +import MkCore -import Id import Name +import Var +import Id import PrelInfo import DataCon import TysWiredIn import BasicTypes import PrelNames -import Util +import Outputable import VarSet import SrcLoc @@ -147,7 +142,7 @@ coreCasePair scrut_var var1 var2 body \begin{code} mkCorePairTy :: Type -> Type -> Type -mkCorePairTy t1 t2 = mkCoreTupTy [t1, t2] +mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr mkCorePairExpr e1 e2 = mkCoreTup [e1, e2] @@ -222,16 +217,11 @@ matchVarStack env_id (stack_id:stack_ids) body = do \end{code} \begin{code} -mkHsTupleExpr :: [HsExpr Id] -> HsExpr Id -mkHsTupleExpr [e] = e -mkHsTupleExpr es = ExplicitTuple (map noLoc es) Boxed - -mkHsPairExpr :: HsExpr Id -> HsExpr Id -> HsExpr Id -mkHsPairExpr e1 e2 = mkHsTupleExpr [e1, e2] - -mkHsEnvStackExpr :: [Id] -> [Id] -> HsExpr Id +mkHsEnvStackExpr :: [Id] -> [Id] -> LHsExpr Id mkHsEnvStackExpr env_ids stack_ids - = foldl mkHsPairExpr (mkHsTupleExpr (map HsVar env_ids)) (map HsVar stack_ids) + = foldl (\a b -> mkLHsTupleExpr [a,b]) + (mkLHsVarTuple env_ids) + (map nlHsVar stack_ids) \end{code} Translation of arrow abstraction @@ -251,7 +241,7 @@ dsProcExpr dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do meth_ids <- mkCmdEnv ids let locals = mkVarSet (collectPatBinders pat) - (core_cmd, free_vars, env_ids) <- dsfixCmd meth_ids locals [] cmd_ty cmd + (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals [] cmd_ty cmd let env_ty = mkBigCoreVarTupTy env_ids fail_expr <- mkFailExpr ProcExpr env_ty var <- selectSimpleMatchVarL pat @@ -261,6 +251,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do (Lam var match_code) core_cmd return (bindCmdEnv meth_ids proc_code) +dsProcExpr _ c = pprPanic "dsProcExpr" (ppr c) \end{code} Translation of command judgements of the form @@ -268,6 +259,8 @@ Translation of command judgements of the form A | xs |- c :: [ts] t \begin{code} +dsLCmd :: DsCmdEnv -> IdSet -> [Id] -> [Type] -> Type -> LHsCmd Id + -> DsM (CoreExpr, IdSet) dsLCmd ids local_vars env_ids stack res_ty cmd = dsCmd ids local_vars env_ids stack res_ty (unLoc cmd) @@ -294,7 +287,6 @@ dsCmd ids local_vars env_ids stack res_ty let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty - env_ty = mkBigCoreVarTupTy env_ids core_arrow <- dsLExpr arrow core_arg <- dsLExpr arg stack_ids <- mapM newSysLocalDs stack @@ -320,7 +312,6 @@ dsCmd ids local_vars env_ids stack res_ty let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty - env_ty = mkBigCoreVarTupTy env_ids core_arrow <- dsLExpr arrow core_arg <- dsLExpr arg @@ -483,7 +474,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ (core_leaf, fvs, leaf_ids) <- dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf return (fvs `minusVarSet` bound_vars, - [noLoc $ mkHsEnvStackExpr leaf_ids stack_ids], + [mkHsEnvStackExpr leaf_ids stack_ids], envStackType leaf_ids stack, core_leaf) @@ -538,7 +529,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do defined_vars = mkVarSet (map unLoc (collectLocalBinders binds)) local_vars' = local_vars `unionVarSet` defined_vars - (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack res_ty body + (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack res_ty body stack_ids <- mapM newSysLocalDs stack -- build a new environment, plus the stack, using the let bindings core_binds <- dsLocalBinds binds (buildEnvStack env_ids' stack_ids) @@ -573,6 +564,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsTick ix vars expr) = do expr2 <- mkTickBox ix vars expr1 return (expr2,id_set) +dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) + -- A | ys |- c :: [ts] t (ys <= xs) -- --------------------- -- A | xs |- c :: [ts] t ---> arr_ts (\ (xs) -> (ys)) >>> c @@ -642,7 +635,7 @@ dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = do let bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt)) local_vars' = local_vars `unionVarSet` bound_vars - (core_stmts, fv_stmts, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do + (core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts body return (core_stmts, fv_stmts, varSetElems fv_stmts)) (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt @@ -659,6 +652,8 @@ A statement maps one local environment to another, and is represented as an arrow from one tuple type to another. A statement sequence is translated to a composition of such arrows. \begin{code} +dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> [Id] -> LStmt Id + -> DsM (CoreExpr, IdSet) dsCmdLStmt ids local_vars env_ids out_ids cmd = dsCmdStmt ids local_vars env_ids out_ids (unLoc cmd) @@ -784,7 +779,9 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do -- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>> -- arr (\((xs1),(xs2)) -> (xs')) >>> ss' -dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss binds) = do +dsCmdStmt ids local_vars env_ids out_ids + (RecStmt { recS_stmts = stmts, recS_later_ids = later_ids, recS_rec_ids = rec_ids + , recS_rec_rets = rhss, recS_dicts = _binds }) = do let -- ToDo: ****** binds not desugared; ROSS PLEASE FIX ******** env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids env2_ids = varSetElems env2_id_set @@ -831,10 +828,14 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss b return (core_body, env1_id_set `unionVarSet` env2_id_set) +dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) + -- loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>> -- ss >>> -- arr (\ (out_ids) -> ((later_ids),(rhss))) >>> +dsRecCmd :: DsCmdEnv -> VarSet -> [LStmt Id] -> [Var] -> [Var] -> [HsExpr Id] + -> DsM (CoreExpr, VarSet, [Var]) dsRecCmd ids local_vars stmts later_ids rec_ids rhss = do let rec_id_set = mkVarSet rec_ids @@ -924,7 +925,7 @@ dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do let bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt)) local_vars' = local_vars `unionVarSet` bound_vars - (core_stmts, fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts + (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt return (do_compose ids (mkBigCoreVarTupTy env_ids) @@ -934,6 +935,8 @@ dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do core_stmts, fv_stmt) +dsCmdStmts _ _ _ _ [] = panic "dsCmdStmts []" + \end{code} Match a list of expressions against a list of patterns, left-to-right. @@ -949,6 +952,7 @@ matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do match_code <- matchSimplys exps ctxt pats result_expr fail_expr matchSimply exp ctxt pat match_code fail_expr +matchSimplys _ _ _ _ _ = panic "matchSimplys" \end{code} List of leaf expressions, with set of variables bound in each @@ -976,7 +980,7 @@ replaceLeavesMatch -> LMatch Id -- the matches of a case command -> ([LHsExpr Id],-- remaining leaf expressions LMatch Id) -- updated match -replaceLeavesMatch res_ty leaves (L loc (Match pat mt (GRHSs grhss binds))) +replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds))) = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss in @@ -987,8 +991,9 @@ replaceLeavesGRHS -> LGRHS Id -- rhss of a case command -> ([LHsExpr Id],-- remaining leaf expressions LGRHS Id) -- updated GRHS -replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts rhs)) +replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _)) = (leaves, L loc (GRHS stmts leaf)) +replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" \end{code} Balanced fold of a non-empty list. @@ -1023,19 +1028,20 @@ See comments in HsUtils for why the other version does not include these bindings. \begin{code} -collectPatBinders :: LPat a -> [a] +collectPatBinders :: OutputableBndr a => LPat a -> [a] collectPatBinders pat = map unLoc (collectLocatedPatBinders pat) -collectLocatedPatBinders :: LPat a -> [Located a] +collectLocatedPatBinders :: OutputableBndr a => LPat a -> [Located a] collectLocatedPatBinders pat = collectl pat [] -collectPatsBinders :: [LPat a] -> [a] +collectPatsBinders :: OutputableBndr a => [LPat a] -> [a] collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats) -collectLocatedPatsBinders :: [LPat a] -> [Located a] +collectLocatedPatsBinders :: OutputableBndr a => [LPat a] -> [Located a] collectLocatedPatsBinders pats = foldr collectl [] pats --------------------- +collectl :: OutputableBndr a => LPat a -> [Located a] -> [Located a] collectl (L l pat) bndrs = go pat where @@ -1052,7 +1058,7 @@ collectl (L l pat) bndrs go (PArrPat pats _) = foldr collectl bndrs pats go (TuplePat pats _ _) = foldr collectl bndrs pats - go (ConPatIn c ps) = foldr collectl bndrs (hsConPatArgs ps) + go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps) go (ConPatOut {pat_args=ps, pat_binds=ds}) = collectHsBindLocatedBinders ds ++ foldr collectl bndrs (hsConPatArgs ps) @@ -1062,6 +1068,7 @@ collectl (L l pat) bndrs go (SigPatIn pat _) = collectl pat bndrs go (SigPatOut pat _) = collectl pat bndrs - go (TypePat ty) = bndrs - go (CoPat _ pat ty) = collectl (noLoc pat) bndrs + go (TypePat _) = bndrs + go (CoPat _ pat _) = collectl (noLoc pat) bndrs + go p = pprPanic "collectl/go" (ppr p) \end{code}