X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=ee3c6c6bf017b431f5f0bde7cb9f592848751e49;hb=e8db8f8ea957807dc6d4f134a147ef60bfd0ee93;hp=4fa3d8de680e955952f582a5e2881df0d4c1a67d;hpb=2c1ea2cedb1a8034b0828e24b554a35f56bb8924;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 4fa3d8d..ee3c6c6 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -16,8 +16,8 @@ import Var              ( mkTyVar, mkGlobalId )
 import IdInfo           ( GlobalIdDetails(..), vanillaIdInfo )
 import OccName          ( mkOccName, tvName )
 import SrcLoc           ( noSrcLoc  )
-import TysWiredIn       ( intTy, stringTy, mkListTy, unitTy )
-import PrelNames        ( breakpointJumpName )
+import TysWiredIn       ( intTy, stringTy, mkListTy, unitTy, boolTy )
+import PrelNames        ( breakpointJumpName, breakpointCondJumpName )
 import NameEnv          ( mkNameEnv )
 #endif
 
@@ -29,8 +29,7 @@ import HscTypes		( HscEnv(..), ModGuts(..), ModIface(..),
 			  Deprecs(..), FixityEnv, FixItem, 
 			  lookupType, unQualInScope )
 import Module		( Module, unitModuleEnv )
-import RdrName		( GlobalRdrEnv, emptyGlobalRdrEnv, 	
-			  LocalRdrEnv, emptyLocalRdrEnv )
+import RdrName		( GlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv )
 import Name		( Name, isInternalName, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc )
 import Type		( Type )
 import TcType		( tcIsTyVarTy, tcGetTyVar )
@@ -139,17 +138,23 @@ initTc hsc_env hsc_src mod do_this
                           unique <- newUnique ;
                           let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc;
                                 tyvar = mkTyVar var liftedTypeKind;
-                                breakpointJumpType = mkGlobalId
-                                                     (VanillaGlobal)
-                                                     (breakpointJumpName)
-                                                     (FunTy intTy
-                                                      (FunTy (mkListTy unitTy)
-                                                       (FunTy stringTy
-                                                        (ForAllTy tyvar
-                                                         (FunTy (TyVarTy tyvar)
-                                                          (TyVarTy tyvar))))))
-                                                     (vanillaIdInfo);
-                                new_env = mkNameEnv [(breakpointJumpName,AGlobal (AnId breakpointJumpType))];
+                                basicType extra = (FunTy intTy
+                                                   (FunTy (mkListTy unitTy)
+                                                    (FunTy stringTy
+                                                     (ForAllTy tyvar
+                                                      (extra
+                                                       (FunTy (TyVarTy tyvar)
+                                                        (TyVarTy tyvar)))))));
+                                breakpointJumpType
+                                    = mkGlobalId VanillaGlobal breakpointJumpName
+                                                 (basicType id) vanillaIdInfo;
+                                breakpointCondJumpType
+                                    = mkGlobalId VanillaGlobal breakpointCondJumpName
+                                                 (basicType (FunTy boolTy)) vanillaIdInfo;
+                                new_env = mkNameEnv [(breakpointJumpName
+                                                     , ATcId breakpointJumpType topLevel False)
+                                                     ,(breakpointCondJumpName
+                                                     , ATcId breakpointCondJumpType topLevel False)];
                               };
                           r <- tryM (updLclEnv (\gbl -> gbl{tcl_env=new_env}) do_this)
 #else
@@ -1011,8 +1016,10 @@ forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
 forkM_maybe doc thing_inside
  = do {	unsafeInterleaveM $
 	do { traceIf (text "Starting fork {" <+> doc)
-	   ; mb_res <- tryM thing_inside ;
-	     case mb_res of
+	   ; mb_res <- tryM $
+		       updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ 
+		       thing_inside
+	   ; case mb_res of
 		Right r  -> do	{ traceIf (text "} ending fork" <+> doc)
 				; return (Just r) }
 		Left exn -> do {