[new eta expander than can look through cases and lets
John Meacham <john@repetae.net>**20060317002424] hunk ./DataConstructors.hs 4
+    DataTableMonad(..),
hunk ./DataConstructors.hs 10
+    expandAliases,
hunk ./DataConstructors.hs 507
+
+class Monad m => DataTableMonad m where
+    getDataTable :: m DataTable
+    getDataTable = return mempty
+
+
+instance DataTableMonad Identity
+
+expandAliases :: DataTableMonad m => E -> m E
+expandAliases e = do
+    dt <- getDataTable
+    return (followAliases dt e)
+
hunk ./E/Eta.hs 2
+    ArityType(ATop,ABottom),
hunk ./E/Eta.hs 4
+    annotateArity,
+    etaExpandDef,
+    etaExpandDef',
+    getArityInfo,
hunk ./E/Eta.hs 11
-import qualified Data.Set as Set
-import qualified Data.Map as Map
hunk ./E/Eta.hs 13
+import Data.Typeable
+import Maybe
+import qualified Data.Map as Map
+import qualified Data.Set as Set
hunk ./E/Eta.hs 25
+import E.Values
hunk ./E/Eta.hs 33
-manifestLambdas :: E -> Arity
-manifestLambdas e = Arity (f 0 e) where
-    f n (ELam _ e) = let n' = n + 1 in n' `seq` f n' e
-    f n _ = n
+
+data ArityType = AFun Bool ArityType | ABottom | ATop
+    deriving(Eq,Ord,Show,Typeable)
+
+arity at = f at 0 where
+    f (AFun _ a) n = f a $! (1 + n)
+    f x n | n `seq` x `seq` True = (x,n)
+
+getArityInfo tvr
+    | Just at <- Info.lookup (tvrInfo tvr) = arity at
+    | otherwise = (ATop,0)
+
+isOneShot x = False
+
+arityType :: E -> ArityType
+arityType e = f e where
+    f EError {} = ABottom
+    f (ELam x e) = AFun (isOneShot x) (f e)
+    f (EAp a b) = case f a of
+        AFun _ xs | isCheap b -> xs
+        _ -> ATop
+    f ec@ECase { eCaseScrutinee = scrut } = case foldr1 andArityType (map f $ caseBodies ec) of
+        xs@(AFun True _) -> xs
+        xs | isCheap scrut -> xs
+        _ -> ATop
+    f (ELetRec ds e) = case f e of
+        xs@(AFun True _) -> xs
+        xs | all isCheap (snds ds) -> xs
+        _ -> ATop
+    f (EVar tvr) | Just at <- Info.lookup (tvrInfo tvr) = at
+    f _ = ATop
+
+
+andArityType ABottom	    at2		  = at2
+andArityType ATop	    at2		  = ATop
+andArityType (AFun t1 at1)  (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
+andArityType at1	    at2		  = andArityType at2 at1
hunk ./E/Eta.hs 72
-letann e nfo = return (Info.insert (manifestLambdas e) nfo)
hunk ./E/Eta.hs 73
+annotateArity e nfo = annotateArity' (arityType e) nfo
+
+annotateArity' at nfo = Info.insert (Arity n) $ Info.insert at nfo where
+    (_,n) = arity at
+
+
+{-
hunk ./E/Eta.hs 83
-    prog <- annotateProgram mempty (const return) letann lamann prog
+    prog <- annotateProgram mempty (const return) annotateArity lamann prog
hunk ./E/Eta.hs 91
-    let Identity ds' = annotateDs mempty (const return) letann lamann ds
+    let Identity ds' = annotateDs mempty (const return) annotateArity lamann ds
hunk ./E/Eta.hs 94
+-}
+
+expandPis :: DataTable -> E -> E
+expandPis dataTable e = f (followAliases dataTable e) where
+    f (EPi v r) = EPi v (f (followAliases dataTable r))
+    f e = e
+
+
hunk ./E/Eta.hs 107
+{-
hunk ./E/Eta.hs 125
-        let (_,ts) = fromPi' dataTable (getType e)
+        let (_,ts) = expandPis dataTable (getType e)
hunk ./E/Eta.hs 133
+-}
hunk ./E/Eta.hs 151
+etaExpandDef' dataTable t e = etaExpandDef dataTable t e >>= \x -> case x of
+    Nothing -> return (t,e)
+    Just x -> return x
+
+etaExpandDef :: MonadStats m => DataTable -> TVr -> E -> m (Maybe (TVr,E))
+etaExpandDef _ _ e | isAtomic e = return Nothing -- will be inlined
+etaExpandDef dataTable t e  = ans where
+    fvs = freeVars (e,tvrType t)
+    at = arityType e
+    nameSupply = [ n |  n <- [2,4 :: Int ..], not $ n `Set.member` fvs  ]
+    ans = do
+        (ne,flag) <- f at e (expandPis dataTable $ tvrType t) nameSupply
+        if flag then return (Just (tvrInfo_u (annotateArity' at) t,ne)) else return Nothing
+    f (AFun _ a) (ELam tvr e) ty ns | (EPi _ rt) <- followAliases dataTable ty = do
+        (ne,flag) <- f a e rt ns
+        return (ELam tvr ne,flag)
+    f (AFun _ a) e (EPi tt rt) (n:ns) = do
+        mtick ("EtaExpand.def.{" ++ tvrShowName t)
+        let nv = tt { tvrIdent = n }
+            eb = EAp e (EVar nv)
+        (ne,_) <- f a eb rt ns
+        return (ELam nv ne,True)
+    f _ e _ _ = do
+        return (e,False)
+
hunk ./E/Eta.hs 178
-etaExpandAp dataTable t as | Just (Arity n) <- Info.lookup (tvrInfo t), n > length as = do
+etaExpandAp dataTable t as | Just at <- Info.lookup (tvrInfo t),let n = snd (arity at), n > length as = do
hunk ./E/SSimplify.hs 210
+                (t,e') <- etaExpandDef' (so_dataTable sopts) t e'
hunk ./Main.hs 25
+import E.Eta
hunk ./Main.hs 153
-letann e nfo = return (Info.insert (manifestLambdas e) nfo)
+letann e nfo = return (annotateArity e nfo)
hunk ./Main.hs 269
+            (v,lc) <- Stats.runStatIO stats (etaExpandDef' fullDataTable v lc)
hunk ./Main.hs 271
+            (v,lc) <- Stats.runStatIO stats (etaExpandDef' fullDataTable v lc)
hunk ./Main.hs 278
+            (v,lc) <- Stats.runStatIO stats (etaExpandDef' fullDataTable v lc)