module Language.Syntactic.Sharing.SimpleCodeMotion
( PrjDict (..)
, InjDict (..)
, MkInjDict
, codeMotion
, prjDictFO
, reifySmart
, mkInjDictFO
) where
import Control.Monad.State
import Data.Set as Set
import Data.Typeable
import Language.Syntactic
import Language.Syntactic.Constructs.Binding
import Language.Syntactic.Constructs.Binding.HigherOrder
data PrjDict dom = PrjDict
{ prjVariable :: forall sig . dom sig -> Maybe VarId
, prjLambda :: forall sig . dom sig -> Maybe VarId
}
data InjDict dom a b = InjDict
{ injVariable :: VarId -> dom (Full a)
, injLambda :: VarId -> dom (b :-> Full (a -> b))
, injLet :: dom (a :-> (a -> b) :-> Full b)
}
type MkInjDict dom = forall a b . ASTF dom a -> ASTF dom b -> Maybe (InjDict dom a b)
substitute :: forall dom a b
. (ConstrainedBy dom Typeable, AlphaEq dom dom dom [(VarId,VarId)])
=> ASTF dom a
-> ASTF dom a
-> ASTF dom b
-> ASTF dom b
substitute x y a
| Dict <- exprDictSub pTypeable y
, Dict <- exprDictSub pTypeable a
, Just y' <- gcast y, alphaEq x a = y'
| otherwise = subst a
where
subst :: AST dom c -> AST dom c
subst (f :$ a) = subst f :$ substitute x y a
subst a = a
count :: forall dom a b
. AlphaEq dom dom dom [(VarId,VarId)]
=> ASTF dom a
-> ASTF dom b
-> Int
count a b
| alphaEq a b = 1
| otherwise = cnt b
where
cnt :: AST dom c -> Int
cnt (f :$ b) = cnt f + count a b
cnt _ = 0
nonTerminal :: AST dom a -> Bool
nonTerminal (_ :$ _) = True
nonTerminal _ = False
data Env dom = Env
{ inLambda :: Bool
, counter :: ASTE dom -> Int
, dependencies :: Set VarId
}
independent :: PrjDict dom -> Env dom -> AST dom a -> Bool
independent pd env (Sym (prjVariable pd -> Just v)) = not (v `member` dependencies env)
independent pd env (f :$ a) = independent pd env f && independent pd env a
independent _ _ _ = True
liftable :: PrjDict dom -> Env dom -> ASTF dom a -> Bool
liftable pd env a = independent pd env a && heuristic
where
heuristic = nonTerminal a && (inLambda env || (counter env (ASTE a) > 1))
choose
:: (AlphaEq dom dom dom [(VarId,VarId)])
=> PrjDict dom
-> ASTF dom a
-> Maybe (ASTE dom)
choose pd a = chooseEnv pd env a
where
env = Env
{ inLambda = False
, counter = \(ASTE b) -> count b a
, dependencies = empty
}
chooseEnv :: forall dom a
. PrjDict dom
-> Env dom
-> ASTF dom a
-> Maybe (ASTE dom)
chooseEnv pd env a
| liftable pd env a = Just (ASTE a)
chooseEnv pd env a = chooseEnvSub pd env a
chooseEnvSub
:: PrjDict dom
-> Env dom
-> AST dom a
-> Maybe (ASTE dom)
chooseEnvSub pd env (Sym lam :$ a)
| Just v <- prjLambda pd lam
= chooseEnv pd (env' v) a
where
env' v = env
{ inLambda = True
, dependencies = insert v (dependencies env)
}
chooseEnvSub pd env (f :$ a) = chooseEnvSub pd env f `mplus` chooseEnv pd env a
chooseEnvSub _ _ _ = Nothing
codeMotion :: forall dom a
. ( ConstrainedBy dom Typeable
, AlphaEq dom dom dom [(VarId,VarId)]
)
=> PrjDict dom
-> MkInjDict dom
-> ASTF dom a
-> State VarId (ASTF dom a)
codeMotion pd mkId a
| Just (ASTE b) <- choose pd a, Just id <- mkId b a = share id b
| otherwise = descend a
where
share :: InjDict dom b a -> ASTF dom b -> State VarId (ASTF dom a)
share id b = do
b' <- codeMotion pd mkId b
v <- get; put (v+1)
let x = Sym (injVariable id v)
body <- codeMotion pd mkId $ substitute b x a
return
$ Sym (injLet id)
:$ b'
:$ (Sym (injLambda id v) :$ body)
descend :: AST dom b -> State VarId (AST dom b)
descend (f :$ a) = liftM2 (:$) (descend f) (codeMotion pd mkId a)
descend a = return a
prjDictFO :: forall dom p pVar . PrjDict (FODomain dom p pVar)
prjDictFO = PrjDict
{ prjVariable = fmap (\(C' (Variable v)) -> v) . prjP (P::P (Variable :|| pVar))
, prjLambda = fmap (\(SubConstr2 (Lambda v)) -> v) . prjP (P::P (CLambda pVar))
}
reifySmart :: forall dom p pVar a
. ( AlphaEq dom dom (FODomain dom p pVar) [(VarId,VarId)]
, Syntactic a
, Domain a ~ HODomain dom p pVar
, p :< Typeable
)
=> MkInjDict (FODomain dom p pVar)
-> a
-> ASTF (FODomain dom p pVar) (Internal a)
reifySmart mkId = flip evalState 0 . (codeMotion prjDictFO mkId <=< reifyM . desugar)
mkInjDictFO :: forall dom pVar . (Let :<: dom)
=> (forall a . ASTF (FODomain dom Typeable pVar) a -> Maybe (Dict (pVar a)))
-> MkInjDict (FODomain dom Typeable pVar)
mkInjDictFO canShare a b
| Dict <- exprDict a
, Dict <- exprDict b
, Just Dict <- canShare a
= Just $ InjDict
{ injVariable = \v -> injC (symType pVar $ C' (Variable v))
, injLambda = \v -> injC (symType pLam $ SubConstr2 (Lambda v))
, injLet = C' $ inj Let
}
where
pVar = P::P (Variable :|| pVar)
pLam = P::P (CLambda pVar)
mkInjDictFO _ _ _ = Nothing