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
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 )
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
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 {