From: Pepe Iborra Date: Tue, 24 Apr 2007 10:23:13 +0000 (+0000) Subject: We no longer instantiate tyvars to Unknown types in the :print mechanism X-Git-Tag: 2007-05-06~115 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=cb429c8ac482f3b294f709b5ba50423fdf1f35b0 We no longer instantiate tyvars to Unknown types in the :print mechanism Instead, we keep the original tyvars. The plan is to exploit type relationships among closures to recover more types. --- diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 4f721d1..ea1e7f3 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -62,12 +62,11 @@ pprintClosureCommand bindThings force str = do mb_new_ids <- mapM (io . go cms) (catMaybes mb_ids) io$ updateIds cms (catMaybes mb_new_ids) where - -- Find the Id, clean up 'Unknowns' in the idType + -- Find the Id cleanUp :: Session -> [Name] -> String -> IO (Maybe Id) cleanUp cms newNames str = do tythings <- GHC.parseName cms str >>= mapM (GHC.lookupName cms) - return$ listToMaybe (map (stripUnknowns newNames) - [ i | Just (AnId i) <- tythings]) + return$ listToMaybe [ i | Just (AnId i) <- tythings] -- Do the obtainTerm--bindSuspensions-refineIdType dance -- Warning! This function got a good deal of side-effects @@ -83,10 +82,8 @@ pprintClosureCommand bindThings force str = do showDocWith LeftMode (doc (mkErrStyle unqual)) (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm) -- Before leaving, we compare the type obtained to see if it's more specific - -- Note how we need the Unknown-clear type returned by obtainTerm let Just reconstructedType = termType term - new_type <- instantiateTyVarsToUnknown cms - (mostSpecificType (idType id) reconstructedType) + new_type = mostSpecificType (idType id) reconstructedType return . Just $ setIdType id new_type updateIds :: Session -> [Id] -> IO () @@ -129,9 +126,8 @@ bindSuspensions cms@(Session ref) t = do availNames_var <- newIORef availNames (t', stuff) <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t let (names, tys, hvals) = unzip3 stuff - concrete_tys <- mapM (instantiateTyVarsToUnknown cms) tys let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo - | (name,ty) <- zip names concrete_tys] + | (name,ty) <- zip names tys] new_type_env = extendTypeEnvWithIds type_env ids new_rn_env = extendLocalRdrEnv rn_env names new_ic = ictxt { ic_rn_local_env = new_rn_env, @@ -208,45 +204,3 @@ newGrimName cms userName = do occname = mkOccName varName userName name = mkInternalName unique occname noSrcLoc return name - --- | The inverse function. Strip the GHC.Base.Unknowns in the type of the id, they correspond to tyvars. The caller must provide an infinite list of fresh names -stripUnknowns :: [Name] -> Id -> Id -stripUnknowns names id = setIdType id . fst . go names . idType - $ id - where - go tyvarsNames@(v:vv) ty - | Just (ty1,ty2) <- splitFunTy_maybe ty = let - (ty1',vv') = go tyvarsNames ty1 - (ty2',vv'')= go vv' ty2 - in (mkFunTy ty1' ty2', vv'') - | Just (ty1,ty2) <- splitAppTy_maybe ty = let - (ty1',vv') = go tyvarsNames ty1 - (ty2',vv'')= go vv' ty2 - in (mkAppTy ty1' ty2', vv'') - | Just (tycon, args) <- splitTyConApp_maybe ty - , Just (tycon', vv') <- (fixTycon tycon tyvarsNames) - , (args',vv'') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg - in (arg':aa,vv')) - ([],vv') args - = (mkAppTys tycon' args',vv'') - | Just (tycon, args) <- splitTyConApp_maybe ty - , (args',vv') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg - in (arg':aa,vv')) - ([],tyvarsNames) args - = (mkTyConApp tycon args',vv') - | otherwise = (ty, tyvarsNames) - where fixTycon tycon (v:vv) = do - k <- lookup (tyConName tycon) kinds - return (mkTyVarTy$ mkTyVar v k, vv) - kinds = [ (unknownTyConName, liftedTypeKind) - , (unknown1TyConName, kind1) - , (unknown2TyConName, kind2) - , (unknown3TyConName, kind3)] - kind1 = mkArrowKind liftedTypeKind liftedTypeKind - kind2 = mkArrowKind kind1 liftedTypeKind - kind3 = mkArrowKind kind2 liftedTypeKind - -instantiateTyVarsToUnknown :: Session -> Type -> IO Type -instantiateTyVarsToUnknown (Session ref) ty - = do hsc_env <- readIORef ref - DebuggerTys.instantiateTyVarsToUnknown hsc_env ty diff --git a/compiler/ghci/DebuggerTys.hs b/compiler/ghci/DebuggerTys.hs deleted file mode 100644 index 5ea3a6a..0000000 --- a/compiler/ghci/DebuggerTys.hs +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------ --- --- GHCi Interactive debugging commands --- --- Pepe Iborra (supported by Google SoC) 2006 --- ------------------------------------------------------------------------------ - -module DebuggerTys (instantiateTyVarsToUnknown) where - -import HscTypes -import Type -import TcRnDriver -import Var -import PrelNames -import TyCon -import DataCon - -import Control.Monad - ----------------------------------------------------------------------------- --- | Replace all the tyvars in a Term with the opaque type GHC.Base.Unknown ----------------------------------------------------------------------------- -instantiateTyVarsToUnknown :: HscEnv -> Type -> IO Type -instantiateTyVarsToUnknown hsc_env ty --- We have a GADT, so just fix its tyvars - | Just (tycon, args) <- splitTyConApp_maybe ty - , tycon /= funTyCon - , isGADT tycon - = mapM fixTyVars args >>= return . mkTyConApp tycon --- We have a regular TyCon, so map recursively to its args - | Just (tycon, args) <- splitTyConApp_maybe ty - , tycon /= funTyCon - = do unknownTyVar <- unknownTV - args' <- mapM (instantiateTyVarsToUnknown hsc_env) args - return$ mkTyConApp tycon args' --- we have a tyvar of kind * - | Just tyvar <- getTyVar_maybe ty - , ([],_) <- splitKindFunTys (tyVarKind tyvar) - = unknownTV --- we have a higher kind tyvar, so insert an unknown of the appropriate kind - | Just tyvar <- getTyVar_maybe ty - , (args,_) <- splitKindFunTys (tyVarKind tyvar) - = liftM mkTyConTy $ unknownTC !! length args --- Base case - | otherwise = return ty - - where unknownTV = do - Just (ATyCon unknown_tc) <- tcRnLookupName hsc_env unknownTyConName - return$ mkTyConTy unknown_tc - unknownTC = [undefined, unknownTC1, unknownTC2, unknownTC3] - unknownTC1 = do - Just (ATyCon unknown_tc) <- tcRnLookupName hsc_env unknown1TyConName - return unknown_tc - unknownTC2 = do - Just (ATyCon unknown_tc) <- tcRnLookupName hsc_env unknown2TyConName - return unknown_tc - unknownTC3 = do - Just (ATyCon unknown_tc) <- tcRnLookupName hsc_env unknown3TyConName - return unknown_tc --- isGADT ty | pprTrace' "isGADT" (ppr ty <> colon <> ppr(isGadtSyntaxTyCon ty)) False = undefined - isGADT tc | Just dcs <- tyConDataCons_maybe tc = any (not . null . dataConEqSpec) dcs - | otherwise = False - fixTyVars ty - | Just (tycon, args) <- splitTyConApp_maybe ty - = mapM fixTyVars args >>= return . mkTyConApp tycon --- Fix the tyvar so that the interactive environment doesn't choke on it TODO - | Just tv <- getTyVar_maybe ty = return ty --TODO - | otherwise = return ty - diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index b98d61a..e8157ac 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -464,10 +464,12 @@ newVar = liftTcM . newFlexiTyVar liftTcM = id -instScheme :: Type -> TR TcType -instScheme ty = liftTcM$ liftM trd (tcInstType (liftM fst3 . tcInstTyVars) ty) - where fst3 (x,y,z) = x - trd (x,y,z) = z +-- | Returns the instantiated type scheme ty', and the substitution sigma +-- such that sigma(ty') = ty +instScheme :: Type -> TR (TcType, TvSubst) +instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do + (tvs',theta,ty') <- tcInstType (mapM tcInstTyVar) ty + return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs)) cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term cvObtainTerm hsc_env force mb_ty a = do @@ -488,14 +490,19 @@ cvObtainTerm hsc_env force mb_ty a = do cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do - tv <- case (isMonomorphic `fmap` mb_ty) of - Just True -> return (fromJust mb_ty) - _ -> do - tv_ <- liftM mkTyVarTy (newVar argTypeKind) - when (isJust mb_ty) $ - instScheme (sigmaType$ fromJust mb_ty) >>= addConstraint tv_ - return tv_ - go tv (fromMaybe tv mb_ty) hval + tv <- liftM mkTyVarTy (newVar argTypeKind) + case mb_ty of + Nothing -> go tv tv hval + Just ty | isMonomorphic ty -> go ty ty hval + Just ty -> do + (ty',rev_subst) <- instScheme (sigmaType$ fromJust mb_ty) + addConstraint tv ty' + term <- go tv tv hval + --restore original Tyvars + return$ flip foldTerm term idTermFold { + fTerm = \ty dc hval tt -> Term (substTy rev_subst ty) dc hval tt, + fSuspension = \ct mb_ty hval n -> + Suspension ct (substTy rev_subst `fmap` mb_ty) hval n} where go tv ty a = do let monomorphic = not(isTyVarTy tv) -- This is a convention. The ancestor tests for @@ -522,7 +529,7 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do -- right here, _before_ the subterms are RTTI reconstructed. when (not monomorphic) $ do let myType = mkFunTys (reOrderTerms subTermTvs subTtypesNP subTtypes) tv - instScheme(dataConRepType dc) >>= addConstraint myType + instScheme(dataConRepType dc) >>= addConstraint myType . fst subTermsP <- sequence $ drop extra_args -- all extra arguments are pointed [ appArr (go tv t) (ptrs clos) i | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP] diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 3b1d917..2a2f5c1 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -2310,7 +2310,7 @@ extendEnvironment hsc_env apStack idsOffsets = do let (ids, hValues) = unzip idsVals let names = map idName ids let global_ids = map globaliseAndTidy ids - typed_ids <- mapM instantiateIdType global_ids + typed_ids <- return global_ids -- mapM instantiateIdType global_ids let ictxt = hsc_IC hsc_env rn_env = ic_rn_local_env ictxt type_env = ic_type_env ictxt @@ -2334,12 +2334,6 @@ extendEnvironment hsc_env apStack idsOffsets = do = let tidied_type = tidyTopType$ idType id in setIdType (globaliseId VanillaGlobal id) tidied_type - -- | Instantiate the tyVars with GHC.Base.Unknown - instantiateIdType :: Id -> IO Id - instantiateIdType id = do - instantiatedType <- instantiateTyVarsToUnknown hsc_env (idType id) - return$ setIdType id instantiatedType - ----------------------------------------------------------------------------- -- show a module and it's source/object filenames