isModuleInterpreted,
compileExpr, dynCompileExpr,
lookupName,
- Term(..), obtainTerm, obtainTerm1, obtainTermB, reconstructType,
+ Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,
skolemiseSubst, skolemiseTy
#endif
) where
import InstEnv
import Var
import Id
-import IdInfo
import Name hiding ( varName )
import NameSet
import RdrName
import FastString
import MonadUtils
+import System.Directory
import Data.Dynamic
import Data.List (find)
import Control.Monad
import Control.Concurrent
import Data.List (sortBy)
import Foreign.StablePtr
+import System.IO
-- -----------------------------------------------------------------------------
-- running a statement interactively
clearWarnings
status <-
+ withVirtualCWD $
withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
let thing_to_run = unsafeCoerce# hval :: IO [HValue]
liftIO $ sandboxIO dflags' statusMVar thing_to_run
handleRunStatus expr bindings ids
breakMVar statusMVar status emptyHistory
+withVirtualCWD :: GhcMonad m => m a -> m a
+withVirtualCWD m = do
+ hsc_env <- getSession
+ let ic = hsc_IC hsc_env
+
+ let set_cwd = do
+ dir <- liftIO $ getCurrentDirectory
+ case ic_cwd ic of
+ Just dir -> liftIO $ setCurrentDirectory dir
+ Nothing -> return ()
+ return dir
+
+ reset_cwd orig_dir = do
+ virt_dir <- liftIO $ getCurrentDirectory
+ hsc_env <- getSession
+ let old_IC = hsc_IC hsc_env
+ setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
+ liftIO $ setCurrentDirectory orig_dir
+
+ gbracket set_cwd reset_cwd $ \_ -> m
+
+
emptyHistory :: BoundedList History
emptyHistory = nilBL 50 -- keep a log of length 50
let history' = mkHistory hsc_env apStack info `consBL` history
-- probably better make history strict here, otherwise
-- our BoundedList will be pointless.
- liftIO $ evaluate history'
+ _ <- liftIO $ evaluate history'
status <-
withBreakAction True (hsc_dflags hsc_env)
breakMVar statusMVar $ do
-- not "Interrupted", we unset the exception flag before throwing.
--
rethrow :: DynFlags -> IO a -> IO a
-#if __GLASGOW_HASKELL__ < 609
-rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
- case e of
- -- If -fbreak-on-error, we break unconditionally,
- -- but with care of not breaking twice
- _ | dopt Opt_BreakOnError dflags &&
- not(dopt Opt_BreakOnException dflags)
- -> poke exceptionFlag 1
-
- -- If it is an "Interrupted" exception, we allow
- -- a possible break by way of -fbreak-on-exception
- DynException d | Just Interrupted <- fromDynamic d
- -> return ()
-
- -- In any other case, we don't want to break
- _ -> poke exceptionFlag 0
-
- Exception.throwIO e
-#else
-rethrow dflags io = Exception.catch io $ \se@(SomeException e) -> do
+rethrow dflags io = Exception.catch io $ \se -> do
-- If -fbreak-on-error, we break unconditionally,
-- but with care of not breaking twice
if dopt Opt_BreakOnError dflags &&
not (dopt Opt_BreakOnException dflags)
then poke exceptionFlag 1
- else case cast e of
+ else case fromException se of
-- If it is an "Interrupted" exception, we allow
-- a possible break by way of -fbreak-on-exception
Just Interrupted -> return ()
_ -> poke exceptionFlag 0
Exception.throwIO se
-#endif
withInterruptsSentTo :: ThreadId -> IO r -> IO r
withInterruptsSentTo thread get_result = do
noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
noBreakAction True _ _ = return () -- exception: just continue
-resume :: GhcMonad m => SingleStep -> m RunResult
-resume step
+resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
+resume canLogSpan step
= do
hsc_env <- getSession
let ic = hsc_IC hsc_env
when (isStep step) $ liftIO setStepFlag
case r of
Resume expr tid breakMVar statusMVar bindings
- final_ids apStack info _ hist _ -> do
+ final_ids apStack info span hist _ -> do
+ withVirtualCWD $ do
withBreakAction (isStep step) (hsc_dflags hsc_env)
breakMVar statusMVar $ do
status <- liftIO $ withInterruptsSentTo tid $ do
-- this awakens the stopped thread...
takeMVar statusMVar
-- and wait for the result
- let hist' =
- case info of
- Nothing -> fromListBL 50 hist
- Just i -> mkHistory hsc_env apStack i `consBL`
+ let prevHistoryLst = fromListBL 50 hist
+ hist' = case info of
+ Nothing -> prevHistoryLst
+ Just i
+ | not $canLogSpan span -> prevHistoryLst
+ | otherwise -> mkHistory hsc_env apStack i `consBL`
fromListBL 50 hist
case step of
RunAndLogSteps ->
e_fs = fsLit "e"
e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
- exn_id = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
- vanillaIdInfo
+ exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
new_tyvars = unitVarSet e_tyvar
ictxt0 = hsc_IC hsc_env
-- _result in scope at any time.
let result_name = mkInternalName (getUnique result_fs)
(mkVarOccFS result_fs) span
- result_id = Id.mkGlobalId VanillaGlobal result_name result_ty
- vanillaIdInfo
+ result_id = Id.mkVanillaGlobal result_name result_ty
-- for each Id we're about to bind in the local envt:
-- - skolemise the type variables in its type, so they can't
-- - 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
loc = nameSrcSpan (idName id)
name = mkInternalName uniq occ loc
ty = idType id
- new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
+ new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
return new_id
rttiEnvironment :: HscEnv -> IO HscEnv
let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
incompletelyTypedIds =
[id | id <- tmp_ids
- , not $ null [v | v <- varSetElems$ tyVarsOfType (idType id)
- , isSkolemTyVar v]
+ , not $ noSkolems id
, (occNameFS.nameOccName.idName) id /= result_fs]
- tys <- reconstructType hsc_env 10 `mapM` incompletelyTypedIds
- -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
-
- improvs <- sequence [improveRTTIType hsc_env ty ty'
- | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
- let ic' = foldr (\mb_subst ic' ->
- maybe (WARN(True, text ("RTTI failed to calculate the "
- ++ "improvement for a type")) ic')
- (substInteractiveContext ic' . skolemiseSubst)
- mb_subst)
- ic
- improvs
- return hsc_env{hsc_IC=ic'}
-
-skolemiseSubst :: TvSubst -> TvSubst
-skolemiseSubst subst = subst `setTvSubstEnv`
- mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst)
+ hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
+ return hsc_env'
+ where
+ noSkolems = null . filter isSkolemTyVar . varSetElems . tyVarsOfType . idType
+ improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
+ let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
+ Just id = find (\i -> idName i == name) tmp_ids
+ if noSkolems id
+ then return hsc_env
+ else do
+ mb_new_ty <- reconstructType hsc_env 10 id
+ let old_ty = idType id
+ case mb_new_ty of
+ Nothing -> return hsc_env
+ Just new_ty -> do
+ mb_subst <- improveRTTIType hsc_env old_ty new_ty
+ case mb_subst of
+ Nothing -> return $
+ WARN(True, text (":print failed to calculate the "
+ ++ "improvement for a type")) hsc_env
+ Just subst -> do
+ when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $
+ printForUser stderr alwaysQualify $
+ fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
+
+ let (subst', skols) = skolemiseSubst subst
+ ic' = extendInteractiveContext
+ (substInteractiveContext ic subst') [] skols
+ return hsc_env{hsc_IC=ic'}
+
+skolemiseSubst :: TvSubst -> (TvSubst, TyVarSet)
+skolemiseSubst subst = let
+ varenv = getTvSubstEnv subst
+ all_together = mapVarEnv skolemiseTy varenv
+ (varenv', skol_vars) = ( mapVarEnv fst all_together
+ , map snd (varEnvElts all_together))
+ in (subst `setTvSubstEnv` varenv', unionVarSets skol_vars)
+
skolemiseTy :: Type -> (Type, TyVarSet)
skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
----------------------------------------------------------------------------
-- RTTI primitives
-obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term
-obtainTerm1 hsc_env force mb_ty x =
- cvObtainTerm hsc_env maxBound force mb_ty (unsafeCoerce# x)
+obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
+obtainTermFromVal hsc_env bound force ty x =
+ cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
-obtainTermB :: HscEnv -> Int -> Bool -> Id -> IO Term
-obtainTermB hsc_env bound force id = do
- hv <- Linker.getHValue hsc_env (varName id)
- cvObtainTerm hsc_env bound force (Just$ idType id) hv
-
-obtainTerm :: HscEnv -> Bool -> Id -> IO Term
-obtainTerm hsc_env force id = do
- hv <- Linker.getHValue hsc_env (varName id)
- cvObtainTerm hsc_env maxBound force (Just$ idType id) hv
+obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
+obtainTermFromId hsc_env bound force id = do
+ hv <- Linker.getHValue hsc_env (varName id)
+ cvObtainTerm hsc_env bound force (idType id) hv
-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
reconstructType hsc_env bound id = do
hv <- Linker.getHValue hsc_env (varName id)
- cvReconstructType hsc_env bound (Just$ idType id) hv
+ cvReconstructType hsc_env bound (idType id) hv
+
#endif /* GHCI */
+
projects / ghc-hetmet.git / blobdiff