X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsExpr.lhs;h=9030f94c3499e8d429e418dbae5ef4d59ead484d;hb=68afb16743cafd5b7495771d359891c6dfc5a186;hp=9e444150a62b7bc399fdd1f5cb60ec1e4f5e2805;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 9e44415..9030f94 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[DsExpr]{Matching expressions (Exprs)} @@ -8,49 +8,57 @@ module DsExpr ( dsExpr ) where -IMPORT_Trace -- ToDo: rm (debugging) -import Pretty -import Outputable - -import AbsSyn -- the stuff being desugared -import PlainCore -- the output of desugaring; - -- importing this module also gets all the - -- CoreSyn utility functions -import DsMonad -- the monadery used in the desugarer - -import AbsPrel ( mkTupleTy, unitTy, nilDataCon, consDataCon, - charDataCon, charTy, - mkFunTy, mkBuild -- LATER: , foldrId -#ifdef DPH - ,fromDomainId, toDomainId -#endif {- Data Parallel Haskell -} - ) -import PrimKind ( PrimKind(..) ) -- rather ugly import *** ToDo??? -import AbsUniType ( alpha, alpha_tv, beta, beta_tv, splitType, - splitTyArgs, mkTupleTyCon, mkTyVarTy, mkForallTy, - kindFromType, maybeBoxedPrimType, - TyVarTemplate, TyCon, Arity(..), Class, - TauType(..), UniType +import Ubiq +import DsLoop -- partly to get dsBinds, partly to chk dsExpr + +import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), + Match, Qual, HsBinds, Stmt, PolyType ) +import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..), + TypecheckedRecordBinds(..), TypecheckedPat(..) ) -import BasicLit ( mkMachInt, BasicLit(..) ) -import CmdLineOpts ( GlobalSwitch(..), SwitchResult, switchIsOn ) -import CostCentre ( mkUserCC ) -import DsBinds ( dsBinds ) +import CoreSyn + +import DsMonad import DsCCall ( dsCCall ) import DsListComp ( dsListComp ) -import DsUtils ( mkCoAppDs, mkCoConDs, mkCoPrimDs, dsExprToAtom ) -import Id -import IdEnv -import IdInfo +import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom, + mkErrorAppDs, showForErr, EquationInfo, + MatchResult + ) import Match ( matchWrapper ) -import Maybes ( Maybe(..) ) -import TaggedCore ( TaggedBinder(..), unTagBinders ) -import TyVarEnv -import Util - -#ifdef DPH -import DsParZF ( dsParallelZF ) -#endif {- Data Parallel Haskell -} + +import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..), + FormSummary ) +import CoreUtils ( coreExprType, substCoreExpr, argToExpr, + mkCoreIfThenElse, unTagBinders ) +import CostCentre ( mkUserCC ) +import FieldLabel ( fieldLabelType, FieldLabel ) +import Id ( mkTupleCon, idType, nullIdEnv, addOneToIdEnv, + getIdUnfolding, dataConArgTys, dataConFieldLabels, + recordSelectorFieldLabel + ) +import Literal ( mkMachInt, Literal(..) ) +import MagicUFs ( MagicUnfoldingFun ) +import Name ( Name{--O only-} ) +import PprStyle ( PprStyle(..) ) +import PprType ( GenType ) +import PrelInfo ( mkTupleTy, unitTy, nilDataCon, consDataCon, + charDataCon, charTy, rEC_CON_ERROR_ID, + rEC_UPD_ERROR_ID + ) +import Pretty ( ppShow, ppBesides, ppPStr, ppStr ) +import TyCon ( isDataTyCon, isNewTyCon ) +import Type ( splitSigmaTy, splitFunTy, typePrimRep, + getAppDataTyCon, getAppTyCon, applyTy + ) +import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} ) +import Usage ( UVar(..) ) +import Util ( zipEqual, pprError, panic, assertPanic ) + +maybeBoxedPrimType = panic "DsExpr.maybeBoxedPrimType" +splitTyArgs = panic "DsExpr.splitTyArgs" + +mk_nil_con ty = mkCon nilDataCon [] [ty] [] -- micro utility... \end{code} The funny business to do with variables is that we look them up in the @@ -64,9 +72,9 @@ around; if we get hits, we use the value accordingly. %************************************************************************ \begin{code} -dsExpr :: TypecheckedExpr -> DsM PlainCoreExpr +dsExpr :: TypecheckedHsExpr -> DsM CoreExpr -dsExpr (Var var) = dsApp (Var var) [] +dsExpr (HsVar var) = dsApp (HsVar var) [] \end{code} %************************************************************************ @@ -91,98 +99,95 @@ representation decisions are delayed)... See also below where we look for @DictApps@ for \tr{plusInt}, etc. \begin{code} -dsExpr (Lit (StringLit s)) +dsExpr (HsLitOut (HsString s) _) | _NULL_ s - = returnDs ( CoCon nilDataCon [charTy] [] ) + = returnDs (mk_nil_con charTy) | _LENGTH_ s == 1 = let - the_char = CoCon charDataCon [] [CoLitAtom (MachChar (_HEAD_ s))] - the_nil = CoCon nilDataCon [charTy] [] + the_char = mkCon charDataCon [] [] [LitArg (MachChar (_HEAD_ s))] + the_nil = mk_nil_con charTy in - mkCoConDs consDataCon [charTy] [the_char, the_nil] + mkConDs consDataCon [charTy] [the_char, the_nil] -- "_" => build (\ c n -> c 'c' n) -- LATER -- "str" ==> build (\ c n -> foldr charTy T c n "str") {- LATER: -dsExpr (Lit (StringLit str)) = - newTyVarsDs [alpha_tv] `thenDs` \ [new_tyvar] -> +dsExpr (HsLitOut (HsString str) _) + = newTyVarsDs [alphaTyVar] `thenDs` \ [new_tyvar] -> let new_ty = mkTyVarTy new_tyvar in - newSysLocalsDs [ + newSysLocalsDs [ charTy `mkFunTy` (new_ty `mkFunTy` new_ty), new_ty, - mkForallTy [alpha_tv] - ((charTy `mkFunTy` (alpha `mkFunTy` alpha)) - `mkFunTy` (alpha `mkFunTy` alpha)) + mkForallTy [alphaTyVar] + ((charTy `mkFunTy` (alphaTy `mkFunTy` alphaTy)) + `mkFunTy` (alphaTy `mkFunTy` alphaTy)) ] `thenDs` \ [c,n,g] -> returnDs (mkBuild charTy new_tyvar c n g ( - foldl CoApp - (CoTyApp (CoTyApp (CoVar foldrId) charTy) new_ty) *** ensure non-prim type *** - [CoVarAtom c,CoVarAtom n,CoLitAtom (NoRepStr str)])) + foldl App + (CoTyApp (CoTyApp (Var foldrId) charTy) new_ty) *** ensure non-prim type *** + [VarArg c,VarArg n,LitArg (NoRepStr str)])) -} -- otherwise, leave it as a NoRepStr; -- the Core-to-STG pass will wrap it in an application of "unpackCStringId". -dsExpr (Lit (StringLit str)) - = returnDs (CoLit (NoRepStr str)) +dsExpr (HsLitOut (HsString str) _) + = returnDs (Lit (NoRepStr str)) -dsExpr (Lit (LitLitLit s ty)) - = returnDs ( CoCon data_con [] [CoLitAtom (MachLitLit s kind)] ) +dsExpr (HsLitOut (HsLitLit s) ty) + = returnDs ( mkCon data_con [] [] [LitArg (MachLitLit s kind)] ) where (data_con, kind) = case (maybeBoxedPrimType ty) of - Nothing - -> error ("ERROR: ``literal-literal'' not a single-constructor type: "++ _UNPK_ s ++"; type: "++(ppShow 80 (ppr PprDebug ty))) Just (boxing_data_con, prim_ty) - -> (boxing_data_con, kindFromType prim_ty) + -> (boxing_data_con, typePrimRep prim_ty) + Nothing + -> pprError "ERROR: ``literal-literal'' not a single-constructor type: " + (ppBesides [ppPStr s, ppStr "; type: ", ppr PprDebug ty]) -dsExpr (Lit (IntLit i)) - = returnDs (CoLit (NoRepInteger i)) +dsExpr (HsLitOut (HsInt i) _) + = returnDs (Lit (NoRepInteger i)) -dsExpr (Lit (FracLit r)) - = returnDs (CoLit (NoRepRational r)) +dsExpr (HsLitOut (HsFrac r) _) + = returnDs (Lit (NoRepRational r)) -- others where we know what to do: -dsExpr (Lit (IntPrimLit i)) +dsExpr (HsLitOut (HsIntPrim i) _) = if (i >= toInteger minInt && i <= toInteger maxInt) then - returnDs (CoLit (mkMachInt i)) + returnDs (Lit (mkMachInt i)) else error ("ERROR: Int constant " ++ show i ++ out_of_range_msg) -dsExpr (Lit (FloatPrimLit f)) - = returnDs (CoLit (MachFloat f)) +dsExpr (HsLitOut (HsFloatPrim f) _) + = returnDs (Lit (MachFloat f)) -- ToDo: range checking needed! -dsExpr (Lit (DoublePrimLit d)) - = returnDs (CoLit (MachDouble d)) +dsExpr (HsLitOut (HsDoublePrim d) _) + = returnDs (Lit (MachDouble d)) -- ToDo: range checking needed! -dsExpr (Lit (CharLit c)) - = returnDs ( CoCon charDataCon [] [CoLitAtom (MachChar c)] ) +dsExpr (HsLitOut (HsChar c) _) + = returnDs ( mkCon charDataCon [] [] [LitArg (MachChar c)] ) -dsExpr (Lit (CharPrimLit c)) - = returnDs (CoLit (MachChar c)) +dsExpr (HsLitOut (HsCharPrim c) _) + = returnDs (Lit (MachChar c)) -dsExpr (Lit (StringPrimLit s)) - = returnDs (CoLit (MachStr s)) +dsExpr (HsLitOut (HsStringPrim s) _) + = returnDs (Lit (MachStr s)) -- end of literals magic. -- -dsExpr expr@(Lam a_Match) - = let - error_msg = "%L" --> "pattern-matching failed in lambda" - in - matchWrapper LambdaMatch [a_Match] error_msg `thenDs` \ (binders, matching_code) -> - returnDs ( mkCoLam binders matching_code ) - -dsExpr expr@(App e1 e2) = dsApp expr [] +dsExpr expr@(HsLam a_Match) + = matchWrapper LambdaMatch [a_Match] "lambda" `thenDs` \ (binders, matching_code) -> + returnDs ( mkValLam binders matching_code ) +dsExpr expr@(HsApp e1 e2) = dsApp expr [] dsExpr expr@(OpApp e1 op e2) = dsApp expr [] \end{code} @@ -190,7 +195,7 @@ Operator sections. At first it looks as if we can convert \begin{verbatim} (expr op) \end{verbatim} -to +to \begin{verbatim} \x -> op expr x \end{verbatim} @@ -211,151 +216,266 @@ will sort it out. dsExpr (SectionL expr op) = dsExpr op `thenDs` \ core_op -> dsExpr expr `thenDs` \ core_expr -> - dsExprToAtom core_expr ( \ y_atom -> + dsExprToAtom core_expr $ \ y_atom -> -- for the type of x, we need the type of op's 2nd argument let - x_ty = case (splitType (typeOfCoreExpr core_op)) of { (_, _, tau_ty) -> + x_ty = case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) -> case (splitTyArgs tau_ty) of { ((_:arg2_ty:_), _) -> arg2_ty; - _ -> panic "dsExpr:SectionL:arg 2 ty"--++(ppShow 80 (ppAboves [ppr PprDebug (typeOfCoreExpr core_op), ppr PprDebug tau_ty])) + _ -> panic "dsExpr:SectionL:arg 2 ty" }} in newSysLocalDs x_ty `thenDs` \ x_id -> - returnDs ( mkCoLam [x_id] (CoApp (CoApp core_op y_atom) (CoVarAtom x_id)) )) + returnDs (mkValLam [x_id] (core_op `App` y_atom `App` VarArg x_id)) -- dsExpr (SectionR op expr) -- \ x -> op x expr dsExpr (SectionR op expr) = dsExpr op `thenDs` \ core_op -> dsExpr expr `thenDs` \ core_expr -> - dsExprToAtom core_expr (\ y_atom -> + dsExprToAtom core_expr $ \ y_atom -> -- for the type of x, we need the type of op's 1st argument let - x_ty = case (splitType (typeOfCoreExpr core_op)) of { (_, _, tau_ty) -> + x_ty = case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) -> case (splitTyArgs tau_ty) of { ((arg1_ty:_), _) -> arg1_ty; - _ -> panic "dsExpr:SectionR:arg 1 ty"--++(ppShow 80 (ppAboves [ppr PprDebug (typeOfCoreExpr core_op), ppr PprDebug tau_ty])) + _ -> panic "dsExpr:SectionR:arg 1 ty" }} in newSysLocalDs x_ty `thenDs` \ x_id -> - returnDs ( mkCoLam [x_id] (CoApp (CoApp core_op (CoVarAtom x_id)) y_atom) )) + returnDs (mkValLam [x_id] (core_op `App` VarArg x_id `App` y_atom)) dsExpr (CCall label args may_gc is_asm result_ty) = mapDs dsExpr args `thenDs` \ core_args -> dsCCall label core_args may_gc is_asm result_ty -- dsCCall does all the unboxification, etc. -dsExpr (SCC cc expr) +dsExpr (HsSCC cc expr) = dsExpr expr `thenDs` \ core_expr -> getModuleAndGroupDs `thenDs` \ (mod_name, group_name) -> - returnDs ( CoSCC (mkUserCC cc mod_name group_name) core_expr) + returnDs ( SCC (mkUserCC cc mod_name group_name) core_expr) -dsExpr expr@(Case discrim matches) - = dsExpr discrim `thenDs` \ core_discrim -> - let - error_msg = "%C" --> "pattern-matching failed in case" - in - matchWrapper CaseMatch matches error_msg `thenDs` \ ([discrim_var], matching_code) -> - returnDs ( mkCoLetAny (CoNonRec discrim_var core_discrim) matching_code ) +dsExpr expr@(HsCase discrim matches src_loc) + = putSrcLocDs src_loc $ + dsExpr discrim `thenDs` \ core_discrim -> + matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) -> + returnDs ( mkCoLetAny (NonRec discrim_var core_discrim) matching_code ) dsExpr (ListComp expr quals) = dsExpr expr `thenDs` \ core_expr -> dsListComp core_expr quals -dsExpr (Let binds expr) +dsExpr (HsLet binds expr) = dsBinds binds `thenDs` \ core_binds -> dsExpr expr `thenDs` \ core_expr -> returnDs ( mkCoLetsAny core_binds core_expr ) -dsExpr (ExplicitList _) = panic "dsExpr:ExplicitList -- not translated" +dsExpr (HsDoOut stmts m_id mz_id src_loc) + = putSrcLocDs src_loc $ + panic "dsExpr:HsDoOut" + +dsExpr (HsIf guard_expr then_expr else_expr src_loc) + = putSrcLocDs src_loc $ + dsExpr guard_expr `thenDs` \ core_guard -> + dsExpr then_expr `thenDs` \ core_then -> + dsExpr else_expr `thenDs` \ core_else -> + returnDs (mkCoreIfThenElse core_guard core_then core_else) + +\end{code} + + +Type lambda and application +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +\begin{code} +dsExpr (TyLam tyvars expr) + = dsExpr expr `thenDs` \ core_expr -> + returnDs (mkTyLam tyvars core_expr) +dsExpr expr@(TyApp e tys) = dsApp expr [] +\end{code} + + +Various data construction things +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +\begin{code} dsExpr (ExplicitListOut ty xs) = case xs of - [] -> returnDs ( CoCon nilDataCon [ty] [] ) + [] -> returnDs (mk_nil_con ty) (y:ys) -> dsExpr y `thenDs` \ core_hd -> dsExpr (ExplicitListOut ty ys) `thenDs` \ core_tl -> - mkCoConDs consDataCon [ty] [core_hd, core_tl] + mkConDs consDataCon [ty] [core_hd, core_tl] dsExpr (ExplicitTuple expr_list) = mapDs dsExpr expr_list `thenDs` \ core_exprs -> - mkCoConDs (mkTupleCon (length expr_list)) - (map typeOfCoreExpr core_exprs) - core_exprs - -dsExpr (ExprWithTySig expr sig) = panic "dsExpr: ExprWithTySig" + mkConDs (mkTupleCon (length expr_list)) + (map coreExprType core_exprs) + core_exprs + +-- Two cases, one for ordinary constructors and one for newtype constructors +dsExpr (HsCon con tys args) + | isDataTyCon tycon -- The usual datatype case + = mapDs dsExpr args `thenDs` \ args_exprs -> + mkConDs con tys args_exprs + + | otherwise -- The newtype case + = ASSERT( isNewTyCon tycon ) + ASSERT( null rest_args ) + dsExpr first_arg `thenDs` \ arg_expr -> + returnDs (Coerce (CoerceIn con) result_ty arg_expr) -dsExpr (If guard_expr then_expr else_expr) - = dsExpr guard_expr `thenDs` \ core_guard -> - dsExpr then_expr `thenDs` \ core_then -> - dsExpr else_expr `thenDs` \ core_else -> - returnDs (mkCoreIfThenElse core_guard core_then core_else) - -dsExpr (ArithSeqIn info) = panic "dsExpr.ArithSeqIn" + where + (first_arg:rest_args) = args + (args_tys, result_ty) = splitFunTy (foldl applyTy (idType con) tys) + (tycon,_) = getAppTyCon result_ty dsExpr (ArithSeqOut expr (From from)) = dsExpr expr `thenDs` \ expr2 -> dsExpr from `thenDs` \ from2 -> - mkCoAppDs expr2 from2 + mkAppDs expr2 [] [from2] dsExpr (ArithSeqOut expr (FromTo from two)) = dsExpr expr `thenDs` \ expr2 -> dsExpr from `thenDs` \ from2 -> dsExpr two `thenDs` \ two2 -> - mkCoAppDs expr2 from2 `thenDs` \ app1 -> - mkCoAppDs app1 two2 + mkAppDs expr2 [] [from2, two2] dsExpr (ArithSeqOut expr (FromThen from thn)) = dsExpr expr `thenDs` \ expr2 -> dsExpr from `thenDs` \ from2 -> dsExpr thn `thenDs` \ thn2 -> - mkCoAppDs expr2 from2 `thenDs` \ app1 -> - mkCoAppDs app1 thn2 + mkAppDs expr2 [] [from2, thn2] dsExpr (ArithSeqOut expr (FromThenTo from thn two)) = dsExpr expr `thenDs` \ expr2 -> dsExpr from `thenDs` \ from2 -> dsExpr thn `thenDs` \ thn2 -> dsExpr two `thenDs` \ two2 -> - mkCoAppDs expr2 from2 `thenDs` \ app1 -> - mkCoAppDs app1 thn2 `thenDs` \ app2 -> - mkCoAppDs app2 two2 + mkAppDs expr2 [] [from2, thn2, two2] +\end{code} -#ifdef DPH -dsExpr (ParallelZF expr quals) - = dsParallelZF expr quals +Record construction and update +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For record construction we do this (assuming T has three arguments) -dsExpr (ExplicitPodIn _) - = panic "dsExpr:ExplicitPodIn -- not translated" + T { op2 = e } +==> + let err = /\a -> recConErr a + T (recConErr t1 "M.lhs/230/op1") + e + (recConErr t1 "M.lhs/230/op3") -dsExpr (ExplicitPodOut _ _) - = panic "dsExpr:ExplicitPodOut should remove this." +recConErr then converts its arugment string into a proper message +before printing it as -dsExpr (ExplicitProcessor exprs expr) - = mapDs dsExpr exprs `thenDs` \ core_exprs -> - dsExpr expr `thenDs` \ core_expr -> - mkCoConDs (mkProcessorCon (length exprs)) - ((map typeOfCoreExpr core_exprs)++[typeOfCoreExpr core_expr]) - (core_exprs++[core_expr]) -#endif {- Data Parallel Haskell -} + M.lhs, line 230: missing field op1 was evaluated + + +\begin{code} +dsExpr (RecordCon con_expr rbinds) + = dsExpr con_expr `thenDs` \ con_expr' -> + let + con_id = get_con con_expr' + (arg_tys, _) = splitFunTy (coreExprType con_expr') + + mk_arg (arg_ty, lbl) + = case [rhs | (sel_id,rhs,_) <- rbinds, + lbl == recordSelectorFieldLabel sel_id] of + (rhs:rhss) -> ASSERT( null rhss ) + dsExpr rhs + [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showForErr lbl) + in + mapDs mk_arg (arg_tys `zipEqual` dataConFieldLabels con_id) `thenDs` \ con_args -> + mkAppDs con_expr' [] con_args + where + -- "con_expr'" is simply an application of the constructor Id + -- to types and (perhaps) dictionaries. This gets the constructor... + get_con (Var con) = con + get_con (App fun _) = get_con fun \end{code} +Record update is a little harder. Suppose we have the decl: + + data T = T1 {op1, op2, op3 :: Int} + | T2 {op4, op2 :: Int} + | T3 + +Then we translate as follows: + + r { op2 = e } +===> + let op2 = e in + case r of + T1 op1 _ op3 -> T1 op1 op2 op3 + T2 op4 _ -> T2 op4 op2 + other -> recUpdError "M.lhs/230" + +It's important that we use the constructor Ids for T1, T2 etc on the +RHSs, and do not generate a Core Con directly, because the constructor +might do some argument-evaluation first; and may have to throw away some +dictionaries. + \begin{code} -dsExpr (TyLam tyvars expr) - = dsExpr expr `thenDs` \ core_expr -> - returnDs( foldr CoTyLam core_expr tyvars) +dsExpr (RecordUpdOut record_expr dicts rbinds) + = dsExpr record_expr `thenDs` \ record_expr' -> -dsExpr expr@(TyApp e tys) = dsApp expr [] + -- Desugar the rbinds, and generate let-bindings if + -- necessary so that we don't lose sharing + dsRbinds rbinds $ \ rbinds' -> + let + record_ty = coreExprType record_expr' + (tycon, inst_tys, cons) = _trace "getAppDataTyCon.DsExpr" $ getAppDataTyCon record_ty + cons_to_upd = filter has_all_fields cons + + -- initial_args are passed to every constructor + initial_args = map TyArg inst_tys ++ map VarArg dicts + + mk_val_arg (field, arg_id) + = case [arg | (f, arg) <- rbinds', + field == recordSelectorFieldLabel f] of + (arg:args) -> ASSERT(null args) + arg + [] -> VarArg arg_id + + mk_alt con + = newSysLocalsDs (dataConArgTys con inst_tys) `thenDs` \ arg_ids -> + let + val_args = map mk_val_arg (dataConFieldLabels con `zipEqual` arg_ids) + in + returnDs (con, arg_ids, mkGenApp (mkGenApp (Var con) initial_args) val_args) + + mk_default + | length cons_to_upd == length cons + = returnDs NoDefault + | otherwise + = newSysLocalDs record_ty `thenDs` \ deflt_id -> + mkErrorAppDs rEC_UPD_ERROR_ID record_ty "" `thenDs` \ err -> + returnDs (BindDefault deflt_id err) + in + mapDs mk_alt cons_to_upd `thenDs` \ alts -> + mk_default `thenDs` \ deflt -> + + returnDs (Case record_expr' (AlgAlts alts deflt)) + + where + has_all_fields :: Id -> Bool + has_all_fields con_id + = all ok rbinds + where + con_fields = dataConFieldLabels con_id + ok (sel_id, _, _) = recordSelectorFieldLabel sel_id `elem` con_fields \end{code} +Dictionary lambda and application +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @DictLam@ and @DictApp@ turn into the regular old things. (OLD:) @DictFunApp@ also becomes a curried application, albeit slightly more complicated; reminiscent of fully-applied constructors. \begin{code} dsExpr (DictLam dictvars expr) = dsExpr expr `thenDs` \ core_expr -> - returnDs( mkCoLam dictvars core_expr ) + returnDs( mkValLam dictvars core_expr ) ------------------ @@ -371,7 +491,7 @@ of length 0 or 1. \end{verbatim} \begin{code} dsExpr (SingleDict dict) -- just a local - = lookupEnvWithDefaultDs dict (CoVar dict) + = lookupEnvWithDefaultDs dict (Var dict) dsExpr (Dictionary dicts methods) = -- hey, these things may have been substituted away... @@ -385,41 +505,48 @@ dsExpr (Dictionary dicts methods) 1 -> returnDs (head core_d_and_ms) -- just a single Id _ -> -- tuple 'em up - mkCoConDs (mkTupleCon num_of_d_and_ms) - (map typeOfCoreExpr core_d_and_ms) - core_d_and_ms + mkConDs (mkTupleCon num_of_d_and_ms) + (map coreExprType core_d_and_ms) + core_d_and_ms ) where dicts_and_methods = dicts ++ methods - dicts_and_methods_exprs = map CoVar dicts_and_methods + dicts_and_methods_exprs = map Var dicts_and_methods num_of_d_and_ms = length dicts_and_methods dsExpr (ClassDictLam dicts methods expr) = dsExpr expr `thenDs` \ core_expr -> case num_of_d_and_ms of 0 -> newSysLocalDs unitTy `thenDs` \ new_x -> - returnDs (CoLam [new_x] core_expr) + returnDs (mkValLam [new_x] core_expr) 1 -> -- no untupling - returnDs (CoLam dicts_and_methods core_expr) + returnDs (mkValLam dicts_and_methods core_expr) _ -> -- untuple it newSysLocalDs tuple_ty `thenDs` \ new_x -> returnDs ( - CoLam [new_x] - (CoCase (CoVar new_x) - (CoAlgAlts + Lam (ValBinder new_x) + (Case (Var new_x) + (AlgAlts [(tuple_con, dicts_and_methods, core_expr)] - CoNoDefault))) + NoDefault))) where + num_of_d_and_ms = length dicts + length methods dicts_and_methods = dicts ++ methods - num_of_d_and_ms = length dicts_and_methods - tuple_ty = mkTupleTy num_of_d_and_ms (map getIdUniType dicts_and_methods) - tuple_tycon = mkTupleTyCon num_of_d_and_ms + tuple_ty = mkTupleTy num_of_d_and_ms (map idType dicts_and_methods) tuple_con = mkTupleCon num_of_d_and_ms -cocon_unit = CoCon (mkTupleCon 0) [] [] -- out here to avoid CAF (sigh) -out_of_range_msg -- ditto +#ifdef DEBUG +-- HsSyn constructs that just shouldn't be here: +dsExpr (HsDo _ _) = panic "dsExpr:HsDo" +dsExpr (ExplicitList _) = panic "dsExpr:ExplicitList" +dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig" +dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn" +#endif + +cocon_unit = mkCon (mkTupleCon 0) [] [] [] -- out here to avoid CAF (sigh) +out_of_range_msg -- ditto = " out of range: [" ++ show minInt ++ ", " ++ show maxInt ++ "]\n" \end{code} @@ -435,79 +562,95 @@ We're doing all this so we can saturate constructors (as painlessly as possible). \begin{code} -data DsCoreArg - = DsTypeArg UniType - | DsValArg PlainCoreExpr +type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar -dsApp :: TypecheckedExpr -- expr to desugar +dsApp :: TypecheckedHsExpr -- expr to desugar -> [DsCoreArg] -- accumulated ty/val args: NB: - -> DsM PlainCoreExpr -- final result + -> DsM CoreExpr -- final result -dsApp (App e1 e2) args +dsApp (HsApp e1 e2) args = dsExpr e2 `thenDs` \ core_e2 -> - dsApp e1 (DsValArg core_e2 : args) + dsApp e1 (VarArg core_e2 : args) dsApp (OpApp e1 op e2) args = dsExpr e1 `thenDs` \ core_e1 -> dsExpr e2 `thenDs` \ core_e2 -> - dsApp op (DsValArg core_e1 : DsValArg core_e2 : args) + dsApp op (VarArg core_e1 : VarArg core_e2 : args) dsApp (DictApp expr dicts) args = -- now, those dicts may have been substituted away... - zipWithDs lookupEnvWithDefaultDs dicts (map CoVar dicts) + zipWithDs lookupEnvWithDefaultDs dicts (map Var dicts) `thenDs` \ core_dicts -> - dsApp expr (map DsValArg core_dicts ++ args) + dsApp expr (map VarArg core_dicts ++ args) dsApp (TyApp expr tys) args - = dsApp expr (map DsTypeArg tys ++ args) + = dsApp expr (map TyArg tys ++ args) -- we might should look out for SectionLs, etc., here, but we don't -dsApp (Var v) args +dsApp (HsVar v) args = lookupEnvDs v `thenDs` \ maybe_expr -> case maybe_expr of Just expr -> apply_to_args expr args Nothing -> -- we're only saturating constructors and PrimOps case getIdUnfolding v of - GeneralForm _ _ the_unfolding EssentialUnfolding + GenForm _ _ the_unfolding EssentialUnfolding -> do_unfold nullTyVarEnv nullIdEnv (unTagBinders the_unfolding) args - _ -> apply_to_args (CoVar v) args + _ -> apply_to_args (Var v) args dsApp anything_else args = dsExpr anything_else `thenDs` \ core_expr -> apply_to_args core_expr args --- a DsM version of applyToArgs: -apply_to_args :: PlainCoreExpr -> [DsCoreArg] -> DsM PlainCoreExpr +-- a DsM version of mkGenApp: +apply_to_args :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr -apply_to_args fun [] = returnDs fun +apply_to_args fun args + = let + (ty_args, val_args) = foldr sep ([],[]) args + in + mkAppDs fun ty_args val_args + where + sep a@(LitArg l) (tys,vals) = (tys, (Lit l):vals) + sep a@(VarArg e) (tys,vals) = (tys, e:vals) + sep a@(TyArg ty) (tys,vals) = (ty:tys, vals) + sep a@(UsageArg _) _ = panic "DsExpr:apply_to_args:UsageArg" +\end{code} -apply_to_args fun (DsValArg expr : args) - = mkCoAppDs fun expr `thenDs` \ fun2 -> - apply_to_args fun2 args -apply_to_args fun (DsTypeArg ty : args) - = apply_to_args (mkCoTyApp fun ty) args -\end{code} +\begin{code} +dsRbinds :: TypecheckedRecordBinds -- The field bindings supplied + -> ([(Id, CoreArg)] -> DsM CoreExpr) -- A continuation taking the field + -- bindings with atomic rhss + -> DsM CoreExpr -- The result of the continuation, + -- wrapped in suitable Lets + +dsRbinds [] continue_with + = continue_with [] + +dsRbinds ((sel_id, rhs, pun_flag) : rbinds) continue_with + = dsExpr rhs `thenDs` \ rhs' -> + dsExprToAtom rhs' $ \ rhs_atom -> + dsRbinds rbinds $ \ rbinds' -> + continue_with ((sel_id, rhs_atom) : rbinds') +\end{code} \begin{code} -do_unfold ty_env val_env (CoTyLam tyvar body) (DsTypeArg ty : args) +do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args) = do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args -do_unfold ty_env val_env (CoLam [] body) args - = do_unfold ty_env val_env body args - -do_unfold ty_env val_env (CoLam (binder:binders) body) (DsValArg expr : args) - = dsExprToAtom expr (\ arg_atom -> - do_unfold ty_env (addOneToIdEnv val_env binder (atomToExpr arg_atom)) (CoLam binders body) args - ) +do_unfold ty_env val_env (Lam (ValBinder binder) body) (VarArg expr : args) + = dsExprToAtom expr $ \ arg_atom -> + do_unfold ty_env + (addOneToIdEnv val_env binder (argToExpr arg_atom)) + body args do_unfold ty_env val_env body args = -- Clone the remaining part of the template - uniqSMtoDsM (substCoreExprUS val_env ty_env body) `thenDs` \ body' -> + uniqSMtoDsM (substCoreExpr val_env ty_env body) `thenDs` \ body' -> -- Apply result to remaining arguments apply_to_args body' args