X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=36e6f7c2c82fbdcab7b262133bec2fb0f55c7a22;hb=547bf6827f1fc3f2fb31bc6323cc0d33b445f32a;hp=77594f83387a58c35dcd9f80ec1b928447b77e33;hpb=c012323004263ba46ff6c8d3cc8987a881d79f99;p=ghc-hetmet.git diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 77594f8..36e6f7c 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -30,7 +30,7 @@ module InteractiveEval ( isModuleInterpreted, compileExpr, dynCompileExpr, lookupName, - Term(..), obtainTerm, obtainTerm1, obtainTermB, reconstructType, + Term(..), obtainTermFromId, obtainTermFromVal, reconstructType, skolemiseSubst, skolemiseTy #endif ) where @@ -47,7 +47,6 @@ import TcType hiding (typeKind) import InstEnv import Var import Id -import IdInfo import Name hiding ( varName ) import NameSet import RdrName @@ -72,6 +71,7 @@ import Outputable import FastString import MonadUtils +import System.Directory import Data.Dynamic import Data.List (find) import Control.Monad @@ -83,6 +83,7 @@ import Exception import Control.Concurrent import Data.List (sortBy) import Foreign.StablePtr +import System.IO -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -212,6 +213,7 @@ runStmt expr step = 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 @@ -227,6 +229,28 @@ runStmt expr step = 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 @@ -349,32 +373,13 @@ sandboxIO dflags statusMVar thing = -- 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 () @@ -382,7 +387,6 @@ rethrow dflags io = Exception.catch io $ \se@(SomeException e) -> do _ -> poke exceptionFlag 0 Exception.throwIO se -#endif withInterruptsSentTo :: ThreadId -> IO r -> IO r withInterruptsSentTo thread get_result = do @@ -456,6 +460,7 @@ resume step case r of Resume expr tid breakMVar statusMVar bindings final_ids apStack info _ hist _ -> do + withVirtualCWD $ do withBreakAction (isStep step) (hsc_dflags hsc_env) breakMVar statusMVar $ do status <- liftIO $ withInterruptsSentTo tid $ do @@ -542,8 +547,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do 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 @@ -594,8 +598,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- _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 @@ -629,7 +632,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = 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 @@ -637,26 +640,46 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do 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) @@ -969,23 +992,20 @@ isModuleInterpreted mod_summary = withSession $ \hsc_env -> ---------------------------------------------------------------------------- -- 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 */ +