module DDC.Core.Transform.Snip
( Snip (..)
, Config (..)
, configZero)
where
import DDC.Core.Analysis.Arity
import DDC.Core.Module
import DDC.Core.Exp
import DDC.Core.Compounds
import DDC.Core.Predicates
import qualified DDC.Core.Transform.LiftX as L
import qualified DDC.Type.Compounds as T
data Config
= Config
{
configSnipOverApplied :: Bool
, configSnipLetBody :: Bool
}
configZero :: Config
configZero
= Config
{ configSnipOverApplied = False
, configSnipLetBody = False }
class Snip (c :: * -> *) where
snip :: Ord n => Config -> c n -> c n
instance Snip (Module a) where
snip config mm
= let arities = aritiesOfModule mm
body' = snipX config arities (moduleBody mm) []
in mm { moduleBody = body' }
instance Snip (Exp a) where
snip config x
= snipX config emptyArities x []
snipX :: Ord n
=> Config
-> Arities n
-> Exp a n
-> [(Exp a n, a)]
-> Exp a n
snipX config arities x args
| XApp a fun arg <- x
= snipX config arities fun
$ (snipX config arities arg [], a) : args
| null args
= enterX config arities x
| otherwise
= let x' = enterX config arities x
in buildNormalisedApp config arities x' args
enterX config arities xx
= let down ars e
= snipX config (extendsArities arities ars) e []
in case xx of
XApp{}
-> error "DDC.Core.Transform.Snip: snipX shouldn't give us an XApp"
XVar{} -> xx
XCon{} -> xx
XType{} -> xx
XWitness{} -> xx
XLAM a b e
-> XLAM a b (down [(b,0)] e)
XLam a b e
-> XLam a b (down [(b,0)] e)
XLet a (LLet b x1) x2
-> let x1' = down [] x1
x2' = snipLetBody config a
$ down [(b, arityOfExp' x1')] x2
in XLet a (LLet b x1') x2'
XLet a (LRec lets) x2
-> let bs = map fst lets
xs = map snd lets
ars = zip bs (map arityOfExp' xs)
xs' = map (down ars) xs
x2' = snipLetBody config a $ down ars x2
in XLet a (LRec $ zip bs xs') x2'
XLet a (LLetRegions b bs) x2
-> let ars = zip bs (repeat 0)
x2' = snipLetBody config a $ down ars x2
in XLet a (LLetRegions b bs) x2'
XLet a (LWithRegion b) x2
-> let x2' = snipLetBody config a $ down [] x2
in XLet a (LWithRegion b) x2'
XCase a e alts
| isAtom e
-> let e' = down [] e
alts' = map (\(AAlt pat ae)
-> AAlt pat (down (aritiesOfPat pat) ae)) alts
in XCase a e' alts'
| otherwise
-> let e' = down [] e
alts' = [AAlt pat (down (aritiesOfPat pat) ae)
| AAlt pat ae <- alts]
xBody' = snipLetBody config a
$ XCase a (XVar a $ UIx 0)
(map (L.liftX 1) alts')
in XLet a (LLet (BAnon (T.tBot T.kData)) e')
xBody'
XCast a c e
-> XCast a c (down [] e)
buildNormalisedApp
:: Ord n
=> Config
-> Arities n
-> Exp a n
-> [(Exp a n,a)]
-> Exp a n
buildNormalisedApp _ _ f0 [] = f0
buildNormalisedApp config arities f0 args@( (_, annot) : _)
= make annot f0 args
where
tBot' = T.tBot T.kData
f0Arity
= case f0 of
XVar _ b
| Just arity <- getArity arities b
-> max arity 1
_ -> max (arityOfExp' f0) 1
make a xFun xsArgs
| isAtom xFun
= buildNormalisedFunApp config a f0Arity xFun xsArgs
| otherwise
= XLet a (LLet (BAnon tBot') xFun)
(snipLetBody config a
$ buildNormalisedFunApp config a f0Arity
(XVar a (UIx 0))
[ (L.liftX 1 x, a') | (x, a') <- xsArgs])
buildNormalisedFunApp
:: Ord n
=> Config
-> a
-> Int
-> Exp a n
-> [(Exp a n, a)]
-> Exp a n
buildNormalisedFunApp config an funArity xFun xsArgs
= let tBot' = T.tBot T.kData
argss = splitArgs xsArgs
xsLets = [ (x, a)
| (_, a, _, Just x) <- argss]
nLets = length xsLets
xsLets' = [ (L.liftX n x, a)
| (x, a) <- xsLets
| (n :: Int) <- [0..] ]
xFun' = L.liftX nLets xFun
xsArgs' = [if liftMe
then (L.liftX nLets xArg, a)
else (xArg, a)
| (xArg, a, liftMe, _) <- argss]
xFunApps
| configSnipOverApplied config
, length xsArgs' > funArity
, (xsSat, xsOver) <- splitAt funArity xsArgs'
= XLet an (LLet (BAnon tBot')
(makeXAppsWithAnnots xFun' xsSat))
(snipLetBody config an
$ makeXAppsWithAnnots
(XVar an (UIx 0))
[ (L.liftX 1 x, a) | (x, a) <- xsOver ])
| otherwise
= makeXAppsWithAnnots
xFun'
xsArgs'
in case xsLets' of
[] -> xFunApps
_ -> foldr (\(x, a) x' -> XLet a x x')
(snipLetBody config an xFunApps)
[ (LLet (BAnon tBot') x, a)
| (x, a) <- xsLets' ]
splitArgs
:: Ord n
=> [(Exp a n, a)]
-> [( Exp a n
, a
, Bool
, Maybe (Exp a n))]
splitArgs args
= reverse $ go 0 $ reverse args
where
go _n [] = []
go n ((xArg, a) : xsArgs)
| isAtom xArg
= (xArg, a, True, Nothing) : go n xsArgs
| otherwise
= (XVar a (UIx n), a, False, Just xArg) : go (n + 1) xsArgs
snipLetBody :: Config -> a -> Exp a n -> Exp a n
snipLetBody config a xx
| configSnipLetBody config
, not (isAtom xx)
, not (isXLet xx)
= let tBot' = T.tBot T.kData
in XLet a (LLet (BAnon tBot') xx)
(XVar a (UIx 0))
| otherwise
= xx
isAtom :: Exp a n -> Bool
isAtom xx
= case xx of
XVar{} -> True
XCon{} -> True
XType{} -> True
XWitness{} -> True
XCast _ _ x -> isAtom x
_ -> False
arityOfExp' :: Ord n => Exp a n -> Int
arityOfExp' xx
= case arityOfExp xx of
Nothing -> 0
Just a -> a