X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsArrows.lhs;h=3360a95a976be9fbcf9e672fe001c604f2563c78;hp=d50aa3e5542bc56545c5235d98059b6fb59b1e32;hb=5723262f616ac02ddf637f6ff480a599c737ea0d;hpb=0c72a3ada46ae38fef4d800423ba046f99c119c6 diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index d50aa3e..3360a95 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -34,13 +34,12 @@ import MkCore import Name import Var import Id -import PrelInfo import DataCon import TysWiredIn import BasicTypes import PrelNames import Outputable - +import Bag import VarSet import SrcLoc @@ -149,7 +148,7 @@ mkCorePairExpr e1 e2 = mkCoreTup [e1, e2] The input is divided into a local environment, which is a flat tuple (unless it's too big), and a stack, each element of which is paired -with the stack in turn. In general, the input has the form +with the environment in turn. In general, the input has the form (...((x1,...,xn),s1),...sk) @@ -405,7 +404,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsPar cmd) -- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>> -- c1 ||| c2 -dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd) = do +dsCmd ids local_vars env_ids stack res_ty (HsIf mb_fun cond then_cmd else_cmd) = do core_cond <- dsLExpr cond (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack res_ty then_cmd (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack res_ty else_cmd @@ -413,20 +412,26 @@ dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd) = do either_con <- dsLookupTyCon eitherTyConName left_con <- dsLookupDataCon leftDataConName right_con <- dsLookupDataCon rightDataConName - let - left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e] - right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e] + + let mk_left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e] + mk_right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e] in_ty = envStackType env_ids stack then_ty = envStackType then_ids stack else_ty = envStackType else_ids stack sum_ty = mkTyConApp either_con [then_ty, else_ty] fvs_cond = exprFreeVars core_cond `intersectVarSet` local_vars - - core_if <- matchEnvStack env_ids stack_ids - (mkIfThenElse core_cond - (left_expr then_ty else_ty (buildEnvStack then_ids stack_ids)) - (right_expr then_ty else_ty (buildEnvStack else_ids stack_ids))) + + core_left = mk_left_expr then_ty else_ty (buildEnvStack then_ids stack_ids) + core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_ids) + + core_if <- case mb_fun of + Just fun -> do { core_fun <- dsExpr fun + ; matchEnvStack env_ids stack_ids $ + mkCoreApps core_fun [core_cond, core_left, core_right] } + Nothing -> matchEnvStack env_ids stack_ids $ + mkIfThenElse core_cond core_left core_right + return (do_map_arrow ids in_ty sum_ty res_ty core_if (do_choice ids then_ty else_ty res_ty core_then core_else), @@ -449,19 +454,17 @@ is translated to The idea is to extract the commands from the case, build a balanced tree of choices, and replace the commands with expressions that build tagged tuples, obtaining a case expression that can be desugared normally. -To build all this, we use quadruples decribing segments of the list of +To build all this, we use triples describing segments of the list of case bodies, containing the following fields: -1. an IdSet containing the environment variables free in the case bodies -2. a list of expressions of the form (Left|Right)* ((xs)*ts), to be put + * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put into the case replacing the commands -3. a sum type that is the common type of these expressions, and also the + * a sum type that is the common type of these expressions, and also the input type of the arrow -4. a CoreExpr for an arrow built by combining the translated command + * a CoreExpr for an arrow built by combining the translated command bodies with |||. \begin{code} dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ty)) = do - core_exp <- dsLExpr exp stack_ids <- mapM newSysLocalDs stack -- Extract and desugar the leaf commands in the case, building tuple @@ -470,10 +473,9 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ let leaves = concatMap leavesMatch matches make_branch (leaf, bound_vars) = do - (core_leaf, fvs, leaf_ids) <- + (core_leaf, _fvs, leaf_ids) <- dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf - return (fvs `minusVarSet` bound_vars, - [mkHsEnvStackExpr leaf_ids stack_ids], + return ([mkHsEnvStackExpr leaf_ids stack_ids], envStackType leaf_ids stack, core_leaf) @@ -490,22 +492,19 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ -- Prefix each tuple with a distinct series of Left's and Right's, -- in a balanced way, keeping track of the types. - merge_branches (fvs1, builds1, in_ty1, core_exp1) - (fvs2, builds2, in_ty2, core_exp2) - = (fvs1 `unionVarSet` fvs2, - map (left_expr in_ty1 in_ty2) builds1 ++ + merge_branches (builds1, in_ty1, core_exp1) + (builds2, in_ty2, core_exp2) + = (map (left_expr in_ty1 in_ty2) builds1 ++ map (right_expr in_ty1 in_ty2) builds2, mkTyConApp either_con [in_ty1, in_ty2], do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2) - (fvs_alts, leaves', sum_ty, core_choices) - = foldb merge_branches branches + (leaves', sum_ty, core_choices) = foldb merge_branches branches -- Replace the commands in the case with these tagged tuples, -- yielding a HsExpr Id we can feed to dsExpr. (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches in_ty = envStackType env_ids stack - fvs_exp = exprFreeVars core_exp `intersectVarSet` local_vars pat_ty = funArgTy match_ty match_ty' = mkFunTy pat_ty sum_ty @@ -515,7 +514,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ core_body <- dsExpr (HsCase exp (MatchGroup matches' match_ty')) core_matches <- matchEnvStack env_ids stack_ids core_body return (do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices, - fvs_exp `unionVarSet` fvs_alts) + exprFreeVars core_body `intersectVarSet` local_vars) -- A | ys |- c :: [ts] t -- ---------------------------------- @@ -1029,21 +1028,19 @@ See comments in HsUtils for why the other version does not include these bindings. \begin{code} -collectPatBinders :: OutputableBndr a => LPat a -> [a] +collectPatBinders :: LPat Id -> [Id] collectPatBinders pat = collectl pat [] -collectPatsBinders :: OutputableBndr a => [LPat a] -> [a] +collectPatsBinders :: [LPat Id] -> [Id] collectPatsBinders pats = foldr collectl [] pats --------------------- -collectl :: OutputableBndr a => LPat a -> [a] -> [a] +collectl :: LPat Id -> [Id] -> [Id] -- See Note [Dictionary binders in ConPatOut] collectl (L _ pat) bndrs = go pat where go (VarPat var) = var : bndrs - go (VarPatOut var bs) = var : collectHsBindsBinders bs - ++ bndrs go (WildPat _) = bndrs go (LazyPat pat) = collectl pat bndrs go (BangPat pat) = collectl pat bndrs @@ -1056,7 +1053,7 @@ collectl (L _ pat) bndrs go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps) go (ConPatOut {pat_args=ps, pat_binds=ds}) = - collectHsBindsBinders ds + collectEvBinders ds ++ foldr collectl bndrs (hsConPatArgs ps) go (LitPat _) = bndrs go (NPat _ _ _) = bndrs @@ -1068,4 +1065,13 @@ collectl (L _ pat) bndrs go (CoPat _ pat _) = collectl (noLoc pat) bndrs go (ViewPat _ pat _) = collectl pat bndrs go p@(QuasiQuotePat {}) = pprPanic "collectl/go" (ppr p) + +collectEvBinders :: TcEvBinds -> [Id] +collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs +collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" + +add_ev_bndr :: EvBind -> [Id] -> [Id] +add_ev_bndr (EvBind b _) bs | isId b = b:bs + | otherwise = bs + -- A worry: what about coercion variable binders?? \end{code}