module DDC.Core.Analysis.Usage
(
Used (..)
, UsedMap (..)
, usageModule
, usageX)
where
import DDC.Core.Module
import DDC.Core.Exp.Annot
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
data Used
= UsedFunction
| UsedDestruct
| UsedInCast
| UsedOcc
| UsedInLambda Used
| UsedInAlt Used
deriving (Eq, Show)
data UsedMap n
= UsedMap (Map n [Used])
deriving Show
empty :: UsedMap n
empty = UsedMap (Map.empty)
accUsed :: Ord n => Bound n -> Used -> UsedMap n -> UsedMap n
accUsed u used um@(UsedMap m)
= case u of
UName n -> UsedMap $ Map.insertWith (++) n [used] m
_ -> um
plusUsedMap :: Ord n => UsedMap n -> UsedMap n -> UsedMap n
plusUsedMap (UsedMap map1) (UsedMap map2)
= UsedMap $ Map.unionWith (++) map1 map2
sumUsedMap :: Ord n => [UsedMap n] -> UsedMap n
sumUsedMap [] = UsedMap Map.empty
sumUsedMap (m:ms)
= foldl' plusUsedMap m ms
removeUsedMap :: Ord n => UsedMap n -> [Bind n] -> UsedMap n
removeUsedMap (UsedMap m) bs
= UsedMap
$ foldr Map.delete m
$ mapMaybe takeNameOfBind bs
usageModule
:: Ord n
=> Module a n
-> Module (UsedMap n, a) n
usageModule
(ModuleCore
{ moduleName = name
, moduleIsHeader = isHeader
, moduleExportTypes = exportTypes
, moduleExportValues = exportValues
, moduleImportTypes = importTypes
, moduleImportCaps = importCaps
, moduleImportValues = importValues
, moduleImportDataDefs = importDataDefs
, moduleDataDefsLocal = dataDefsLocal
, moduleBody = body })
= ModuleCore
{ moduleName = name
, moduleIsHeader = isHeader
, moduleExportTypes = exportTypes
, moduleExportValues = exportValues
, moduleImportTypes = importTypes
, moduleImportCaps = importCaps
, moduleImportValues = importValues
, moduleImportDataDefs = importDataDefs
, moduleDataDefsLocal = dataDefsLocal
, moduleBody = usageX body }
usageX :: Ord n
=> Exp a n
-> Exp (UsedMap n, a) n
usageX xx = snd $ usageX' xx
usageX' :: Ord n
=> Exp a n
-> (UsedMap n, Exp (UsedMap n, a) n)
usageX' xx
= case xx of
XVar a u
| used <- accUsed u UsedOcc empty
-> ( used
, XVar (used, a) u)
XCon a u
-> ( empty
, XCon (empty, a) u)
XLAM a b1 x2
| ( used2, x2') <- usageX' x2
, UsedMap us2 <- used2
, used2' <- UsedMap (Map.map (map UsedInLambda) us2)
, cleared <- removeUsedMap used2' [b1]
-> ( cleared
, XLAM (used2', a) b1 x2')
XLam a b1 x2
| ( used2, x2') <- usageX' x2
, UsedMap us2 <- used2
, used2' <- UsedMap (Map.map (map UsedInLambda) us2)
, cleared <- removeUsedMap used2' [b1]
-> ( cleared
, XLam (used2', a) b1 x2')
XApp a x1 x2
| XVar a1 u <- x1
, used1 <- accUsed u UsedFunction empty
, (used2, x2') <- usageX' x2
, used' <- used1 `plusUsedMap` used2
-> ( used'
, XApp (used', a) (XVar (used1, a1) u) x2')
| ( used1, x1') <- usageX' x1
, ( used2, x2') <- usageX' x2
, used' <- used1 `plusUsedMap` used2
-> ( used'
, XApp (used', a) x1' x2')
XLet a lts x2
| ( used1, lts') <- usageLets lts
, ( used2, x2') <- usageX' x2
, used' <- used1 `plusUsedMap` used2
, cleared <- removeUsedMap used'
$ uncurry (++) (bindsOfLets lts)
-> ( cleared
, XLet (used', a) lts' x2')
XCase a x1 alts
| ( used1, x1') <- usageX' x1
, ( usedA, alts') <- unzip $ map usageAlt alts
, UsedMap usA <- sumUsedMap usedA
, usedA' <- UsedMap (Map.map (map UsedInAlt) usA)
, used' <- plusUsedMap used1 usedA'
-> ( used'
, XCase (used', a) x1' alts' )
XCast a c x1
| (used1, x1') <- usageX' x1
, (used2, c') <- usageCast c
, used' <- plusUsedMap used1 used2
-> ( used'
, XCast (used', a) c' x1')
XType a t
-> ( empty
, XType (empty, a) t)
XWitness a w
| (used', w') <- usageWitness w
-> ( used'
, XWitness (used', a) w')
usageLets
:: Ord n
=> Lets a n
-> (UsedMap n, Lets (UsedMap n, a) n)
usageLets lts
= case lts of
LLet b x
| (used1', x') <- usageX' x
-> (used1', LLet b x')
LRec bxs
| (bs, xs) <- unzip bxs
, (useds', xs') <- unzip $ map usageX' xs
, used' <- sumUsedMap useds'
-> (used', LRec $ zip bs xs')
LPrivate b mt bs
-> (empty, LPrivate b mt bs)
usageCast
:: Ord n
=> Cast a n
-> (UsedMap n, Cast (UsedMap n, a) n)
usageCast cc
= case cc of
CastWeakenEffect eff
-> (empty, CastWeakenEffect eff)
CastPurify w
| (used, w') <- usageWitness w
-> (used, CastPurify w')
CastBox -> (empty, CastBox)
CastRun -> (empty, CastRun)
usageAlt
:: Ord n
=> Alt a n
-> (UsedMap n, Alt (UsedMap n, a) n)
usageAlt (AAlt p x)
= let (used, x') = usageX' x
in (used, AAlt p x')
usageWitness
:: Ord n
=> Witness a n
-> (UsedMap n, Witness (UsedMap n, a) n)
usageWitness ww
= case ww of
WVar a u
-> (empty, WVar (empty, a) u)
WCon a c
-> (empty, WCon (empty, a) c)
WApp a w1 w2
| (used1, w1') <- usageWitness w1
, (used2, w2') <- usageWitness w2
, used' <- plusUsedMap used1 used2
-> (empty, WApp (used', a) w1' w2')
WType a t
-> (empty, WType (empty, a) t)