Commit 709c9ce0 authored by Simon Marlow's avatar Simon Marlow

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.
parent e562d3a5
...@@ -17,6 +17,7 @@ import LibFFI ...@@ -17,6 +17,7 @@ import LibFFI
import Outputable import Outputable
import Name import Name
import MkId
import Id import Id
import FiniteMap import FiniteMap
import ForeignCall import ForeignCall
...@@ -454,9 +455,21 @@ schemeE d s p (AnnLet binds (_,body)) ...@@ -454,9 +455,21 @@ schemeE d s p (AnnLet binds (_,body))
-- best way to calculate the free vars but it seemed like the least -- best way to calculate the free vars but it seemed like the least
-- intrusive thing to do -- intrusive thing to do
schemeE d s p exp@(AnnCase {}) schemeE d s p exp@(AnnCase {})
| Just (_tickInfo, rhs) <- isTickedExp' exp | Just (_tickInfo, _rhs) <- isTickedExp' exp
= if isUnLiftedType ty = 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 else do
id <- newId ty id <- newId ty
-- Todo: is emptyVarSet correct on the next line? -- Todo: is emptyVarSet correct on the next line?
......
...@@ -609,18 +609,22 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do ...@@ -609,18 +609,22 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
-- - tidy the type variables -- - tidy the type variables
-- - globalise the Id (Ids are supposed to be Global, apparently). -- - globalise the Id (Ids are supposed to be Global, apparently).
-- --
let all_ids | isPointer result_id = result_id : new_ids let result_ok = isPointer result_id
| otherwise = new_ids && not (isUnboxedTupleType (idType result_id))
all_ids | result_ok = result_id : new_ids
| otherwise = new_ids
(id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
(_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
new_tyvars = unionVarSets tyvarss 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 ictxt0 = hsc_IC hsc_env
ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ] 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 } 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 where
mkNewId :: OccName -> Id -> IO Id mkNewId :: OccName -> Id -> IO Id
mkNewId occ id = do mkNewId occ id = do
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment