combineGRHSMatchResults,
combineMatchResults,
- dsExprToAtom,
+ dsExprToAtom, DsCoreArg(..),
mkCoAlgCaseMatchResult,
mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
mkCoLetsMatchResult,
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 )
+ Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
import TcHsSyn ( TypecheckedPat(..) )
import DsHsSyn ( outPatType )
import CoreSyn
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-},
import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
mkTheta, isUnboxedType, applyTyCon, getAppTyCon
)
+import TysPrim ( voidTy )
import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
import PprCore{-ToDo:rm-}
%************************************************************************
\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
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 ->
%************************************************************************
\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}
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}
-- 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 (mkFunTys [voidTy] 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}