From 709c9ce0ec4ecaabc1e4ee0f05dbad87fc6aca4d Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Mon, 20 Apr 2009 14:25:25 +0000 Subject: [PATCH] FIX #2845: Allow breakpoints on expressions with unlifted type It turns out we can easily support breakpoints on expressions with unlifted types, by translating case tick# of _ -> e into let f = \s . case tick# of _ -> e in f realWorld# instead of just a plain let-binding. This is the same trick that GHC uses for abstracting join points of unlifted type. In #2845, GHC has eta-expanded the tick expression, changing the result type from IO a to (# State#, a #), which was the reason the tick was suddenly being ignored. By supporting ticks on unlifted expressions we can make it work again, although some confusion might arise because _result will no longer be available (it now has unboxed-tuple type, so we can't bind it in the environment). The underlying problem here is that GHC does transformations like eta-expanding the tick expressions, and there's nothing we can do to prevent that. --- compiler/ghci/ByteCodeGen.lhs | 17 +++++++++++++++-- compiler/main/InteractiveEval.hs | 14 +++++++++----- 2 files changed, 24 insertions(+), 7 deletions(-) diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 95aae77..888aeec 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -17,6 +17,7 @@ import LibFFI import Outputable import Name +import MkId import Id import FiniteMap import ForeignCall @@ -454,9 +455,21 @@ schemeE d s p (AnnLet binds (_,body)) -- best way to calculate the free vars but it seemed like the least -- intrusive thing to do schemeE d s p exp@(AnnCase {}) - | Just (_tickInfo, rhs) <- isTickedExp' exp + | Just (_tickInfo, _rhs) <- isTickedExp' exp = if isUnLiftedType ty - then schemeE d s p (snd rhs) + then do + -- If the result type is unlifted, then we must generate + -- let f = \s . case tick# of _ -> e + -- in f realWorld# + -- When we stop at the breakpoint, _result will have an unlifted + -- type and hence won't be bound in the environment, but the + -- breakpoint will otherwise work fine. + id <- newId (mkFunTy realWorldStatePrimTy ty) + st <- newId realWorldStatePrimTy + let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyVarSet, exp))) + (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id) + (emptyVarSet, AnnVar realWorldPrimId))) + schemeE d s p letExp else do id <- newId ty -- Todo: is emptyVarSet correct on the next line? diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 50eae9f..794459c 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -609,18 +609,22 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- - tidy the type variables -- - globalise the Id (Ids are supposed to be Global, apparently). -- - let all_ids | isPointer result_id = result_id : new_ids - | otherwise = new_ids + let result_ok = isPointer result_id + && not (isUnboxedTupleType (idType result_id)) + + all_ids | result_ok = result_id : new_ids + | otherwise = new_ids (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys new_tyvars = unionVarSets tyvarss - let final_ids = zipWith setIdType all_ids tidy_tys + final_ids = zipWith setIdType all_ids tidy_tys ictxt0 = hsc_IC hsc_env ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars + Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ] - Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] + when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } - return (hsc_env1, result_name:names, span) + return (hsc_env1, if result_ok then result_name:names else names, span) where mkNewId :: OccName -> Id -> IO Id mkNewId occ id = do -- 1.7.10.4