X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=e99c01daf55f0fb3a8980fbe3dfb52a6b09e5141;hb=d4e0a55c3761544989209a2180d6d0489470db3d;hp=e2ba97018c64425b441fb52851e83f5d1c555803;hpb=266fadd93461d4317967df08cd641e965cd8769a;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index e2ba970..e99c01d 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -22,14 +22,13 @@ module TcHsSyn (
 	TypecheckedGRHSs, TypecheckedGRHS,
 	TypecheckedRecordBinds, TypecheckedDictBinds,
 
-	mkHsTyApp, mkHsDictApp,
+	mkHsTyApp, mkHsDictApp, mkHsConApp,
 	mkHsTyLam, mkHsDictLam, mkHsLet,
+	idsToMonoBinds,
 
 	-- re-exported from TcEnv
 	TcId, tcInstId,
 
-	maybeBoxedPrimType,
-
 	zonkTopBinds, zonkId, zonkIdOcc,
 	zonkForeignExports, zonkRules
   ) where
@@ -40,8 +39,8 @@ module TcHsSyn (
 import HsSyn	-- oodles of it
 
 -- others:
-import Id	( idName, idType, setIdType, omitIfaceSigForId, Id )
-import DataCon	( DataCon, splitProductType_maybe )	
+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 +49,13 @@ import TcMonad
 import TcType	( TcType, TcTyVar,
 		  zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
 		)
-import TyCon	( isDataTyCon )
-import Type	( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type )
+import Type	( mkTyVarTy, 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,27 +122,14 @@ mkHsDictLam dicts expr = DictLam dicts expr
 
 mkHsLet EmptyMonoBinds expr = expr
 mkHsLet mbinds	       expr = HsLet (MonoBind mbinds [] Recursive) expr
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
-%*									*
-%************************************************************************
 
-Some gruesome hackery for desugaring ccalls. It's here because if we put it
-in Type.lhs we get irritating loops, and it's only used by TcInstDcls.lhs and
-DsCCall.lhs.
+mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
 
-\begin{code}
-maybeBoxedPrimType :: Type -> Maybe (DataCon, Type)
-maybeBoxedPrimType ty
-  = 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
+idsToMonoBinds :: [Id] -> TcMonoBinds 
+idsToMonoBinds ids
+  = andMonoBindList [ CoreMonoBind id (unfoldingTemplate (idUnfolding id))
+		    | id <- ids
+		    ]
 \end{code}
 
 %************************************************************************
@@ -184,7 +170,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
@@ -433,11 +419,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 ->
@@ -460,10 +441,10 @@ 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 lbl expr)
   = zonkExpr expr	`thenNF_Tc` \ new_expr ->