Inline.hs

module E.Inline(
    app,
    programMapRecGroups,
    forceInline,
    programDecomposedDs,
    programMapProgGroups,
    forceNoinline,
    baseInlinability
    ) where

import Control.Monad.Writer
import Data.Monoid

import StringTable.Atom
import E.Annotate
import E.E
import E.Program
import E.Subst
import E.Values
import Support.FreeVars
import Info.Info(Info)
import Info.Types
import Name.Id
import Options
import Stats
import Util.Graph
import Util.SetLike
import qualified FlagOpts as FO
import qualified Info.Info as Info





-- | higher numbers mean we want to inline it more
baseInlinability t e
    | forceNoinline t = -15
    | forceSuperInline t = 10
    | forceInline t = 7
    | isAtomic e = 6
    | whnfOrBot e = 4
    | otherwise = 0

-- NOINLINE must take precidence because it is sometimes needed for correctness, while INLINE is surely an optimization.
forceInline :: HasProperties a => a -> Bool
forceInline x
    | forceNoinline props = False
    | not (fopts FO.InlinePragmas) = False
    | otherwise  = fromList [prop_INLINE,prop_WRAPPER,prop_SUPERINLINE] `intersects` props
    where props = getProperties x

forceSuperInline :: HasProperties a => a -> Bool
forceSuperInline x
    | forceNoinline props = False
    | not (fopts FO.InlinePragmas) = False
    | otherwise = member prop_SUPERINLINE props
    where props = getProperties x

forceNoinline :: HasProperties a => a -> Bool
forceNoinline x  = fromList [prop_HASRULE,prop_NOINLINE,prop_PLACEHOLDER] `intersects` getProperties x

app (e,[]) = return e
app (e,xs) = app' e xs

app' (ELit lc@LitCons { litName = n, litArgs = xs, litType = EPi ta tt }) (a:as)  = do
    mtick (toAtom $ "E.Simplify.typecon-reduce.{" ++ show n ++ "}" )
    app (ELit (lc { litArgs = xs ++ [a], litType = subst ta a tt }),as)
app' (ELit LitCons { litName = n, litArgs = es, litAliasFor = Just af }) bs@(_:_) = do
    mtick (toAtom $ "E.Simplify.newtype-reduce.{" ++ show n ++ "}" )
    app (foldl eAp af (es ++ bs),[])
app' (ELam tvr e) (a:as) = do
    mtick (toAtom "E.Simplify.beta-reduce")
    app (subst tvr a e,as)   -- TODO Fix quadradic substitution
    --app (eLet tvr a e,as)   -- TODO Fix quadradic substitution
app' (EPi tvr e) (a:as) = do
    mtick (toAtom "E.Simplify.pi-reduce")
    app (subst tvr a e,as)     -- Okay, types are small
app' ec@ECase {} xs = do
    mtick (toAtom "E.Simplify.case-application")
    let f e = app' e xs
    ec' <- caseBodiesMapM f ec
    let t = foldl eAp (eCaseType ec') xs
    return $ caseUpdate ec' { eCaseType = t }
app' (ELetRec ds e) xs = do
    mtick (toAtom "E.Simplify.let-application")
    e' <- app' e xs
    return $ eLetRec ds e'
app' (EError s t) xs = do
    mtick (toAtom "E.Simplify.error-application")
    return $ EError s (foldl eAp t xs)
app' e as = do
    return $ foldl EAp e as


-- | Map recursive groups, allowing an initial map to be passed in and it will
-- also propagate changes in the tvrInfo properly, and make sure nothing
-- shadows one of the global names.

programMapRecGroups :: Monad m =>
    IdMap (Maybe E)        -- ^ initial map to apply
    -> (Id -> Info -> m Info)   -- ^ annotate based on Id map
    -> (E -> Info -> m Info)    -- ^ annotate letbound bindings
    -> (E -> Info -> m Info)    -- ^ annotate lambdabound bindings
    -> ((Bool,[Comb]) -> m [Comb])  -- ^ bool is true if group is recursive.
    -> Program
    -> m Program
programMapRecGroups imap idann letann lamann f prog = do
    let g rs imap ((False,ds):rds) = do
            ds' <- annotateCombs imap idann letann lamann ds
            nds <- f (False,ds')
            g (nds:rs) (bm nds imap) rds
        g rs imap ((True,ds):rds) = do
            ds' <- annotateCombs imap idann letann lamann ds
            nds <- f (True,ds')
            let imap' = (bm nds imap)
            let smap = substMap' $ fromList [ (combIdent  x,EVar (combHead  x)) | x <- nds]
                nds' = [ combBody_u smap x | x <- nds]
            g (nds':rs) imap' rds
        g rs _ [] = return $ concat rs
        bm xs imap = fromList [ (combIdent c,Just $ EVar (combHead c)) | c <- xs ] `union` imap
    ds <- g [] imap $ programDecomposedCombs prog
    return $ programUpdate $ prog { progCombinators = ds }

{-
The boolean value represents whether the bindings are recursive.
-}
programDecomposedCombs :: Program -> [(Bool,[Comb])]
programDecomposedCombs prog = map f $ scc g where
    --g = newGraph (progCombinators prog) combIdent ( toList . (union $ progSeasoning prog) . (freeVars :: Comb -> IdSet))
    g = newGraph (progCombinators prog) combIdent ( toList . (freeVars :: Comb -> IdSet))
    f (Left c) = (False,[c])
    f (Right cs) = (True,cs)


programDecomposedDs :: Program -> [Either (TVr, E) [(TVr,E)]]
programDecomposedDs prog = decomposeDs $ programDs prog

programSubProgram prog rec ds = progCombinators_s ds prog {  progType = SubProgram rec, progEntry = fromList (map combIdent ds) }

{-
Map recursive program groups.

Consider the program:
x = y
y = z
z = y

This would call 'f [x]' and 'f [y,z]'.

The code is made by the need for substitutions. The names of bindings can't change
but their types or other associated info might.
-}
programMapProgGroups :: Monad m =>
    IdMap (Maybe E)        -- ^ initial map to apply
    -> (Program -> m Program)
    -> Program
    -> m Program
programMapProgGroups imap f prog = do
    let g prog' rs imap ((False,ds):rds) = do
            ds' <- annotateCombs imap nann nann nann ds
            nprog <- f (programSubProgram prog' False ds')
            let nds = progCombinators nprog
            g (unames nds nprog) (nds:rs) (bm nds imap) rds
        g prog' rs imap ((True,ds):rds) = do
            ds' <- annotateCombs imap nann nann nann ds
            nprog <- f (programSubProgram prog' True ds')
            let imap' = bm nds imap
                smap = substMap' $ fromList [ (combIdent  x,EVar (combHead  x)) | x <- nds]
                nds = progCombinators nprog
                nds' = [ combBody_u smap x | x <- nds]
            g (unames nds' nprog) (nds':rs) imap' rds
        g prog' rs _ [] = return $ (concat rs,prog')
        bm xs imap = fromList [ (combIdent c,Just $ EVar (combHead c)) | c <- xs ] `union` imap
        nann _ = return
        unames ds prog = prog { progExternalNames = progExternalNames prog `mappend` fromList (map combIdent ds) }
    (ds,prog'') <- g prog { progStats = mempty } [] imap $ programDecomposedCombs prog
    return $ programUpdate $ prog { progCombinators = ds, progStats = progStats prog `mappend` progStats prog'' }