[project @ 1999-05-18 15:03:54 by simonpj]

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

diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 177b183..e289d24 100644 (file)
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -10,13 +10,15 @@ module DsUtils (
        CanItFail(..), EquationInfo(..), MatchResult(..),
         EqnNo, EqnSet,
 
+       mkDsLet, mkDsLets,
+
        cantFailMatchResult, extractMatchResult,
        combineMatchResults, 
        adjustMatchResult, adjustMatchResultDs,
        mkCoLetsMatchResult, mkGuardedMatchResult, 
        mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
 
-       mkErrorAppDs,
+       mkErrorAppDs, mkNilExpr, mkConsExpr,
 
        mkSelectorBinds, mkTupleExpr, mkTupleSelector,
 
@@ -35,16 +37,19 @@ import CoreSyn
 import DsMonad
 
 import CoreUtils       ( coreExprType )
-import PrelVals                ( iRREFUT_PAT_ERROR_ID )
+import PrelInfo                ( iRREFUT_PAT_ERROR_ID )
 import Id              ( idType, Id, mkWildId )
 import Const           ( Literal(..), Con(..) )
 import TyCon           ( isNewTyCon, tyConDataCons )
-import DataCon         ( DataCon, dataConStrictMarks, dataConArgTys )
-import BasicTypes      ( StrictnessMark(..) )
+import DataCon         ( DataCon, StrictnessMark, maybeMarkedUnboxed, dataConStrictMarks, 
+                         dataConArgTys, dataConId
+                       )
 import Type            ( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy,
                          Type
                        )
-import TysWiredIn      ( unitDataCon, tupleCon, stringTy, unitTy, unitDataCon )
+import TysWiredIn      ( unitDataCon, tupleCon, stringTy, unitTy, unitDataCon,
+                         nilDataCon, consDataCon
+                       )
 import UniqSet         ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
 import Outputable
 \end{code}
@@ -52,6 +57,27 @@ import Outputable
 
 %************************************************************************
 %*                                                                     *
+%* Building lets
+%*                                                                     *
+%************************************************************************
+
+Use case, not let for unlifted types.  The simplifier will turn some
+back again.
+
+\begin{code}
+mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
+mkDsLet (NonRec bndr rhs) body
+  | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
+mkDsLet bind body
+  = Let bind body
+
+mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
+mkDsLets binds body = foldr mkDsLet body binds
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
 %* Selecting match variables
 %*                                                                     *
 %************************************************************************
@@ -127,7 +153,7 @@ extractMatchResult (MatchResult CantFail match_fn) fail_expr
 extractMatchResult (MatchResult CanFail match_fn) fail_expr
   = mkFailurePair fail_expr            `thenDs` \ (fail_bind, if_it_fails) ->
     match_fn if_it_fails               `thenDs` \ body ->
-    returnDs (Let fail_bind body)
+    returnDs (mkDsLet fail_bind body)
 
 
 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
@@ -157,7 +183,7 @@ adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
 
 mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
 mkCoLetsMatchResult binds match_result
-  = adjustMatchResult (mkLets binds) match_result
+  = adjustMatchResult (mkDsLets binds) match_result
 
 
 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
@@ -244,14 +270,14 @@ rebuildConArgs con (arg:args) stricts body | isTyVar arg
     returnDs (body',arg:args')
 rebuildConArgs con (arg:args) (str:stricts) body
   = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
-    case str of
-       MarkedUnboxed pack_con tys -> 
+    case maybeMarkedUnboxed str of
+       Just (pack_con, tys) -> 
            let id_tys  = dataConArgTys pack_con ty_args in
            newSysLocalsDs id_tys `thenDs` \ unpacked_args ->
            returnDs (
-                Let (NonRec arg (Con (DataCon pack_con) 
-                                     (map Type ty_args ++
-                                      map Var  unpacked_args))) body', 
+                mkDsLet (NonRec arg (Con (DataCon pack_con) 
+                                         (map Type ty_args ++
+                                          map Var  unpacked_args))) body', 
                 unpacked_args ++ real_args
            )
        _ -> returnDs (body', arg:real_args)
@@ -409,6 +435,24 @@ mkTupleSelector vars the_var scrut_var scrut
 %*                                                                     *
 %************************************************************************
 
+Call the constructor Ids when building explicit lists, so that they
+interact well with rules.
+
+\begin{code}
+mkNilExpr :: Type -> CoreExpr
+mkNilExpr ty = App (Var (dataConId nilDataCon)) (Type ty)
+
+mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
+mkConsExpr ty hd tl = mkApps (Var (dataConId consDataCon)) [Type ty, hd, tl]
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection[mkFailurePair]{Code for pattern-matching and other failures}
+%*                                                                     *
+%************************************************************************
+
 Generally, we handle pattern matching failure like this: let-bind a
 fail-variable, and use that variable if the thing fails:
 \begin{verbatim}