module DDC.Core.Salt.Transfer
(transferModule)
where
import DDC.Core.Salt.Convert.Base
import DDC.Core.Salt.Runtime
import DDC.Core.Salt.Name
import DDC.Core.Salt.Env
import DDC.Core.Predicates
import DDC.Core.Compounds
import DDC.Core.Module
import DDC.Core.Exp
import DDC.Core.Check (AnTEC(..))
import Data.Map (Map)
import qualified Data.Map as Map
transferModule
:: Module (AnTEC a Name) Name
-> Either (Error (AnTEC a Name))
(Module (AnTEC a Name) Name)
transferModule mm@ModuleCore{}
| XLet a (LRec bxs) x1 <- moduleBody mm
= let bxs' = map transLet bxs
in Right $ mm { moduleBody = XLet a (LRec bxs') x1 }
| otherwise
= Left (ErrorNoTopLevelLetrec mm)
transLet :: (Bind Name, Exp (AnTEC a Name) Name)
-> (Bind Name, Exp (AnTEC a Name) Name)
transLet (BName n t, x)
= let tails = Map.singleton n t
x' = transSuper tails x
in (BName n t, x')
transLet tup
= tup
transSuper
:: Map Name (Type Name)
-> Exp (AnTEC a Name) Name
-> Exp (AnTEC a Name) Name
transSuper tails xx
= let down = transSuper tails
in case xx of
XVar a _ -> xReturn a (annotType a) xx
XCon a _ -> xReturn a (annotType a) xx
XLAM a b x -> XLAM a b $ down x
XLam a b x -> XLam a b $ down x
XApp{}
| Just (xv@(XVar a (UName n)), args) <- takeXApps xx
, Just tF <- Map.lookup n tails
, (xsArgsType, xsArgsMore) <- span isXType args
, (xsArgsWit, xsArgsVal) <- span isXWitness xsArgsMore
, not $ any isXType xsArgsVal
, not $ any isXWitness xsArgsVal
, (_, tsValArgs, tResult) <- takeTFunWitArgResult $ eraseTForalls tF
-> let arity = length xsArgsVal
p = PrimCallTail arity
u = UPrim (NamePrimOp (PrimCall p)) (typeOfPrimCall p)
in xApps a (XVar a u)
$ (map (XType a) (tsValArgs ++ [tResult]))
++ [xApps a xv (xsArgsType ++ xsArgsWit)]
++ xsArgsVal
XApp a x1 x2
-> let x1' = transX tails x1
x2' = transX tails x2
in addReturnX a (annotType a) (XApp a x1' x2')
XLet a lts x -> XLet a (transL tails lts) (down x)
XCase a x alts -> XCase a (transX tails x) (map (transA tails) alts)
XCast a c x -> XCast a c (transSuper tails x)
XType{} -> xx
XWitness{} -> xx
addReturnX :: a -> Type Name
-> Exp a Name -> Exp a Name
addReturnX a t xx
| Just (NamePrimOp p, _) <- takeXPrimApps xx
, PrimControl{} <- p
= xx
| otherwise
= xReturn a t xx
transL :: Map Name (Type Name)
-> Lets (AnTEC a Name) Name
-> Lets (AnTEC a Name) Name
transL tails lts
= case lts of
LLet b x -> LLet b (transX tails x)
LRec bxs -> LRec [(b, transX tails x) | (b, x) <- bxs]
LPrivate{} -> lts
LWithRegion{} -> lts
transA :: Map Name (Type Name)
-> Alt (AnTEC a Name) Name
-> Alt (AnTEC a Name) Name
transA tails aa
= case aa of
AAlt p x -> AAlt p (transSuper tails x)
transX :: Map Name (Type Name)
-> Exp (AnTEC a Name) Name
-> Exp (AnTEC a Name) Name
transX tails xx
= let down = transX tails
in case xx of
XVar{} -> xx
XCon{} -> xx
XLAM{} -> xx
XLam{} -> xx
XApp a x1 x2 -> XApp a (down x1) (down x2)
XLet{} -> xx
XCase{} -> xx
XCast{} -> xx
XType{} -> xx
XWitness{} -> xx