diff options
| -rw-r--r-- | compiler/ghci/ByteCodeGen.lhs | 17 | ||||
| -rw-r--r-- | 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 95aae77671..888aeec739 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 50eae9f997..794459c458 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 |