X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=e2a4f8e6088882806ac9d7b456530e181c552a69;hp=e68bf88d30b466a3793938acb47c72f0ce88453c;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hpb=0ffb4bedd21e52dd5d04d710aade581e2fc9b6a1

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index e68bf88..e2a4f8e 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -6,6 +6,13 @@
 --
 -----------------------------------------------------------------------------
 
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module RtClosureInspect(
   
      cvObtainTerm,      -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
@@ -77,6 +84,9 @@ import Control.Monad
 import Data.Maybe
 import Data.Array.Base
 import Data.List        ( partition )
+import qualified Data.Sequence as Seq
+import Data.Monoid
+import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
 import Foreign
 import System.IO.Unsafe
 
@@ -586,31 +596,31 @@ cvReconstructType hsc_env force mb_ty hval = runTR_maybe hsc_env $ do
    tv <- newVar argTypeKind
    case mb_ty of
      Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
-                          (uncurry go)  
-                          [(tv, hval)]  
+                          (uncurry go)
+                          (Seq.singleton (tv, hval))
                           max_depth
                    zonkTcType tv  -- TODO untested!
      Just ty | isMonomorphic ty -> return ty
-     Just ty -> do 
-              (ty',rev_subst) <- instScheme (sigmaType ty) 
+     Just ty -> do
+              (ty',rev_subst) <- instScheme (sigmaType ty)
               addConstraint tv ty'
-              search (isMonomorphic `fmap` zonkTcType tv) 
-                     (\(ty,a) -> go ty a) 
-                     [(tv, hval)]
+              search (isMonomorphic `fmap` zonkTcType tv)
+                     (\(ty,a) -> go ty a)
+                     (Seq.singleton (tv, hval))
                      max_depth
               substTy rev_subst `fmap` zonkTcType tv
     where 
 --  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
-  search stop expand [] depth  = return ()
+  search stop expand l depth | Seq.null l = return ()
   search stop expand x 0 = fail$ "Failed to reconstruct a type after " ++
                                 show max_depth ++ " steps"
-  search stop expand (x:xx) d  = unlessM stop $ do 
-    new <- expand x 
-    search stop expand (xx ++ new) $! (pred d)
+  search stop expand l d | x :< xx <- viewl l = unlessM stop $ do
+    new <- expand x
+    search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
 
    -- returns unification tasks,since we are going to want a breadth-first search
   go :: Type -> HValue -> TR [(Type, HValue)]
-  go tv a = do 
+  go tv a = do
     clos <- trIO $ getClosureData a
     case tipe clos of
       Indirection _ -> go tv $! (ptrs clos ! 0)
@@ -618,29 +628,31 @@ cvReconstructType hsc_env force mb_ty hval = runTR_maybe hsc_env $ do
         Right dcname <- dataConInfoPtrToName (infoPtr clos)
         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
         case mb_dc of
-          Nothing-> do 
+          Nothing-> do
                      --  TODO: Check this case
-            vars     <- replicateM (length$ elems$ ptrs clos) 
+            vars     <- replicateM (length$ elems$ ptrs clos)
                                    (newVar (liftedTypeKind))
-            subTerms <- sequence [ appArr (go tv) (ptrs clos) i 
+            subTerms <- sequence [ appArr (go tv) (ptrs clos) i
                                    | (i, tv) <- zip [0..] vars]    
             forM [0..length (elems $ ptrs clos)] $ \i -> do
-                        tv <- newVar liftedTypeKind 
+                        tv <- newVar liftedTypeKind
                         return$ appArr (\e->(tv,e)) (ptrs clos) i
 
-          Just dc -> do 
-            let extra_args = length(dataConRepArgTys dc) - 
+          Just dc -> do
+            let extra_args = length(dataConRepArgTys dc) -
                              length(dataConOrigArgTys dc)
             subTtypes <- mapMif (not . isMonomorphic)
                                 (\t -> newVar (typeKind t))
                                 (dataConRepArgTys dc)
+
             -- It is vital for newtype reconstruction that the unification step
             -- is done right here, _before_ the subterms are RTTI reconstructed
             let myType         = mkFunTys subTtypes tv
             (signatureType,_) <- instScheme(dataConRepType dc) 
             addConstraint myType signatureType
             return $ [ appArr (\e->(t,e)) (ptrs clos) i
-                       | (i,t) <- drop extra_args $ zip [0..] subTtypes]
+                       | (i,t) <- drop extra_args $ 
+                                     zip [0..] (filter isPointed subTtypes)]
       otherwise -> return []
 
      -- This helper computes the difference between a base type t and the