X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=2512dddc5135e38a3357c4141e9369468677c551;hb=3f888bd95df5154a535673a33fee13cf88c3838e;hp=2eca842eb009d6429e14bea7044e6ac7e2385754;hpb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 2eca842..2512ddd 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -261,6 +261,25 @@ dsExpr (SectionR op expr) = do return (bindNonRec y_id y_core $ Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id])) +dsExpr (ExplicitTuple tup_args boxity) + = do { let go (lam_vars, args) (Missing ty) + -- For every missing expression, we need + -- another lambda in the desugaring. + = do { lam_var <- newSysLocalDs ty + ; return (lam_var : lam_vars, Var lam_var : args) } + go (lam_vars, args) (Present expr) + -- Expressions that are present don't generate + -- lambdas, just arguments. + = do { core_expr <- dsLExpr expr + ; return (lam_vars, core_expr : args) } + + ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args) + -- The reverse is because foldM goes left-to-right + + ; return $ mkCoreLams lam_vars $ + mkConApp (tupleCon boxity (length tup_args)) + (map (Type . exprType) args ++ args) } + dsExpr (HsSCC cc expr) = do mod_name <- getModuleDs Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr @@ -335,11 +354,6 @@ dsExpr (ExplicitPArr ty xs) = do unary fn x = mkApps (Var fn) [Type ty, x] binary fn x y = mkApps (Var fn) [Type ty, x, y] -dsExpr (ExplicitTuple expr_list boxity) = do - core_exprs <- mapM dsLExpr expr_list - return (mkConApp (tupleCon boxity (length expr_list)) - (map (Type . exprType) core_exprs ++ core_exprs)) - dsExpr (ArithSeq expr (From from)) = App <$> dsExpr expr <*> dsLExpr from @@ -662,13 +676,16 @@ dsDo :: [LStmt Id] -> Type -- Type of the whole expression -> DsM CoreExpr -dsDo stmts body _result_ty +dsDo stmts body result_ty = goL stmts where + -- result_ty must be of the form (m b) + (m_ty, _b_ty) = tcSplitAppTy result_ty + goL [] = dsLExpr body - goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go stmt lstmts) + goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - go (ExprStmt rhs then_expr _) stmts + go _ (ExprStmt rhs then_expr _) stmts = do { rhs2 <- dsLExpr rhs ; case tcSplitAppTy_maybe (exprType rhs2) of Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty @@ -677,23 +694,52 @@ dsDo stmts body _result_ty ; rest <- goL stmts ; return (mkApps then_expr2 [rhs2, rest]) } - go (LetStmt binds) stmts + go _ (LetStmt binds) stmts = do { rest <- goL stmts ; dsLocalBinds binds rest } - go (BindStmt pat rhs bind_op fail_op) stmts - = - do { body <- goL stmts - ; rhs' <- dsLExpr rhs - ; bind_op' <- dsExpr bind_op - ; var <- selectSimpleMatchVarL pat - ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2 - res1_ty = funResultTy (funArgTy (funResultTy bind_ty)) - ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat - res1_ty (cantFailMatchResult body) - ; match_code <- handle_failure pat match fail_op - ; return (mkApps bind_op' [rhs', Lam var match_code]) } + go _ (BindStmt pat rhs bind_op fail_op) stmts + = do { body <- goL stmts + ; rhs' <- dsLExpr rhs + ; bind_op' <- dsExpr bind_op + ; var <- selectSimpleMatchVarL pat + ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2 + res1_ty = funResultTy (funArgTy (funResultTy bind_ty)) + ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat + res1_ty (cantFailMatchResult body) + ; match_code <- handle_failure pat match fail_op + ; return (mkApps bind_op' [rhs', Lam var match_code]) } + go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids + , recS_rec_ids = rec_ids, recS_ret_fn = return_op + , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op + , recS_rec_rets = rec_rets, recS_dicts = binds }) stmts + = ASSERT( length rec_ids > 0 ) + goL (new_bind_stmt : let_stmt : stmts) + where + -- returnE <- dsExpr return_id + -- mfixE <- dsExpr mfix_id + new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app + bind_op + noSyntaxExpr -- Tuple cannot fail + + let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] [])) + + tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids + rec_tup_pats = map nlVarPat tup_ids + later_pats = rec_tup_pats + rets = map noLoc rec_rets + + mfix_app = nlHsApp (noLoc mfix_op) mfix_arg + mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] + (mkFunTy tup_ty body_ty)) + mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats + body = noLoc $ HsDo DoExpr rec_stmts return_app body_ty + return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) + body_ty = mkAppTy m_ty tup_ty + tup_ty = mkCoreTupTy (map idType tup_ids) + -- mkCoreTupTy deals with singleton case + -- In a do expression, pattern-match failure just calls -- the monadic 'fail' rather than throwing an exception handle_failure pat match fail_op @@ -760,10 +806,11 @@ dsMDo tbl stmts body result_ty ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty, rhs', Lam var match_code]) } - go loc (RecStmt rec_stmts later_ids rec_ids rec_rets binds) stmts + go loc (RecStmt rec_stmts later_ids rec_ids _ _ _ rec_rets binds) stmts = ASSERT( length rec_ids > 0 ) ASSERT( length rec_ids == length rec_rets ) - goL (new_bind_stmt : let_stmt : stmts) + pprTrace "dsMDo" (ppr later_ids) $ + goL (new_bind_stmt : let_stmt : stmts) where new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] [])) @@ -793,7 +840,7 @@ dsMDo tbl stmts body result_ty -- mkCoreTupTy deals with singleton case return_app = nlHsApp (nlHsTyApp return_id [tup_ty]) - (mk_ret_tup rets) + (mkLHsTupleExpr rets) mk_wild_pat :: Id -> LPat Id mk_wild_pat v = noLoc $ WildPat $ idType v @@ -805,10 +852,6 @@ dsMDo tbl stmts body result_ty mk_tup_pat :: [LPat Id] -> LPat Id mk_tup_pat [p] = p mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed - - mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id - mk_ret_tup [r] = r - mk_ret_tup rs = noLoc $ ExplicitTuple rs Boxed \end{code}