import Outputable
import Name
+import MkId
import Id
import FiniteMap
import ForeignCall
-- 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?
-- - 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