From: Pepe Iborra Date: Mon, 27 Aug 2007 17:23:15 +0000 (+0000) Subject: Use a version of obtainTerm that takes a max depth bound X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=a27d12f02b8ab3a3222c351dcf7e9168dfe05fb0 Use a version of obtainTerm that takes a max depth bound when printing the contents of binding at a breakpoint --- diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index dffae16..bea11bf 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -601,7 +601,7 @@ afterRunStmt pred run_result = do tythings <- catMaybes `liftM` io (mapM (GHC.lookupName session) names) docs_ty <- mapM showTyThing tythings - terms <- mapM (io . GHC.obtainTerm session False) + terms <- mapM (io . GHC.obtainTermB session 10 False) [ id | (AnId id, Just _) <- zip tythings docs_ty] docs_terms <- mapM (io . showTerm session) terms printForUser $ vcat $ zipWith (\ty cts -> ty <> text " = " <> cts) diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 255c8e1..cafa527 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -8,7 +8,7 @@ module RtClosureInspect( - cvObtainTerm, -- :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term + cvObtainTerm, -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term Term(..), pprTerm, @@ -471,23 +471,25 @@ addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType >> return () -- TOMDO: what about the coercion? -- we should consider family instances - - -- Type & Term reconstruction -cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term -cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do +cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term +cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do tv <- newVar argTypeKind case mb_ty of - Nothing -> go tv tv hval >>= zonkTerm - Just ty | isMonomorphic ty -> go ty ty hval >>= zonkTerm + Nothing -> go bound tv tv hval >>= zonkTerm + Just ty | isMonomorphic ty -> go bound ty ty hval >>= zonkTerm Just ty -> do (ty',rev_subst) <- instScheme (sigmaType ty) addConstraint tv ty' - term <- go tv tv hval >>= zonkTerm + term <- go bound tv tv hval >>= zonkTerm --restore original Tyvars return$ mapTermType (substTy rev_subst) term where - go tv ty a = do + go bound _ _ _ | seq bound False = undefined + go 0 tv ty a = do + clos <- trIO $ getClosureData a + return (Suspension (tipe clos) (Just tv) a Nothing) + go bound tv ty a = do let monomorphic = not(isTyVarTy tv) -- This ^^^ is a convention. The ancestor tests for -- monomorphism and passes a type instead of a tv @@ -497,9 +499,9 @@ cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never -- force blackholes, because it would almost certainly result in deadlock, -- and showing the '_' is more useful. - t | isThunk t && force -> seq a $ go tv ty a + t | isThunk t && force -> seq a $ go (pred bound) tv ty a -- We always follow indirections - Indirection _ -> go tv ty $! (ptrs clos ! 0) + Indirection _ -> go (pred bound) tv ty $! (ptrs clos ! 0) -- The interesting case Constr -> do Right dcname <- dataConInfoPtrToName (infoPtr clos) @@ -513,7 +515,7 @@ cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do let tag = showSDoc (ppr dcname) vars <- replicateM (length$ elems$ ptrs clos) (newVar (liftedTypeKind)) - subTerms <- sequence [appArr (go tv tv) (ptrs clos) i + subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i | (i, tv) <- zip [0..] vars] return (Term tv (Left ('<' : tag ++ ">")) a subTerms) Just dc -> do @@ -536,7 +538,7 @@ cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do addConstraint myType signatureType subTermsP <- sequence $ drop extra_args -- ^^^ all extra arguments are pointed - [ appArr (go tv t) (ptrs clos) i + [ appArr (go (pred bound) tv t) (ptrs clos) i | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP] let unboxeds = extractUnboxed subTtypesNP clos subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds) @@ -544,9 +546,10 @@ cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do (drop extra_args subTtypes) return (Term tv (Right dc) a subTerms) -- The otherwise case: can be a Thunk,AP,PAP,etc. - otherwise -> - return (Suspension (tipe clos) (Just tv) a Nothing) + tipe_clos -> + return (Suspension tipe_clos (Just tv) a Nothing) +-- matchSubTypes dc ty | pprTrace "matchSubtypes" (ppr dc <+> ppr ty) False = undefined matchSubTypes dc ty | Just (_,ty_args) <- splitTyConApp_maybe (repType ty) -- assumption: ^^^ looks through newtypes diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 8df066c..145d6bd 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -94,7 +94,7 @@ module GHC ( isModuleInterpreted, compileExpr, HValue, dynCompileExpr, lookupName, - GHC.obtainTerm, GHC.obtainTerm1, reconstructType, + GHC.obtainTerm, GHC.obtainTerm1, GHC.obtainTermB, reconstructType, modInfoModBreaks, ModBreaks(..), BreakIndex, BreakInfo(breakInfo_number, breakInfo_module), @@ -1995,4 +1995,9 @@ obtainTerm sess force id = withSession sess $ \hsc_env -> obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term obtainTerm1 sess force mb_ty a = withSession sess $ \hsc_env -> InteractiveEval.obtainTerm1 hsc_env force mb_ty a + +obtainTermB :: Session -> Int -> Bool -> Id -> IO Term +obtainTermB sess bound force id = withSession sess $ \hsc_env -> + InteractiveEval.obtainTermB hsc_env bound force id + #endif diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index e189a58..7467c2e 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -29,7 +29,7 @@ module InteractiveEval ( isModuleInterpreted, compileExpr, dynCompileExpr, lookupName, - Term(..), obtainTerm, obtainTerm1, reconstructType, + Term(..), obtainTerm, obtainTerm1, obtainTermB, reconstructType, skolemiseSubst, skolemiseTy #endif ) where @@ -910,12 +910,17 @@ isModuleInterpreted s mod_summary = withSession s $ \hsc_env -> obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term obtainTerm1 hsc_env force mb_ty x = - cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x) + cvObtainTerm hsc_env maxBound force mb_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 force (Just$ idType id) hv + cvObtainTerm hsc_env maxBound force (Just$ idType id) hv -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic reconstructType :: HscEnv -> Bool -> Id -> IO (Maybe Type)