module DDC.Core.Transform.Boxing
( Rep (..)
, Config (..)
, boxingModule)
where
import DDC.Core.Module
import DDC.Core.Exp.Annot
import DDC.Core.Pretty
import DDC.Type.Transform.Instantiate
import Data.Maybe
data Rep
= RepNone
| RepBoxed
| RepUnboxed
deriving (Eq, Ord, Show)
data Config a n
= Config
{
configRepOfType :: Type n -> Maybe Rep
, configConvertRepType :: Rep -> Type n -> Maybe (Type n)
, configConvertRepExp :: Rep -> a -> Type n -> Exp a n -> Maybe (Exp a n)
, configValueTypeOfLitName :: n -> Maybe (Type n)
, configValueTypeOfPrimOpName :: n -> Maybe (Type n)
, configValueTypeOfForeignName :: n -> Maybe (Type n)
, configUnboxLitName :: n -> Maybe n
, configUnboxPrimOpName :: n -> Maybe n
}
boxingModule
:: (Show a, Show n, Pretty n, Ord n)
=> Config a n -> Module a n -> Module a n
boxingModule config mm
= let
boxingImport imp
= case imp of
ImportValueSea v t
-> ImportValueSea v $ boxingForeignSeaType config t
_ -> imp
nsImportSea = [ n | (n, ImportValueSea _ _) <- moduleImportValues mm]
boxingExport expt
= case expt of
ExportSourceLocal n t
| elem n nsImportSea
-> ExportSourceLocal n $ boxingForeignSeaType config t
_ -> expt
in mm { moduleBody
= boxingX config (moduleBody mm)
, moduleExportValues
= [(n, boxingExport expt) | (n, expt) <- moduleExportValues mm ]
, moduleImportValues
= [(n, boxingImport impt) | (n, impt) <- moduleImportValues mm ] }
boxingX config xx
= case xx of
XCon a (DaConPrim n tLit)
| Just RepBoxed <- configRepOfType config tLit
-> let Just tLitU = configConvertRepType config RepUnboxed tLit
Just nU = configUnboxLitName config n
Just xLit = configConvertRepExp config RepBoxed a tLitU
$ XCon a (DaConPrim nU tLitU)
in xLit
XCast _ CastRun xx'@(XApp a _ _)
| Just (n, xsArgsAll) <- takeXPrimApps xx'
, Just n' <- configUnboxPrimOpName config n
-> let Just tPrimBoxed = configValueTypeOfPrimOpName config n
Just tPrimUnboxed = configValueTypeOfPrimOpName config n'
xsArgsAll' = map (boxingX config) xsArgsAll
in boxingPrimitive config a True xx' (XVar a (UPrim n' tPrimUnboxed))
tPrimBoxed tPrimUnboxed
xsArgsAll'
XApp a _ _
| Just (n, xsArgsAll) <- takeXPrimApps xx
, Just n' <- configUnboxPrimOpName config n
-> let Just tPrimBoxed = configValueTypeOfPrimOpName config n
Just tPrimUnboxed = configValueTypeOfPrimOpName config n'
xsArgsAll' = map (boxingX config) xsArgsAll
in boxingPrimitive config a False xx (XVar a (UPrim n' tPrimUnboxed))
tPrimBoxed tPrimUnboxed
xsArgsAll'
XApp a _ _
| Just (xFn@(XVar _ (UName n)), xsArgsAll)
<- takeXApps xx
, Just tForeign <- configValueTypeOfForeignName config n
-> let xsArgsAll' = map (boxingX config) xsArgsAll
in boxingForeignSea config a xx xFn tForeign xsArgsAll'
XCase a xScrut alts
| p : _ <- [ p | AAlt (PData p@DaConPrim{} []) _ <- alts]
, Just tLit1 <- configValueTypeOfLitName config (daConName p)
, Just RepBoxed <- configRepOfType config tLit1
-> let alts' = map (boxingAlt config) alts
in boxingCase config a tLit1 xScrut alts'
XVar{} -> xx
XCon{} -> xx
XLAM a b x -> XLAM a b (boxingX config x)
XLam a b x -> XLam a b (boxingX config x)
XApp a x1 x2 -> XApp a (boxingX config x1) (boxingX config x2)
XLet a lts x -> XLet a (boxingLts config lts) (boxingX config x)
XCase a x alts -> XCase a (boxingX config x) (map (boxingAlt config) alts)
XCast a c x -> XCast a c (boxingX config x)
XType{} -> xx
XWitness{} -> xx
boxingLts config lts
= case lts of
LLet b x -> LLet b (boxingX config x)
LRec bxs -> LRec [(b, boxingX config x) | (b, x) <- bxs]
LPrivate{} -> lts
boxingAlt config alt
= case alt of
AAlt p x -> AAlt p (boxingX config x)
boxingPrimitive
:: (Ord n, Pretty n, Show a, Show n)
=> Config a n -> a
-> Bool
-> Exp a n
-> Exp a n
-> Type n
-> Type n
-> [Exp a n]
-> Exp a n
boxingPrimitive config a bRun xx xFn tPrimBoxed tPrimUnboxed xsArgsAll
= fromMaybe xx go
where
go = do
let (asArgs, tsArgs) = unzip [(a', t) | XType a' t <- xsArgsAll]
let xsArgs = drop (length tsArgs) xsArgsAll
tPrimBoxedInst <- instantiateTs tPrimBoxed tsArgs
let (tsParamBoxed, _tResultBoxed)
= takeTFunArgResult tPrimBoxedInst
tPrimUnboxedInst <- instantiateTs tPrimUnboxed tsArgs
let (tsParamUnboxed, tResultUnboxed)
= takeTFunArgResult tPrimUnboxedInst
let tResultUnboxed'
| not bRun = tResultUnboxed
| otherwise = case takeTSusp tResultUnboxed of
Just (_, t) -> t
Nothing -> tResultUnboxed
(if not ( length xsArgs == length tsParamBoxed
&& length xsArgs == length tsParamUnboxed)
then Nothing
else Just ())
let xsArgs' = [ (let t = fromMaybe xArg
$ configConvertRepExp config RepUnboxed a tArgInst xArg
in t)
| xArg <- xsArgs
| tArgInst <- tsParamBoxed ]
let xtsArgsU = [ XType a' t | t <- tsArgs | a' <- asArgs ]
let xResultU = xApps a xFn (xtsArgsU ++ xsArgs')
let xResultRunU
| not bRun = xResultU
| otherwise = XCast a CastRun xResultU
let xResultV = fromMaybe xResultRunU
$ configConvertRepExp config RepBoxed a tResultUnboxed' xResultRunU
return xResultV
boxingForeignSea
:: (Ord n, Pretty n)
=> Config a n -> a
-> Exp a n
-> Exp a n
-> Type n
-> [Exp a n]
-> Exp a n
boxingForeignSea config a xx xFn tF xsArg
= fromMaybe xx go
where go = do
let (_asArg, tsArgType) = unzip [(a', t) | XType a' t <- xsArg]
let xsArgVal = drop (length tsArgType) xsArg
let (tsArgVal, tResult)
= takeTFunArgResult
$ eraseTForalls tF
(if not (length xsArgVal == length tsArgVal)
then Nothing
else Just ())
let unboxArg xArg tArg
= fromMaybe xArg
$ configConvertRepExp config RepUnboxed a tArg xArg
let xsArgValU = zipWith unboxArg xsArgVal tsArgVal
let xExpU = xApps a xFn ([XType a t | t <- tsArgType] ++ xsArgValU)
let boxResult tRes xRes
= fromMaybe xRes
$ do tResU <- configConvertRepType config RepUnboxed tRes
configConvertRepExp config RepBoxed a tResU xExpU
return $ boxResult tResult xExpU
boxingForeignSeaType
:: Config a n -> Type n -> Type n
boxingForeignSeaType config tForeign
= let
(bsForall, tBody)
= fromMaybe ([], tForeign)
$ takeTForalls tForeign
(tsParam, tResult)
= takeTFunArgResult tBody
unboxType tThing
= fromMaybe tThing
$ configConvertRepType config RepUnboxed tThing
tsParamU = map unboxType tsParam
tResultU = unboxType tResult
Just tBodyU = tFunOfList (tsParamU ++ [tResultU])
tForeignU = foldr TForall tBodyU bsForall
in tForeignU
boxingCase
:: Config a n
-> a -> Type n
-> Exp a n
-> [Alt a n]
-> Exp a n
boxingCase config a tLit1 xScrut alts
= let
unboxAlt (AAlt (PData (DaConPrim n tLit) []) x)
| Just RepBoxed <- configRepOfType config tLit
, Just nU <- configUnboxLitName config n
, Just tLitU <- configConvertRepType config RepUnboxed tLit
= Just (AAlt (PData (DaConPrim nU tLitU) []) x)
unboxAlt alt@(AAlt PDefault _) = Just alt
unboxAlt _ = Nothing
Just alts_unboxed
= sequence $ map unboxAlt alts
Just xScrut' = configConvertRepExp config RepUnboxed a tLit1 xScrut
alts_default = ensureDefault alts_unboxed
in XCase a xScrut' $ alts_default
ensureDefault :: [Alt a n] -> [Alt a n]
ensureDefault alts
| _ : _ <- [alt | alt@(AAlt PDefault _) <- alts]
= alts
| AAlt (PData _ []) x : rest <- reverse alts
= reverse rest ++ [AAlt PDefault x]
| otherwise
= alts