[project @ 1996-06-11 13:18:54 by partain]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsUtils.lhs

diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 5790628..84e871f 100644 (file)
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -13,7 +13,7 @@ module DsUtils (
 
        combineGRHSMatchResults,
        combineMatchResults,
-       dsExprToAtom,
+       dsExprToAtom, DsCoreArg(..),
        mkCoAlgCaseMatchResult,
        mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
        mkCoLetsMatchResult,
@@ -27,11 +27,11 @@ 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 )
+                         Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
 import TcHsSyn         ( TypecheckedPat(..) )
 import DsHsSyn         ( outPatType )
 import CoreSyn
@@ -40,7 +40,7 @@ import DsMonad
 
 import CoreUtils       ( coreExprType, mkCoreIfThenElse )
 import PprStyle                ( PprStyle(..) )
-import PrelVals                ( iRREFUT_PAT_ERROR_ID )
+import PrelVals                ( iRREFUT_PAT_ERROR_ID, voidId )
 import Pretty          ( ppShow )
 import Id              ( idType, dataConArgTys, mkTupleCon,
                          pprId{-ToDo:rm-},
@@ -50,6 +50,7 @@ import TyCon          ( mkTupleTyCon, isNewTyCon, tyConDataCons )
 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-}
@@ -239,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
@@ -259,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  ->
@@ -279,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}
@@ -551,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}
 
@@ -572,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 (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}