[use new occurance analysis system in simplifier
John Meacham <john@repetae.net>**20060410093026] hunk ./E/SSimplify.hs 1
-module E.SSimplify(Occurance(..), simplifyE, simplifyDs, SimplifyOpts(..)) where
+module E.SSimplify(
+    Occurance(..),
+    simplifyE,
+    simplifyDs,
+    programPruneOccurance,
+    SimplifyOpts(..)
+    ) where
hunk ./E/SSimplify.hs 25
+import E.Program
hunk ./E/SSimplify.hs 46
+import Util.HasSize
hunk ./E/SSimplify.hs 51
+type Bind = (TVr,E)
+
hunk ./E/SSimplify.hs 62
-
+{-
hunk ./E/SSimplify.hs 66
-data StrictInfo = NoStrict | Strict
-    deriving(Typeable,Show)
hunk ./E/SSimplify.hs 130
+-}
+
+
+programPruneOccurance :: Program -> Program
+programPruneOccurance prog =
+    let dsIn = programDs prog
+        (dsIn',fvs) = collectDs dsIn $ if progClosed prog then mempty else fromList $ map (flip (,) Many) (map (tvrIdent . fst) dsIn)
+    in (programSetDs dsIn' prog)
+
+
+newtype OM a = OM (Writer OMap a)
+    deriving(Monad,Functor,MonadWriter OMap)
+
+unOM (OM a) = a
+
+newtype OMap = OMap (IdMap Occurance)
+   deriving(HasSize,SetLike,BuildSet (Id,Occurance),MapLike Id Occurance,Show,IsEmpty,Eq,Ord)
+
+instance Monoid OMap where
+    mempty = OMap mempty
+    mappend (OMap a) (OMap b) = OMap (andOM a b)
+
+-- | occurance analysis
+
+grump :: OM a -> OM (a,OMap)
+grump m = censor (const mempty) (listen m)
+
+collectOccurance :: E -> (E,IdMap Occurance) -- ^ (annotated expression, free variables mapped to their occurance info)
+collectOccurance e = (fe,omap)  where
+    (fe,OMap omap) = runWriter $ unOM (f e)
+    f e@ESort {} = return e
+    f e@Unknown {} = return e
+    f (EPi tvr@TVr { tvrIdent = 0, tvrType =  a} b) = arg $ do
+        a <- f a
+        b <- f b
+        return (EPi tvr { tvrType = a } b)
+    f (EPi tvr@(TVr { tvrIdent = n, tvrType =  a}) b) = arg $ do
+        a <- f a
+        (b,tfvs) <- grump (f b)
+        case mlookup n tfvs of
+            Nothing -> tell tfvs >>  return (EPi tvr { tvrIdent =  0, tvrType = a } b)
+            Just occ -> tell (mdelete n tfvs) >> return (EPi (annb occ tvr { tvrType = a }) b)
+    f (ELit (LitCons n as t)) = arg $ do
+        t <- f t
+        as <- mapM f as
+        return (ELit (LitCons n as t))
+    f (ELit (LitInt i t)) = do
+        t <- arg (f t)
+        return $ ELit (LitInt i t)
+    f (EPrim p as t) = arg $ do
+        t <- f t
+        as <- mapM f as
+        return (EPrim p as t)
+    f (EError err t) = do
+        t <- arg (f t)
+        return $ EError err t
+    f e | (b,as@(_:_)) <- fromLam e = do
+        (b',bvs) <- grump (f b)
+        (as',asfv) <- grump (arg $ mapM ftvr as)
+        let avs = bvs `andOM` asfv
+            as'' = map (annbind avs) as'
+        tell $ inLam $ foldr mdelete avs (map tvrIdent as)
+        return (foldr ELam b' as'')
+    f e | Just (x,t) <- from_unsafeCoerce e  = do x <- f x ; t <- (arg (f t)); return (prim_unsafeCoerce x t)
+    f (EVar tvr@TVr { tvrIdent = n, tvrType =  t}) = do
+        tell $ msingleton n Once
+        t <- arg (f t)
+        return $ EVar tvr { tvrType = t }
+    f e | (x,xs@(_:_)) <- fromAp e = do
+        x <- f x
+        xs <- arg (mapM f xs)
+        return (foldl EAp x xs)
+    f ec@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d} = do
+        scrut' <- f e
+        (d',fvb) <- grump (fmapM f d)
+        (as',fvas) <- mapAndUnzipM (grump . alt) as
+        let fidm = orMaps (fvb:fvas)
+        ct <- arg $ f (eCaseType ec)
+        b <- arg (ftvr b)
+        tell $ mdelete (tvrIdent b) fidm
+        return ec { eCaseScrutinee = scrut', eCaseAlts = as', eCaseBind = annbind fidm b, eCaseType = ct, eCaseDefault = d'}
+    f (ELetRec ds e) = do
+        (e',OMap fve) <- grump (f e)
+        let (ds''',fids) = collectDs ds fve
+        tell (OMap fids)
+        return (ELetRec ds''' e')
+    f e = error $ "SSimplify.collectOcc.f: " ++ show e
+    alt (Alt l e) = do
+        (e',fvs) <- grump (f e)
+        l <- arg (mapLitBindsM ftvr l)
+        l <- arg (fmapM f l)
+        let fvs' = foldr mdelete fvs (map tvrIdent $ litBinds l)
+            l' = mapLitBinds (annbind fvs) l
+        tell fvs'
+        return (Alt l' e')
+    arg m = do
+        let mm (OMap mp) = (OMap $ fmap (const Many) mp)
+        censor mm m
+    ftvr tvr = do
+        tt <- f (tvrType tvr)
+        return tvr { tvrType = tt }
+
+annb x tvr = tvrInfo_u (Info.insert x) tvr
+annbind idm tvr = case mlookup (tvrIdent tvr) idm of
+    Nothing -> annb Unused tvr { tvrIdent = 0 }
+    Just x -> annb x tvr
+mapLitBinds f (LitCons n es t) = LitCons n (map f es) t
+mapLitBinds f (LitInt e t) = LitInt e t
+mapLitBindsM f (LitCons n es t) = do
+    es <- mapM f es
+    return (LitCons n es t)
+mapLitBindsM f (LitInt e t) = return $  LitInt e t
+
+collectBinding :: Bind -> (Bind,IdMap Occurance)
+collectBinding (t,e) = runIdentity $ do
+    let (e',omap) = collectOccurance e
+        rvars = freeVars (Info.fetch (tvrInfo t) :: ARules) :: IdMap TVr
+        rvars' = fmap (const Many) rvars
+    return ((t,e'),omap `andOM` rvars')
+
+collectDs :: [Bind] -> (IdMap Occurance) -> ([Bind],IdMap Occurance)
+collectDs ds fve = runIdentity $ do
+    let ds' = map collectBinding ds
+    let graph = newGraph ds' (\ ((t,_),_) -> tvrIdent t) (\ (_,fv) -> mkeys fv)
+        rds = reachable graph (mkeys fve ++ [ tvrIdent t | (t,_) <- ds, getProperty prop_EXPORTED t])
+        graph' = newGraph rds (\ ((t,_),_) -> tvrIdent t) (\ (_,fv) -> mkeys fv)
+        (lb,ds'') =  findLoopBreakers (\ ((t,e),_) -> loopFunc t e) (const True) graph'
+        fids = foldl andOM mempty (fve:snds ds'')
+        ffids = fromList [ (tvrIdent t,lup t) | ((t,_),_) <- ds'' ]
+        cycNodes = (fromList $ [ tvrIdent v | ((v,_),_) <- cyclicNodes graph'] :: IdSet)
+        calcStrictInfo :: TVr -> TVr
+        calcStrictInfo t
+            | tvrIdent t `member` cycNodes = setProperty prop_CYCLIC t
+            | otherwise = t
+        lup t = case tvrIdent t `elem` [ tvrIdent t | ((t,_),_) <- lb] of
+            True -> LoopBreaker
+            False -> case getProperty prop_EXPORTED t of
+                True -> Many
+                False | Just r <- mlookup (tvrIdent t) fids -> r
+        ds''' = [ (calcStrictInfo $ annbind ffids t ,e) | ((t,e),_) <- ds'']
+        froo (t,e) = ((t {tvrType = t' },e),fvs) where
+            (t',fvs) = collectOccurance (tvrType t)
+        (ds'''',nfids) = unzip $ map froo ds'''
+        nfid' = fmap (const Many) (mconcat nfids)
+    return (ds'''',(nfid' `andOM` fids) S.\\ ffids)
+
hunk ./E/SSimplify.hs 281
-mapAndUnzip3M     :: (Monad m) => (a -> m (b,c,d)) -> [a] -> m ([b], [c], [d])
-mapAndUnzip3M f xs = sequence (map f xs) >>= return . unzip3
+inLam (OMap om) = OMap (fmap il om) where
+    il Once = OnceInLam
+    il _ = Many
hunk ./E/SSimplify.hs 285
-inLam Once = OnceInLam
-inLam _ = Many
-
-andOM x y = Map.unionWith andOcc x y
+andOM x y = munionWith andOcc x y
hunk ./E/SSimplify.hs 290
-orMaps ms = fmap orMany $ foldl (Map.unionWith (++)) mempty (map (fmap (:[])) ms)
+orMaps ms = OMap $ fmap orMany $ foldl (munionWith (++)) mempty (map (fmap (:[])) (map unOMap ms)) where
+    unOMap (OMap m) = m
hunk ./E/SSimplify.hs 349
+
hunk ./E/SSimplify.hs 352
-        let ((ELetRec dsIn' _),fvs,occ) = collectOcc sopts (ELetRec dsIn (eTuple (map EVar (fsts dsIn))))
-        addNames (map tvrIdent $ Map.keys occ)
-        addNames (idSetToList fvs)
-        let occ' = Map.mapKeysMonotonic tvrIdent occ
-            dsIn'' = runIdentity $ annotateDs mempty (\t nfo -> return $ maybe (Info.delete Many nfo) (flip Info.insert nfo) (mlookup t occ')) (\_ -> return) (\_ -> return) dsIn'
-        return dsIn''
+        let (dsIn',fvs) = collectDs dsIn (fromList $ map (flip (,) Many) (map (tvrIdent . fst) dsIn))
+        addNames (mkeys fvs)
+        --addNames (map tvrIdent $ Map.keys occ)
+        --let occ' = Map.mapKeysMonotonic tvrIdent occ
+        --    dsIn'' = runIdentity $ annotateDs mempty (\t nfo -> return $ maybe (Info.delete Many nfo) (flip Info.insert nfo) (mlookup t occ')) (\_ -> return) (\_ -> return) dsIn'
+        return dsIn'
hunk ./E/SSimplify.hs 372
-        let (e',_,_) = collectOcc sopts  e
+        let (e',_) = collectOccurance e
hunk ./E/SSimplify.hs 395
+    g e@(EVar tvr) sub inb = f e sub inb
hunk ./Ho/Library.hs 60
-    --return $ fixupHo $ mconcat (initialHo : map libraryHo (Map.elems ps))
-    return $ mconcat (initialHo : map libraryHo (Map.elems ps))
+    return $ fixupHo $ mconcat (initialHo : map libraryHo (Map.elems ps))
+    --return $ mconcat (initialHo : map libraryHo (Map.elems ps))
hunk ./Main.hs 479
-        prog = hoToProgram ho
+        prog = (hoToProgram ho) { progClosed = True }
hunk ./Main.hs 558
+    wdump FD.Lambdacube $ printProgram prog -- printCheckName dataTable (programE prog)
+    prog <- return $ SS.programPruneOccurance prog
+    putStrLn ">>>> after occurance analysis"
+    wdump FD.Lambdacube $ printProgram prog -- printCheckName dataTable (programE prog)
+
hunk ./Main.hs 934
-    putErrLn (render $ hang 4 (pprint tvr <+> text "::" <+> pty))
-    when (not tmatch) $
-        putErrLn (render $ hang 4 (pprint tvr <+> text "::" <+> pprint (tvrType tvr)))
+    putErrLn (render $ hang 4 (pprint tvr <+> text "::" <+> (pprint $ tvrType tvr)))
+    when (not tmatch || dump FD.EVerbose) $
+        putErrLn (render $ hang 4 (pprint tvr <+> text "::" <+> pty))