[project @ 2000-03-24 17:49:29 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcHsSyn.lhs

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 41e44c5..37b7036 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -22,8 +22,9 @@ module TcHsSyn (
        TypecheckedGRHSs, TypecheckedGRHS,
        TypecheckedRecordBinds, TypecheckedDictBinds,
 
-       mkHsTyApp, mkHsDictApp,
+       mkHsTyApp, mkHsDictApp, mkHsConApp,
        mkHsTyLam, mkHsDictLam, mkHsLet,
+       idsToMonoBinds,
 
        -- re-exported from TcEnv
        TcId, tcInstId,
@@ -40,8 +41,8 @@ module TcHsSyn (
 import HsSyn   -- oodles of it
 
 -- others:
-import Id      ( idName, idType, setIdType, omitIfaceSigForId, Id )
-import DataCon ( DataCon, dataConArgTys )      
+import Id      ( idName, idType, idUnfolding, setIdType, omitIfaceSigForId, isIP, Id )
+import DataCon ( DataCon, dataConWrapId, splitProductType_maybe )      
 import TcEnv   ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv,
                  ValueEnv, TcId, tcInstId
                )
@@ -50,13 +51,13 @@ import TcMonad
 import TcType  ( TcType, TcTyVar,
                  zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
                )
-import TyCon   ( isDataTyCon )
 import Type    ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type )
 import Name    ( isLocallyDefined )
 import Var     ( TyVar )
 import VarEnv  ( TyVarEnv, emptyVarEnv, extendVarEnvList )
 import VarSet  ( isEmptyVarSet )
 import CoreSyn  ( Expr )
+import CoreUnfold( unfoldingTemplate )
 import BasicTypes ( RecFlag(..) )
 import Bag
 import UniqFM
@@ -123,6 +124,14 @@ mkHsDictLam dicts expr = DictLam dicts expr
 
 mkHsLet EmptyMonoBinds expr = expr
 mkHsLet mbinds        expr = HsLet (MonoBind mbinds [] Recursive) expr
+
+mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
+
+idsToMonoBinds :: [Id] -> TcMonoBinds 
+idsToMonoBinds ids
+  = andMonoBindList [ CoreMonoBind id (unfoldingTemplate (idUnfolding id))
+                   | id <- ids
+                   ]
 \end{code}
 
 %************************************************************************
@@ -138,13 +147,11 @@ DsCCall.lhs.
 \begin{code}
 maybeBoxedPrimType :: Type -> Maybe (DataCon, Type)
 maybeBoxedPrimType ty
-  = case splitAlgTyConApp_maybe ty of                                  -- Data type,
-      Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon        -- with exactly one constructor
-        -> case (dataConArgTys data_con tys_applied) of
-            [data_con_arg_ty]                          -- Applied to exactly one type,
-               | isUnLiftedType data_con_arg_ty        -- which is primitive
-               -> Just (data_con, data_con_arg_ty)
-            other_cases -> Nothing
+  = case splitProductType_maybe ty of                          -- Product data type
+      Just (tycon, tys_applied, data_con, [data_con_arg_ty])   -- constr has one arg
+         | isUnLiftedType data_con_arg_ty                      -- which is primitive
+        -> Just (data_con, data_con_arg_ty)
+
       other_cases -> Nothing
 \end{code}
 
@@ -186,7 +193,7 @@ zonkIdBndr id
 
 zonkIdOcc :: TcId -> NF_TcM s Id
 zonkIdOcc id 
-  | not (isLocallyDefined id) || omitIfaceSigForId id
+  | not (isLocallyDefined id) || omitIfaceSigForId id || isIP id
        -- The omitIfaceSigForId thing may look wierd but it's quite
        -- sensible really.  We're avoiding looking up superclass selectors
        -- and constructors; zonking them is a no-op anyway, and the
@@ -237,7 +244,7 @@ zonkBinds binds
            fixNF_Tc (\ ~(_, new_ids) ->
                tcExtendGlobalValEnv (bagToList new_ids)        $
                zonkMonoBinds bind                              `thenNF_Tc` \ (new_bind, new_ids) ->
-               thing_inside (MonoBind new_bind [] is_rec)      `thenNF_Tc` \ stuff ->
+               thing_inside (mkMonoBind new_bind [] is_rec)    `thenNF_Tc` \ stuff ->
                returnNF_Tc (stuff, new_ids)
            )                                                   `thenNF_Tc` \ (stuff, _) ->
           returnNF_Tc stuff
@@ -348,6 +355,10 @@ zonkExpr (HsVar id)
   = zonkIdOcc id       `thenNF_Tc` \ id' ->
     returnNF_Tc (HsVar id')
 
+zonkExpr (HsIPVar id)
+  = zonkIdOcc id       `thenNF_Tc` \ id' ->
+    returnNF_Tc (HsIPVar id')
+
 zonkExpr (HsLit _) = panic "zonkExpr:HsLit"
 
 zonkExpr (HsLitOut lit ty)
@@ -399,6 +410,16 @@ zonkExpr (HsLet binds expr)
     zonkExpr expr      `thenNF_Tc` \ new_expr ->
     returnNF_Tc (HsLet new_binds new_expr)
 
+zonkExpr (HsWith expr binds)
+  = zonkExpr expr              `thenNF_Tc` \ new_expr ->
+    zonkIPBinds binds          `thenNF_Tc` \ new_binds ->
+    returnNF_Tc (HsWith new_expr new_binds)
+    where
+       zonkIPBinds = mapNF_Tc zonkIPBind
+       zonkIPBind (n, e) =
+           zonkExpr e          `thenNF_Tc` \ e' ->
+           returnNF_Tc (n, e')
+
 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
 
 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
@@ -421,11 +442,6 @@ zonkExpr (ExplicitTuple exprs boxed)
   = mapNF_Tc zonkExpr exprs    `thenNF_Tc` \ new_exprs ->
     returnNF_Tc (ExplicitTuple new_exprs boxed)
 
-zonkExpr (HsCon data_con tys exprs)
-  = mapNF_Tc zonkTcTypeToType tys      `thenNF_Tc` \ new_tys ->
-    mapNF_Tc zonkExpr exprs            `thenNF_Tc` \ new_exprs ->
-    returnNF_Tc (HsCon data_con new_tys new_exprs)
-
 zonkExpr (RecordConOut data_con con_expr rbinds)
   = zonkExpr con_expr  `thenNF_Tc` \ new_con_expr ->
     zonkRbinds rbinds  `thenNF_Tc` \ new_rbinds ->
@@ -448,14 +464,14 @@ zonkExpr (ArithSeqOut expr info)
     zonkArithSeq info  `thenNF_Tc` \ new_info ->
     returnNF_Tc (ArithSeqOut new_expr new_info)
 
-zonkExpr (CCall fun args may_gc is_casm result_ty)
+zonkExpr (HsCCall fun args may_gc is_casm result_ty)
   = mapNF_Tc zonkExpr args     `thenNF_Tc` \ new_args ->
     zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
-    returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
+    returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
 
-zonkExpr (HsSCC label expr)
+zonkExpr (HsSCC lbl expr)
   = zonkExpr expr      `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (HsSCC label new_expr)
+    returnNF_Tc (HsSCC lbl new_expr)
 
 zonkExpr (TyLam tyvars expr)
   = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->