[lots of internal changes, bugs introduced.
John Meacham <john@repetae.net>**20051009114920] hunk ./E/E.hs 266
--- | construct a letret, throwing away empty declarations
---eLetRec :: [(TVr,E)] -> E -> E
---eLetRec ds e = f (filter ((/= 0) . tvrNum . fst) ds) where
---    f [] = e
---    f ds = ELetRec ds e
-
-
hunk ./E/Inline.hs 82
+    --app (eLet tvr a e,as)   -- TODO Fix quadradic substitution
hunk ./E/LetFloat.hs 51
-atomizeApps usedIds stats e = traverse travOptions { pruneRecord = varElim stats } f mempty (Map.fromAscList [ (i,NotKnown) | i <- Set.toAscList usedIds ]) e where
+atomizeApps usedIds stats e = liftM fst $ traverse travOptions { pruneRecord = varElim stats } f mempty (Map.fromAscList [ (i,NotKnown) | i <- Set.toAscList usedIds ]) e where
hunk ./E/LetFloat.hs 210
-coalesceLets stats e = traverse travOptions { pruneRecord = varElim stats } f mempty mempty e where
+coalesceLets stats e = liftM fst $ traverse travOptions { pruneRecord = varElim stats } f mempty mempty e where
hunk ./E/Traverse.hs 2
-module E.Traverse(TravM, newVarName, lookupBinding, newBinding, traverse, renameTraverse, renameTraverse', TravOptions(..), Binding(..), travOptions, emapE, emapE') where
-
-import E.E
-import E.Rules
-import E.TypeCheck
-import Data.FunctorM
+module E.Traverse(TravM, newVarName, lookupBinding, newBinding, traverse, renameTraverse, renameTraverse', runRename, TravOptions(..), Binding(..), travOptions, emapE, emapE') where
hunk ./E/Traverse.hs 4
+import Control.Monad.Identity
hunk ./E/Traverse.hs 7
+import Data.FunctorM
hunk ./E/Traverse.hs 9
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
hunk ./E/Traverse.hs 13
+import E.E
hunk ./E/Traverse.hs 15
+import E.Rules
hunk ./E/Traverse.hs 17
+import E.TypeCheck
hunk ./E/Traverse.hs 23
-import qualified Data.Map as Map
hunk ./E/Traverse.hs 31
+
hunk ./E/Traverse.hs 34
-    (e',MInt c) = runWriter $ traverse travOptions { pruneUnreachable = Nothing } (\_ (x,xs) -> lift (tell (MInt 1)) >> (return $ foldl EAp x xs)) mempty mempty  e
+    (e',MInt c) = runWriter $ liftM fst $ traverse travOptions { pruneUnreachable = Nothing } (\_ (x,xs) -> lift (tell (MInt 1)) >> (return $ foldl EAp x xs)) mempty mempty  e
hunk ./E/Traverse.hs 36
-    e' = traverse travOptions { pruneUnreachable = Nothing } (\_ (x,xs) -> (return $ foldl EAp x xs)) mempty mempty  e
+    e' = liftM fst $ traverse travOptions { pruneUnreachable = Nothing } (\_ (x,xs) -> (return $ foldl EAp x xs)) mempty mempty  e
+
+runRename :: Set.Set Int -> E -> (E,Set.Set Int)
+runRename set e = runIdentity $ traverse travOptions { pruneUnreachable = Nothing } (\_ (x,xs) -> (return $ foldl EAp x xs)) mempty (Map.fromList [ (v,NotKnown) | v <- Set.toAscList set])  e
hunk ./E/Traverse.hs 114
-traverse :: (MonadFix m,Monad m) => TravOptions m -> (Int -> (E,[E]) -> TravM m E) -> Subst -> (Map.Map Int Binding) -> E -> m E
-traverse (tOpt :: TravOptions m) func subst smap e = runNameMT $ initNames >> runReaderT (f e) (smap,subst,0::Int)  where
+traverse :: (MonadFix m,Monad m) => TravOptions m -> (Int -> (E,[E]) -> TravM m E) -> Subst -> (Map.Map Int Binding) -> E -> m (E,Set.Set Int)
+traverse (tOpt :: TravOptions m) func subst smap e = runNameMT' $ initNames >> runReaderT (f e) (smap,subst,0::Int)  where
hunk ./Ho.hs 4
+import Control.Monad.Identity
hunk ./Ho.hs 10
+import Maybe
+import Monad
hunk ./Ho.hs 25
-import Control.Monad.Identity
hunk ./Ho.hs 30
+import E.CPR
hunk ./Ho.hs 33
+import E.Pretty
hunk ./Ho.hs 35
+import E.Strictness
hunk ./Ho.hs 48
-import Maybe
-import Monad
hunk ./Ho.hs 477
-loadLibraries = f initialHo (optHls options)  where
-    f ho [] = return ho
-    f ho (fn:rs) = checkForHoFile fn >>= \x -> case x of
-        Nothing -> putErrDie $ "Library not found or invalid: " ++ show fn
-        Just (_,ho') -> f (ho' `mappend` ho) rs
+loadLibraries = do
+    initialHo <- getInitialHo
+    f initialHo (optHls options)  where
+        f ho [] = return ho
+        f ho (fn:rs) = checkForHoFile fn >>= \x -> case x of
+            Nothing -> putErrDie $ "Library not found or invalid: " ++ show fn
+            Just (_,ho') -> f (ho' `mappend` ho) rs
hunk ./Ho.hs 489
-    es = Map.fromList [  (n,(setProperty prop_INSTANCE $ tVr (atomIndex $ toAtom n) (getType v),v)) |  (n,v) <- constantMethods ] `mappend` es'
+    es = Map.fromList [  (n,(setProperties [prop_INSTANCE] $ tVr (atomIndex $ toAtom n) (getType v),v)) |  (n,v) <- constantMethods ] `mappend` es'
hunk ./Ho.hs 493
+
+getInitialHo :: IO Ho
+getInitialHo = do
+    return initialHo
+{-
+    let ds = Map.elems $ hoEs initialHo
+    cds <- E.Strictness.solveDs ds
+    cds <- return $ fst (E.CPR.cprAnalyzeBinds mempty cds)
+    mapM_ (\t -> putStrLn (prettyE (EVar t) <+> show (tvrInfo t))) (fsts cds)
+    return initialHo { hoEs = Map.fromList [ (n,v) | v <- cds | n <- Map.keys (hoEs initialHo) ] }
+    -}
hunk ./Info/Info.hs 74
-createTyp x = toAtom (show (typeOf x))
+createTyp (_::a) = toAtom (show (typeOf (undefined :: a)))
hunk ./Main.hs 60
+import qualified Util.Histogram as Histogram
hunk ./Main.hs 130
-    let Identity (ELetRec ds (ESort EStar)) = annotate imap (idann (hoRules ho) (hoProps ho) ) letann lamann (ELetRec (Map.elems $ hoEs ho) eStar)
-    return ho { hoEs = Map.fromAscList [ (k,d) | k <- Map.keys $ hoEs ho | d <- ds ] }
+    let f (ds,used) (v,lc) = ((v,lc'):ds,used `mappend` used') where
+            (lc',used') = runRename used lc
+        (nds,allUsed) = foldl f ([],Set.empty) (Map.elems $ hoEs ho)
+    let Identity (ELetRec ds (ESort EStar)) = annotate imap (idann (hoRules ho) (hoProps ho) ) letann lamann (ELetRec nds eStar)
+    wdump FD.Rules $ printRules (hoRules ho)
+    return ho { hoEs = Map.fromList [ (runIdentity $ fromId (tvrIdent v),d) |  d@(v,_) <- ds ], hoUsedIds = allUsed }
hunk ./Main.hs 163
+    wdump FD.Rules $ printRules allRules
hunk ./Main.hs 177
-        return ((n, shouldBeExported exports v,lc):ds,usedIds `mappend` collectIds lc)
+        let (lc',used') = runRename usedIds lc
+        return ((n, shouldBeExported exports v,lc'):ds,usedIds `mappend` used')
hunk ./Main.hs 181
+
hunk ./Main.hs 183
-    let f (ds,(smap,annmap)) (rec,ns) = do
+    let f (ds,(smap,annmap,idHist')) (rec,ns) = do
hunk ./Main.hs 186
-        wdump FD.Lambdacube $ putErrLn ("----\n" ++ show names)
+        when (dump FD.Lambdacube || dump FD.Pass) $ putErrLn ("----\n" ++ show names)
+        cds <- annotateDs annmap (idann (hoRules allHo) mempty) letann lamann [ (t,e) | (_,t,e) <- ns]
+        putStrLn "*** After annotate"
+        wdump FD.Lambdacube $ mapM_ (\ (v,lc) -> printCheckName' fullDataTable v lc) ([ (x,y) | (_,x,y) <- ns])
hunk ./Main.hs 195
-        cds <- annotateDs annmap (idann (hoRules allHo) (hoProps allHo)) letann lamann [ (t,e) | (_,t,e) <- ns]
hunk ./Main.hs 214
-        cds <- flip mapM (cds') $ \ (v,lc) -> do
-            lc <- mangle (return ()) False ("Barendregt: ") (return . barendregt) lc
-            lc <- doopt mangle False stats "SuperSimplify" cm lc
-            --lc <- mangle (return ()) False ("Barendregt: " ++ show n) (return . barendregt) lc
-            --lc <- doopt mangle False stats "Float Inward..." (\stats x -> return (floatInward allRules x)) lc
-            --lc <- doopt mangle False stats "SuperSimplify" cm lc
-            --wdump FD.Lambdacube $ printCheckName' fullDataTable v lc
-            return (v,lc)
+        let dd  (ds,used) (v,lc) = do
+                --lc <- mangle (return ()) False ("Barendregt: ") (return . barendregt) lc
+                let (lc', used') = runRename used lc
+                lc <- doopt mangle False stats "SuperSimplify" cm lc'
+                let (lc', used') = runRename used lc
+                return ((v,lc):ds,used' `mappend` used)
+        (cds,usedids) <- foldM dd ([],hoUsedIds ho) cds'
hunk ./Main.hs 224
+        --mapM_ (\t -> putStrLn (prettyE (EVar t) <+> show (tvrInfo t))) (fsts cds)
hunk ./Main.hs 227
+        --let uidMap = Map.fromAscList [  (id,Nothing :: Maybe E) | id <- Set.toAscList $ Set.unions [ collectIds e| (t,e) <- cds]]
+        let uidMap = Map.fromAscList [  (id,Nothing :: Maybe E) | id <- Set.toAscList usedids ]
+        --let idHist = idHist' `mappend` Histogram.unions [ idHistogram e| (t,e) <- cds]
+        --print idHist
hunk ./Main.hs 233
-        return (nvls ++ ds, (Map.fromList [ (tvrIdent v,lc) | (_,v,lc) <- nvls] `mappend` smap, Map.fromList [ (tvrIdent v,(Just (EVar v))) | (_,v,_) <- nvls] `mappend` annmap ) )
+        return (nvls ++ ds, (Map.fromList [ (tvrIdent v,lc) | (_,v,lc) <- nvls] `mappend` smap, Map.fromList [ (tvrIdent v,(Just (EVar v))) | (_,v,_) <- nvls] `Map.union` annmap `Map.union` uidMap , idHist' ))
hunk ./Main.hs 241
-    (ds,_) <- foldM f ([],(Map.fromList [ (tvrNum v,e) | (v,e) <- Map.elems (hoEs ho)], initMap)) (map fscc $ scc graph)
+    (ds,_) <- foldM f ([],(Map.fromList [ (tvrNum v,e) | (v,e) <- Map.elems (hoEs ho)], initMap, Set.empty)) (map fscc $ scc graph)
hunk ./Main.hs 277
+idHistogram e = execWriter $ annotate mempty (\id nfo -> tell (Histogram.singleton id) >> return nfo) (\_ -> return) (\_ -> return) e
hunk ./Main.hs 535
+    putErrLn (show $ tvrInfo tvr)
hunk ./NameMonad.hs 1
-module NameMonad(NameMonad(..), GenName(..), NameMT, runNameMT, freeNames) where
+module NameMonad(NameMonad(..), GenName(..), NameMT, runNameMT, runNameMT', freeNames) where
hunk ./NameMonad.hs 61
+runNameMT' :: (Monad m) => NameMT a1 m a -> m (a,Set.Set a1)
+runNameMT' (NameMT x) = do
+    (r,(used,bound)) <- runStateT x (Set.empty,Set.empty)
+    return (r,bound)
hunk ./NameMonad.hs 87
-
-    --getNames  = NameMT $ do
-    --    fmap Set.toList get