module DDC.Core.Transform.ANormal
(anormalise)
where
import DDC.Core.Exp
import qualified DDC.Type.Exp as T
import qualified DDC.Type.Compounds as T
import qualified DDC.Core.Transform.AnonymizeX as A
import qualified DDC.Core.Transform.LiftX as L
import qualified Data.Map as Map
type Arities n = (Map.Map n Int, [Int])
arEmpty :: Ord n => Arities n
arEmpty = (Map.empty, [])
arExtends :: Ord n => Arities n -> [(Bind n, Int)] -> Arities n
arExtends arity exts = foldl go arity exts
where go (named,anon) (BNone _t, _) = (named,anon)
go (named,anon) (BAnon _t, a) = (named, a:anon)
go (named,anon) (BName n _t, a) = (Map.insert n a named, anon)
arGet :: Ord n => Arities n -> Bound n -> Int
arGet (_named, anon) (UIx ix _) = anon !! ix
arGet (named, _anon) (UName n _) = named Map.! n
arGet (_named,_anon) (UPrim _ t) = arityOfType t
arityOfType :: Ord n => Type n -> Int
arityOfType (T.TForall _ t)
= 1 + arityOfType t
arityOfType t
= let (args, _) = T.takeTFunArgResult t in
length args
arityOfExp :: Ord n => Exp a n -> Int
arityOfExp (XLam _ _ e)
= 1 + arityOfExp e
arityOfExp (XLAM _ _ e)
= 1 + arityOfExp e
arityOfExp (XCon _ (UPrim _ t))
= arityOfType t
arityOfExp _
= 0
aritiesOfPat :: Ord n => Pat n -> [(Bind n, Int)]
aritiesOfPat PDefault = []
aritiesOfPat (PData _b bs) = zip bs (repeat 0)
anormal :: Ord n
=> Arities n
-> Exp a n
-> [(Exp a n,a)]
-> Exp a n
anormal ar (XApp a lhs rhs) args
=
let args' = (anormal ar rhs [], a) : args in
anormal ar lhs args'
anormal ar x args
= let x' = go x in
case args of
[] -> x'
_ -> flattenLets $ makeLets ar x' args
where
down ars e = anormal (arExtends ar ars) e []
go (XApp{}) = error "DDC.Core.Transform.ANormal.anormal: impossible XApp!"
go (XVar{}) = x
go (XCon{}) = x
go (XType{}) = x
go (XWitness{}) = x
go (XLAM a b e) =
XLAM a b (down [(b,0)] e)
go (XLam a b e) =
XLam a b (down [(b,0)] e)
go (XLet a (LLet m b le) re) =
let le' = down [] le in
let re' = down [(b, arityOfExp le')] re in
XLet a (LLet m b le') re'
go (XLet a (LRec lets) re) =
let bs = map fst lets in
let es = map snd lets in
let ars= zip bs (map arityOfExp es) in
let es'= map (down ars) es in
let re'= down ars re in
XLet a (LRec $ zip bs es') re'
go (XLet a (LLetRegion b bs) re) =
let ars = zip bs (repeat 0) in
XLet a (LLetRegion b bs) (down ars re)
go (XLet a (LWithRegion b) re) =
XLet a (LWithRegion b) (down [] re)
go (XCase a e alts) =
let e' = down [] e in
let alts' = map (\(AAlt pat ae) -> AAlt pat (down (aritiesOfPat pat) ae)) alts in
XCase a e' alts'
go (XCast a c e) =
XCast a c (down [] e)
anormalise :: Ord n => Exp a n -> Exp a n
anormalise x = anormal arEmpty x []
isNormal :: Ord n => Exp a n -> Bool
isNormal (XVar{}) = True
isNormal (XCon{}) = True
isNormal (XType{}) = True
isNormal (XWitness{}) = True
isNormal (XCast _ _ x) = isNormal x
isNormal _ = False
makeLets :: Ord n
=> Arities n
-> Exp a n
-> [(Exp a n,a)]
-> Exp a n
makeLets _ f0 [] = f0
makeLets ar f0 args@((_,annot):_) = go 0 (findArity f0) ((f0,annot):args) []
where
tBot = T.tBot T.kData
go i _arf [] acc = mkApps i 0 acc
go i arf ((x,a):xs) acc | length acc > arf
= XLet a (LLet LetStrict (BAnon tBot) (mkApps i 0 acc))
(go i 1 ((x,a):xs) [(XVar a $ UIx 0 tBot,a)])
go i arf ((x,a):xs) acc | isNormal x
= go i arf xs ((x,a):acc)
go i arf ((x,a):xs) acc
= XLet a (LLet LetStrict (BAnon tBot) (L.liftX i x))
(go (i+1) arf xs ((x,a):acc))
mkApps _ _ []
= error "DDC.Core.Transform.ANormal.makeLets.mkApps: impossible empty list"
mkApps l _ [(x,_)] | isNormal x
= L.liftX l x
mkApps _ i [(_,a)]
= XVar a $ UIx i tBot
mkApps l i ((x,a):xs) | isNormal x
= XApp a (mkApps l i xs) (L.liftX l x)
mkApps l i ((_,a):xs)
= XApp a (mkApps l (i+1) xs) (XVar a $ UIx i tBot)
findArity (XVar _ b) = max (arGet ar b) 1
findArity x = max (arityOfExp x) 1
flattenLets :: Ord n
=> Exp a n
-> Exp a n
flattenLets
(XLet a1
(LLet LetStrict b1
(XLet a2 (LLet LetStrict b2@(BAnon _) def2) x2))
x1)
=
let liftDepth = case b1 of { BAnon _ -> 1; _ -> 0 } in
let x1' = L.liftAtDepthX 1 liftDepth x1 in
XLet a2 (LLet LetStrict b2 def2) $
flattenLets $ XLet a1 (LLet LetStrict b1 x2) x1'
flattenLets
(XLet a1
(LLet LetStrict b1 inner@(XLet _ (LLet LetStrict _ _) _))
x1)
= flattenLets $
XLet a1
(LLet LetStrict b1 (A.anonymizeX inner))
x1
flattenLets (XLet a1 llet1 x1)
= XLet a1 llet1 (flattenLets x1)
flattenLets x = x