X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsExpr.lhs;h=45b02fb2e99d14f55a8cb0d4da9d7c2973846b18;hb=6aa2bf20adef309cbf6ff39f4989a96ef0338138;hp=d5d718fe7da5a1534f6c7b284a8e632ac621b8d3;hpb=ab46fd8e68f10b6162e77cfc0b216510d9b1d933;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index d5d718f..45b02fb 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -22,7 +22,7 @@ import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, outPat -- So WATCH OUT; check each use of split*Ty functions. -- Sigh. This is a pain. -import TcType ( tcSplitAppTy, tcSplitFunTys, tcSplitTyConApp_maybe, tcTyConAppArgs, +import TcType ( tcSplitAppTy, tcSplitFunTys, tcTyConAppArgs, isIntegerTy, tcSplitTyConApp, isUnLiftedType, Type ) import Type ( splitFunTys ) import CoreSyn @@ -32,8 +32,8 @@ import DsMonad import DsBinds ( dsMonoBinds, AutoScc(..) ) import DsGRHSs ( dsGuarded ) import DsCCall ( dsCCall, resultWrapper ) -import DsListComp ( dsListComp ) -import DsUtils ( mkErrorAppDs, mkDsLets, mkStringLit, mkStringLitFS, +import DsListComp ( dsListComp, dsPArrComp ) +import DsUtils ( mkErrorAppDs, mkStringLit, mkStringLitFS, mkConsExpr, mkNilExpr, mkIntegerLit ) import Match ( matchWrapper, matchSimply ) @@ -46,10 +46,10 @@ import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArg import DataCon ( isExistentialDataCon ) import Literal ( Literal(..) ) import TyCon ( tyConDataCons ) -import TysWiredIn ( tupleCon, listTyCon, charDataCon, intDataCon ) -import BasicTypes ( RecFlag(..), Boxity(..) ) +import TysWiredIn ( tupleCon, charDataCon, intDataCon ) +import BasicTypes ( RecFlag(..), Boxity(..), ipNameName ) import Maybes ( maybeToBool ) -import PrelNames ( hasKey, ratioTyConKey ) +import PrelNames ( hasKey, ratioTyConKey, toPName ) import Util ( zipEqual, zipWithEqual ) import Outputable @@ -85,31 +85,56 @@ dsLet (ThenBinds b1 b2) body dsLet b1 body' -- Special case for bindings which bind unlifted variables +-- We need to do a case right away, rather than building +-- a tuple and doing selections. -- Silently ignore INLINE pragmas... -dsLet (MonoBind (AbsBinds [] [] binder_triples inlines - (PatMonoBind pat grhss loc)) sigs is_rec) body - | or [isUnLiftedType (idType g) | (_, g, l) <- binder_triples] +dsLet bind@(MonoBind (AbsBinds [] [] exports inlines binds) sigs is_rec) body + | or [isUnLiftedType (idType g) | (_, g, l) <- exports] = ASSERT (case is_rec of {NonRecursive -> True; other -> False}) - putSrcLocDs loc $ - dsGuarded grhss `thenDs` \ rhs -> - let - body' = foldr bind body binder_triples - bind (tyvars, g, l) body = ASSERT( null tyvars ) - bindNonRec g (Var l) body - in - mkErrorAppDs iRREFUT_PAT_ERROR_ID result_ty (showSDoc (ppr pat)) - `thenDs` \ error_expr -> - matchSimply rhs PatBindRhs pat body' error_expr + -- Unlifted bindings are always non-recursive + -- and are always a Fun or Pat monobind + -- + -- ToDo: in some bizarre case it's conceivable that there + -- could be dict binds in the 'binds'. (See the notes + -- below. Then pattern-match would fail. Urk.) + case binds of + FunMonoBind fun _ matches loc + -> putSrcLocDs loc $ + matchWrapper (FunRhs fun) matches `thenDs` \ (args, rhs) -> + ASSERT( null args ) -- Functions aren't lifted + returnDs (bindNonRec fun rhs body_w_exports) + + PatMonoBind pat grhss loc + -> putSrcLocDs loc $ + dsGuarded grhss `thenDs` \ rhs -> + mk_error_app pat `thenDs` \ error_expr -> + matchSimply rhs PatBindRhs pat body_w_exports error_expr + + other -> pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) where - result_ty = exprType body + body_w_exports = foldr bind_export body exports + bind_export (tvs, g, l) body = ASSERT( null tvs ) + bindNonRec g (Var l) body + + mk_error_app pat = mkErrorAppDs iRREFUT_PAT_ERROR_ID + (exprType body) + (showSDoc (ppr pat)) -- Ordinary case for bindings dsLet (MonoBind binds sigs is_rec) body = dsMonoBinds NoSccs binds [] `thenDs` \ prs -> - case is_rec of - Recursive -> returnDs (Let (Rec prs) body) - NonRecursive -> returnDs (mkDsLets [NonRec b r | (b,r) <- prs] body) -\end{code} + returnDs (Let (Rec prs) body) + -- Use a Rec regardless of is_rec. + -- Why? Because it allows the MonoBinds to be all + -- mixed up, which is what happens in one rare case + -- Namely, for an AbsBind with no tyvars and no dicts, + -- but which does have dictionary bindings. + -- See notes with TcSimplify.inferLoop [NO TYVARS] + -- It turned out that wrapping a Rec here was the easiest solution + -- + -- NB The previous case dealt with unlifted bindings, so we + -- only have to deal with lifted ones now; so Rec is ok +\end{code} %************************************************************************ %* * @@ -120,9 +145,9 @@ dsLet (MonoBind binds sigs is_rec) body \begin{code} dsExpr :: TypecheckedHsExpr -> DsM CoreExpr -dsExpr (HsVar var) = returnDs (Var var) -dsExpr (HsIPVar var) = returnDs (Var var) -dsExpr (HsLit lit) = dsLit lit +dsExpr (HsVar var) = returnDs (Var var) +dsExpr (HsIPVar ip) = returnDs (Var (ipNameName ip)) +dsExpr (HsLit lit) = dsLit lit -- HsOverLit has been gotten rid of by the type checker dsExpr expr@(HsLam a_Match) @@ -216,7 +241,7 @@ dsExpr (HsCase discrim matches src_loc) returnDs (Case core_discrim bndr alts) _ -> panic ("dsExpr: tuple pattern:\n" ++ showSDoc (ppr matching_code)) where - ubx_tuple_match (Match _ [TuplePat ps Unboxed] _ _) = True + ubx_tuple_match (Match [TuplePat ps Unboxed] _ _) = True ubx_tuple_match _ = False dsExpr (HsCase discrim matches src_loc) @@ -235,29 +260,28 @@ dsExpr (HsWith expr binds) where dsIPBind body (n, e) = dsExpr e `thenDs` \ e' -> - returnDs (Let (NonRec n e') body) + returnDs (Let (NonRec (ipNameName n) e') body) -dsExpr (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty src_loc) - | maybeToBool maybe_list_comp +-- We need the `ListComp' form to use `deListComp' (rather than the "do" form) +-- because the interpretation of `stmts' depends on what sort of thing it is. +-- +dsExpr (HsDoOut ListComp stmts return_id then_id fail_id result_ty src_loc) = -- Special case for list comprehensions putSrcLocDs src_loc $ dsListComp stmts elt_ty + where + (_, [elt_ty]) = tcSplitTyConApp result_ty - | otherwise +dsExpr (HsDoOut DoExpr stmts return_id then_id fail_id result_ty src_loc) = putSrcLocDs src_loc $ - dsDo do_or_lc stmts return_id then_id fail_id result_ty + dsDo DoExpr stmts return_id then_id fail_id result_ty + +dsExpr (HsDoOut PArrComp stmts return_id then_id fail_id result_ty src_loc) + = -- Special case for array comprehensions + putSrcLocDs src_loc $ + dsPArrComp stmts elt_ty where - maybe_list_comp - = case (do_or_lc, tcSplitTyConApp_maybe result_ty) of - (ListComp, Just (tycon, [elt_ty])) - | tycon == listTyCon - -> Just elt_ty - other -> Nothing - -- We need the ListComp form to use deListComp (rather than the "do" form) - -- because the interpretation of ExprStmt depends on what sort of thing - -- it is. - - Just elt_ty = maybe_list_comp + (_, [elt_ty]) = tcSplitTyConApp result_ty dsExpr (HsIf guard_expr then_expr else_expr src_loc) = putSrcLocDs src_loc $ @@ -294,6 +318,21 @@ dsExpr (ExplicitList ty xs) go xs `thenDs` \ core_xs -> returnDs (mkConsExpr ty core_x core_xs) +-- we create a list from the array elements and convert them into a list using +-- `PrelPArr.toP' +-- +-- * the main disadvantage to this scheme is that `toP' traverses the list +-- twice: once to determine the length and a second time to put to elements +-- into the array; this inefficiency could be avoided by exposing some of +-- the innards of `PrelPArr' to the compiler (ie, have a `PrelPArrBase') so +-- that we can exploit the fact that we already know the length of the array +-- here at compile time +-- +dsExpr (ExplicitPArr ty xs) + = dsLookupGlobalValue toPName `thenDs` \toP -> + dsExpr (ExplicitList ty xs) `thenDs` \coreList -> + returnDs (mkApps (Var toP) [Type ty, coreList]) + dsExpr (ExplicitTuple expr_list boxity) = mapDs dsExpr expr_list `thenDs` \ core_exprs -> returnDs (mkConApp (tupleCon boxity (length expr_list)) @@ -322,6 +361,24 @@ dsExpr (ArithSeqOut expr (FromThenTo from thn two)) dsExpr thn `thenDs` \ thn2 -> dsExpr two `thenDs` \ two2 -> returnDs (mkApps expr2 [from2, thn2, two2]) + +dsExpr (PArrSeqOut expr (FromTo from two)) + = dsExpr expr `thenDs` \ expr2 -> + dsExpr from `thenDs` \ from2 -> + dsExpr two `thenDs` \ two2 -> + returnDs (mkApps expr2 [from2, two2]) + +dsExpr (PArrSeqOut expr (FromThenTo from thn two)) + = dsExpr expr `thenDs` \ expr2 -> + dsExpr from `thenDs` \ from2 -> + dsExpr thn `thenDs` \ thn2 -> + dsExpr two `thenDs` \ two2 -> + returnDs (mkApps expr2 [from2, thn2, two2]) + +dsExpr (PArrSeqOut expr _) + = panic "DsExpr.dsExpr: Infinite parallel array!" + -- the parser shouldn't have generated it and the renamer and typechecker + -- shouldn't have let it through \end{code} \noindent @@ -397,7 +454,7 @@ dictionaries. dsExpr (RecordUpdOut record_expr record_in_ty record_out_ty dicts []) = dsExpr record_expr -dsExpr (RecordUpdOut record_expr record_in_ty record_out_ty dicts rbinds) +dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty dicts rbinds) = getSrcLocDs `thenDs` \ src_loc -> dsExpr record_expr `thenDs` \ record_expr' -> @@ -431,7 +488,9 @@ dsExpr (RecordUpdOut record_expr record_in_ty record_out_ty dicts rbinds) src_loc) in -- Record stuff doesn't work for existentials - ASSERT( all (not . isExistentialDataCon) data_cons ) + -- The type checker checks for this, but we need + -- worry only about the constructors that are to be updated + ASSERT2( all (not . isExistentialDataCon) cons_to_upd, ppr expr ) -- It's important to generate the match with matchWrapper, -- and the right hand sides with applications of the wrapper Id @@ -487,6 +546,7 @@ dsExpr (DictApp expr dicts) -- becomes a curried application dsExpr (HsDo _ _ _) = panic "dsExpr:HsDo" dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig" dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn" +dsExpr (PArrSeqIn _) = panic "dsExpr:PArrSeqIn" #endif \end{code} @@ -509,9 +569,9 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty (_, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b) is_do = case do_or_lc of DoExpr -> True - ListComp -> False + _ -> False - -- For ExprStmt, see the comments near HsExpr.HsStmt about + -- For ExprStmt, see the comments near HsExpr.Stmt about -- exactly what ExprStmts mean! -- -- In dsDo we can only see DoStmt and ListComp (no gaurds) @@ -620,6 +680,3 @@ dsLit (HsRat r ty) (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) (head (tyConDataCons tycon), i_ty) \end{code} - - -