module E.Eta(
ArityType(ATop,ABottom),
etaExpandAp,
annotateArity,
deleteArity,
etaExpandDef,
etaExpandDef',
etaExpandProgram,
getArityInfo,
etaAnnotateProgram,
etaReduce
) where
import Control.Monad.Identity
import Control.Monad.State
import Control.Monad.Writer
import Data.Typeable
import DataConstructors
import E.Annotate
import E.E
import E.Inline
import E.Program
import E.Subst
import E.TypeCheck
import E.Values
import GenUtil hiding(replicateM_)
import Info.Types
import Name.Id
import Support.FreeVars
import Util.NameMonad
import Util.SetLike
import qualified Info.Info as Info
import qualified Stats
data ArityType = AFun Bool ArityType | ABottom | ATop
deriving(Eq,Ord,Typeable)
instance Show ArityType where
showsPrec _ ATop = ("ArT" ++)
showsPrec _ ABottom = ("ArB" ++)
showsPrec _ (AFun False r) = ('\\':) . shows r
showsPrec _ (AFun True r) = ("\\o" ++) . shows r
arity at = f at 0 where
f (AFun _ a) n = f a $! (1 + n)
f x n | n `seq` x `seq` True = (x,n)
f _ _ = error "Eta.arity: bad."
getArityInfo tvr
| Just at <- Info.lookup (tvrInfo tvr) = arity at
| otherwise = (ATop,0)
isOneShot x = getProperty prop_ONESHOT x
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
annotateArity e nfo = annotateArity' (arityType e) nfo
annotateArity' at nfo = Info.insert (Arity n (b == ABottom)) $ Info.insert at nfo where
(b,n) = arity at
deleteArity nfo = Info.delete (undefined :: Arity) $ Info.delete (undefined :: Arity) nfo
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
etaExpandProgram :: Stats.MonadStats m => Program -> m Program
etaExpandProgram prog = runNameMT (programMapDs f prog) where
f (t,e) = do etaExpandDef' (progDataTable prog) 0 t e
etaAnnotateProgram :: Program -> Program
etaAnnotateProgram prog = runIdentity $ programMapRecGroups mempty pass iletann pass f prog where
pass _ = return
iletann e nfo = return $ annotateArity e nfo
letann e nfo = case Info.lookup nfo of
Nothing -> put True >> return (annotateArity e nfo)
Just at -> do
let at' = arityType e
when (at /= at') (put True)
return $ annotateArity' at' nfo
f (rg,ts) = do
let (ts',fs) = runState (annotateCombs mempty pass letann pass ts) False
if fs then f (rg,ts') else return ts'
etaReduce :: E -> E
etaReduce e = f e where
f (ELam t (EAp x (EVar t'))) | t == t' && (tvrIdent t `notMember` (freeVars x :: IdSet)) = f x
f e = e
etaExpandDef' dataTable n t e = etaExpandDef dataTable n t e >>= \x -> case x of
Nothing -> return (tvrInfo_u (annotateArity e) t,e)
Just x -> return x
etaExpandDef :: (NameMonad Id m,Stats.MonadStats m)
=> DataTable
-> Int
-> TVr
-> E
-> m (Maybe (TVr,E))
etaExpandDef _ _ _ e | isAtomic e = return Nothing
etaExpandDef dataTable min t e = ans where
at = arityType e
zeroName = case fromAp e of
(EVar v,_) -> "use.{" ++ tvrShowName v
_ -> "random"
nameSupply = undefined
ans = do
(ne,flag) <- f min at e (expandPis dataTable $ infertype dataTable e) nameSupply
if flag then return (Just (tvrInfo_u (annotateArity' at) t,ne)) else return Nothing
f min (AFun _ a) (ELam tvr e) (EPi tvr' rt) _ns = do
(ne,flag) <- f (min 1) a e (subst tvr' (EVar tvr) rt) _ns
return (ELam tvr ne,flag)
f min (AFun _ a) e (EPi tt rt) _nns = do
if tvrIdent t == emptyId
then Stats.mtick ("EtaExpand." ++ zeroName)
else Stats.mtick ("EtaExpand.def.{" ++ tvrShowName t)
n <- newName
let nv = tt { tvrIdent = n }
eb = EAp e (EVar nv)
(ne,_) <- f (min 1) a eb (subst tt (EVar nv) rt) _nns
return (ELam nv ne,True)
f min a e (EPi tt rt) _nns | min > 0 = do
if tvrIdent t == emptyId
then Stats.mtick ("EtaExpand.min." ++ zeroName)
else Stats.mtick ("EtaExpand.min.def.{" ++ tvrShowName t)
n <- newName
let nv = tt { tvrIdent = n }
eb = EAp e (EVar nv)
(ne,_) <- f (min 1) a eb (subst tt (EVar nv) rt) _nns
return (ELam nv ne,True)
f _ _ e _ _ = do
return (e,False)
etaExpandAp :: (NameMonad Id m,Stats.MonadStats m) => DataTable -> TVr -> [E] -> m (Maybe E)
etaExpandAp dataTable tvr xs = do
r <- etaExpandDef dataTable 0 tvr { tvrIdent = emptyId} (foldl EAp (EVar tvr) xs)
return (fmap snd r)