X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsUtils.lhs;h=66472b77a14c1e873a01dd7d4bd07090ea4ee35a;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=c4a46e2e3d2ce8132d2bff901efe50c1ef72e1ad;hpb=f01a8e8c9c53bfb5ab3393ed3457ebf25390efa1;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index c4a46e2..66472b7 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -13,7 +13,7 @@ module DsUtils ( combineGRHSMatchResults, combineMatchResults, - dsExprToAtom, + dsExprToAtom, SYN_IE(DsCoreArg), mkCoAlgCaseMatchResult, mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs, mkCoLetsMatchResult, @@ -27,12 +27,12 @@ module DsUtils ( showForErr ) where -import Ubiq -import DsLoop ( match, matchSimply ) +IMP_Ubiq() +IMPORT_DELOOPER(DsLoop) ( match, matchSimply ) import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), - Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo ) -import TcHsSyn ( TypecheckedPat(..) ) + Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo ) +import TcHsSyn ( SYN_IE(TypecheckedPat) ) import DsHsSyn ( outPatType ) import CoreSyn @@ -40,27 +40,25 @@ import DsMonad import CoreUtils ( coreExprType, mkCoreIfThenElse ) import PprStyle ( PprStyle(..) ) -import PrelInfo ( stringTy, iRREFUT_PAT_ERROR_ID ) +import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId ) import Pretty ( ppShow ) import Id ( idType, dataConArgTys, mkTupleCon, - pprId{-ToDo:rm-}, - DataCon(..), DictVar(..), Id(..), GenId ) +-- pprId{-ToDo:rm-}, + SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId ) import Literal ( Literal(..) ) import TyCon ( mkTupleTyCon, isNewTyCon, tyConDataCons ) -import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys, - isUnboxedType, applyTyCon, - getAppDataTyCon, getAppTyCon +import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy, + mkTheta, isUnboxedType, applyTyCon, getAppTyCon ) -import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) ) -import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} ) -import PprCore{-ToDo:rm-} -import PprType--ToDo:rm -import Pretty--ToDo:rm -import TyVar--ToDo:rm -import Unique--ToDo:rm -import Usage--ToDo:rm - -splitDictType = panic "DsUtils.splitDictType" +import TysPrim ( voidTy ) +import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) ) +import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} ) +import Usage ( SYN_IE(UVar) ) +--import PprCore{-ToDo:rm-} +--import PprType--ToDo:rm +--import Pretty--ToDo:rm +--import TyVar--ToDo:rm +--import Unique--ToDo:rm \end{code} %************************************************************************ @@ -242,15 +240,19 @@ combineGRHSMatchResults match_result1 match_result2 %************************************************************************ \begin{code} -dsExprToAtom :: CoreExpr -- The argument expression +dsExprToAtom :: DsCoreArg -- The argument expression -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*, -- and delivering an expression E -> DsM CoreExpr -- Either E or let x=arg-expr in E -dsExprToAtom (Var v) continue_with = continue_with (VarArg v) -dsExprToAtom (Lit v) continue_with = continue_with (LitArg v) +dsExprToAtom (UsageArg u) continue_with = continue_with (UsageArg u) +dsExprToAtom (TyArg t) continue_with = continue_with (TyArg t) +dsExprToAtom (LitArg l) continue_with = continue_with (LitArg l) -dsExprToAtom arg_expr continue_with +dsExprToAtom (VarArg (Var v)) continue_with = continue_with (VarArg v) +dsExprToAtom (VarArg (Lit v)) continue_with = continue_with (LitArg v) + +dsExprToAtom (VarArg arg_expr) continue_with = let ty = coreExprType arg_expr in @@ -262,12 +264,11 @@ dsExprToAtom arg_expr continue_with else Let (NonRec arg_id arg_expr) body ) -dsExprsToAtoms :: [CoreExpr] +dsExprsToAtoms :: [DsCoreArg] -> ([CoreArg] -> DsM CoreExpr) -> DsM CoreExpr -dsExprsToAtoms [] continue_with - = continue_with [] +dsExprsToAtoms [] continue_with = continue_with [] dsExprsToAtoms (arg:args) continue_with = dsExprToAtom arg $ \ arg_atom -> @@ -282,21 +283,23 @@ dsExprsToAtoms (arg:args) continue_with %************************************************************************ \begin{code} -mkAppDs :: CoreExpr -> [Type] -> [CoreExpr] -> DsM CoreExpr -mkConDs :: Id -> [Type] -> [CoreExpr] -> DsM CoreExpr -mkPrimDs :: PrimOp -> [Type] -> [CoreExpr] -> DsM CoreExpr +type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar + +mkAppDs :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr +mkConDs :: Id -> [DsCoreArg] -> DsM CoreExpr +mkPrimDs :: PrimOp -> [DsCoreArg] -> DsM CoreExpr -mkAppDs fun tys arg_exprs - = dsExprsToAtoms arg_exprs $ \ vals -> - returnDs (mkApp fun [] tys vals) +mkAppDs fun args + = dsExprsToAtoms args $ \ atoms -> + returnDs (mkGenApp fun atoms) -mkConDs con tys arg_exprs - = dsExprsToAtoms arg_exprs $ \ vals -> - returnDs (mkCon con [] tys vals) +mkConDs con args + = dsExprsToAtoms args $ \ atoms -> + returnDs (Con con atoms) -mkPrimDs op tys arg_exprs - = dsExprsToAtoms arg_exprs $ \ vals -> - returnDs (mkPrim op [] tys vals) +mkPrimDs op args + = dsExprsToAtoms args $ \ atoms -> + returnDs (Prim op atoms) \end{code} \begin{code} @@ -422,7 +425,7 @@ The general case: \begin{code} mkTupleBind tyvars dicts local_global_prs tuple_expr - = pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $ + = --pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $ newSysLocalDs tuple_var_ty `thenDs` \ tuple_var -> @@ -449,7 +452,7 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr applyTyCon (mkTupleTyCon no_of_binders) (map idType locals) where - theta = map (splitDictType . idType) dicts + theta = mkTheta (map idType dicts) mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr) @@ -554,13 +557,13 @@ which is of course utterly wrong. Rather than drop the condition that only boxed types can be let-bound, we just turn the fail into a function for the primitive case: \begin{verbatim} - let fail.33 :: () -> Int# + let fail.33 :: Void -> Int# fail.33 = \_ -> error "Help" in case x of p1 -> ... - p2 -> fail.33 () - p3 -> fail.33 () + p2 -> fail.33 void + p3 -> fail.33 void p4 -> ... \end{verbatim} @@ -575,19 +578,16 @@ mkFailurePair :: Type -- Result type of the whole case expression -- applied to unit tuple mkFailurePair ty | isUnboxedType ty - = newFailLocalDs (mkFunTys [unit_ty] ty) `thenDs` \ fail_fun_var -> - newSysLocalDs unit_ty `thenDs` \ fail_fun_arg -> + = newFailLocalDs (voidTy `mkFunTy` ty) `thenDs` \ fail_fun_var -> + newSysLocalDs voidTy `thenDs` \ fail_fun_arg -> returnDs (\ body -> NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body), - App (Var fail_fun_var) (VarArg unit_id)) + App (Var fail_fun_var) (VarArg voidId)) | otherwise = newFailLocalDs ty `thenDs` \ fail_var -> returnDs (\ body -> NonRec fail_var body, Var fail_var) +\end{code} + -unit_id :: Id -- out here to avoid CAF (sigh) -unit_id = mkTupleCon 0 -unit_ty :: Type -unit_ty = idType unit_id -\end{code}