X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=8dfcd309caf41a8738142fa296096b92f5ccaf3b;hb=37507b3a4342773030ef538599363a5aff8b666a;hp=e8e9e7b37000c4cf0b7548afac96cd9535a9a984;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index e8e9e7b..8dfcd30 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -11,9 +11,10 @@ module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
 import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr )
 import GHC.Exts         ( Ptr(..), Int(..), addr2Int# )
 import IOEnv            ( ioToIOEnv )
-import PrelNames        ( breakpointJumpName )
+import PrelNames        ( breakpointJumpName, breakpointCondJumpName )
 import TysWiredIn       ( unitTy )
 import TypeRep          ( Type(..) )
+import TyCon            ( isUnLiftedTyCon )
 #endif
 
 import Match		( matchWrapper, matchSinglePat, matchEquations )
@@ -42,13 +43,13 @@ import TcHsSyn		( hsPatType, mkVanillaTuplePat )
 
 import TcType		( tcSplitAppTy, tcSplitFunTys, tcTyConAppTyCon, 
 			  tcTyConAppArgs, isUnLiftedType, Type, mkAppTy )
-import Type		( funArgTy, splitFunTys, isUnboxedTupleType, mkFunTy )
+import Type		( splitFunTys, isUnboxedTupleType, mkFunTy )
 import CoreSyn
 import CoreUtils	( exprType, mkIfThenElse, bindNonRec )
 
 import CostCentre	( mkUserCC )
 import Id		( Id, idType, idName, idDataCon )
-import PrelInfo		( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID )
+import PrelInfo		( rEC_CON_ERROR_ID )
 import DataCon		( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys )
 import DataCon		( isVanillaDataCon )
 import TyCon		( FieldLabel, tyConDataCons )
@@ -84,7 +85,9 @@ dsValBinds (ValBindsOut binds _) body = foldrDs ds_val_bind body binds
 -------------------------
 dsIPBinds (IPBinds ip_binds dict_binds) body
   = do	{ prs <- dsLHsBinds dict_binds
-	; let inner = foldr (\(x,r) e -> Let (NonRec x r) e) body prs 
+	; let inner = Let (Rec prs) body
+		-- The dict bindings may not be in 
+		-- dependency order; hence Rec
 	; foldrDs ds_ip_bind inner ip_binds }
   where
     ds_ip_bind (L _ (IPBind n e)) body
@@ -215,9 +218,9 @@ dsExpr expr@(HsLam a_Match)
 #if defined(GHCI) && defined(BREAKPOINT)
 dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _)
     | HsVar funId <- fun
-    , idName funId == breakpointJumpName
-    , ids <- filter (not.hasTyVar.idType) (extractIds arg)
-    = do dsWarn (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids))
+    , idName funId `elem` [breakpointJumpName, breakpointCondJumpName]
+    , ids <- filter (isValidType . idType) (extractIds arg)
+    = do warnDs (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids))
          stablePtr <- ioToIOEnv $ newStablePtr ids
          -- Yes, I know... I'm gonna burn in hell.
          let Ptr addr# = castStablePtrToPtr stablePtr
@@ -234,12 +237,13 @@ dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _)
               = error (showSDoc (ppr ts)) -- argId:extractIds (unLoc fn)
           extractIds x = []
           extractHVals ids = ExplicitList unitTy (map (L loc . HsVar) ids)
-          hasTyVar (TyVarTy _) = True
-          hasTyVar (FunTy a b) = hasTyVar a || hasTyVar b
-          hasTyVar (NoteTy _ t) = hasTyVar t
-          hasTyVar (AppTy a b) = hasTyVar a || hasTyVar b
-          hasTyVar (TyConApp _ ts) = any hasTyVar ts
-          hasTyVar _ = False
+          -- checks for tyvars and unlifted kinds.
+          isValidType (TyVarTy _) = False
+          isValidType (FunTy a b) = isValidType a && isValidType b
+          isValidType (NoteTy _ t) = isValidType t
+          isValidType (AppTy a b) = isValidType a && isValidType b
+          isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) && all isValidType ts
+          isValidType _ = True
 #endif
 
 dsExpr expr@(HsApp fun arg)      
@@ -277,20 +281,10 @@ dsExpr (OpApp e1 op _ e2)
     dsLExpr e2				`thenDs` \ y_core ->
     returnDs (mkApps core_op [x_core, y_core])
     
-dsExpr (SectionL expr op)
-  = dsLExpr op						`thenDs` \ core_op ->
-    -- for the type of y, we need the type of op's 2nd argument
-    let
-	(x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
-	-- Must look through an implicit-parameter type; 
-	-- newtype impossible; hence Type.splitFunTys
-    in
-    dsLExpr expr				`thenDs` \ x_core ->
-    newSysLocalDs x_ty			`thenDs` \ x_id ->
-    newSysLocalDs y_ty			`thenDs` \ y_id ->
-
-    returnDs (bindNonRec x_id x_core $
-	      Lam y_id (mkApps core_op [Var x_id, Var y_id]))
+dsExpr (SectionL expr op)	-- Desugar (e !) to ((!) e)
+  = dsLExpr op				`thenDs` \ core_op ->
+    dsLExpr expr			`thenDs` \ x_core ->
+    returnDs (App core_op x_core)
 
 -- dsLExpr (SectionR op expr)	-- \ x -> op x expr
 dsExpr (SectionR op expr)