syntactic 1.14 → 1.15
raw patch · 5 files changed
+41/−38 lines, 5 filesdep ~basenew-uploader
Dependency ranges changed: base
Files
- src/Language/Syntactic/Constructs/Binding/HigherOrder.hs +3/−2
- src/Language/Syntactic/Sharing/CodeMotion2.hs +30/−28
- src/Language/Syntactic/Sharing/SimpleCodeMotion.hs +5/−4
- src/Language/Syntactic/Syntax.hs +1/−2
- syntactic.cabal +2/−2
src/Language/Syntactic/Constructs/Binding/HigherOrder.hs view
@@ -76,8 +76,9 @@ -reifyM :: forall dom p pVar a- . AST (HODomain dom p pVar) a -> State VarId (AST (FODomain dom p pVar) a)+reifyM :: forall dom p pVar m a+ . MonadState VarId m+ => AST (HODomain dom p pVar) a -> m (AST (FODomain dom p pVar) a) reifyM (f :$ a) = liftM2 (:$) (reifyM f) (reifyM a) reifyM (Sym (C' (InjR a))) = return $ Sym $ C' $ InjR a reifyM (Sym (C' (InjL (HOLambda f)))) = do
src/Language/Syntactic/Sharing/CodeMotion2.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DoRec #-}-module Language.Syntactic.Sharing.CodeMotion2 +module Language.Syntactic.Sharing.CodeMotion2 ( codeMotion2 , reifySmart2 ) where@@ -24,7 +24,7 @@ import Language.Syntactic.Constructs.Binding.HigherOrder import Language.Syntactic.Sharing.SimpleCodeMotion -typeEq :: forall dom a b. (Typeable a, Typeable b) => ASTF dom a -> ASTF dom b -> Bool +typeEq :: forall dom a b. (Typeable a, Typeable b) => ASTF dom a -> ASTF dom b -> Bool typeEq a b | Just _ <- (gcast b :: Maybe (ASTF dom a)) = True typeEq _ _ = False @@ -170,65 +170,66 @@ -- nodes that have been encountered ) -type RebuildMonad dom a = ReaderT (RebuildEnv dom) (State VarId) a-+type RebuildMonad dom m a = ReaderT (RebuildEnv dom) m a -runRebuild :: RebuildMonad dom a -> State VarId a+runRebuild :: (MonadState VarId m) => RebuildMonad dom m a -> m a runRebuild m = runReaderT m (Map.empty, Set.empty, []) -addBoundVar :: VarId -> RebuildMonad dom a -> RebuildMonad dom a+addBoundVar :: (Monad m) => VarId -> RebuildMonad dom m a -> RebuildMonad dom m a addBoundVar v = local (\(nm,vs,sn) -> (nm, Set.insert v vs, sn)) -getBoundVars :: RebuildMonad dom (Set.Set VarId)+getBoundVars :: (Monad m) => RebuildMonad dom m (Set.Set VarId) getBoundVars = do (_,bv,_) <- ask return bv -addNodeExpr :: NodeId -> ASTSAT dom -> RebuildMonad dom a -> RebuildMonad dom a+addNodeExpr :: (Monad m) => NodeId -> ASTSAT dom -> RebuildMonad dom m a -> RebuildMonad dom m a addNodeExpr n a = local (\(nm,vs,sn) -> (Map.insert n a nm, vs, sn)) -getNodeExprMap :: RebuildMonad dom (Map.Map NodeId (ASTSAT dom))+getNodeExprMap :: (Monad m) => RebuildMonad dom m (Map.Map NodeId (ASTSAT dom)) getNodeExprMap = do (nm,_,_) <- ask return nm -addSeenNode :: NodeId -> RebuildMonad dom a -> RebuildMonad dom a+addSeenNode :: (Monad m) => NodeId -> RebuildMonad dom m a -> RebuildMonad dom m a addSeenNode n = local (\(nm,vs,sn) -> (nm, vs, n:sn)) -getSeenNodes :: RebuildMonad dom [NodeId]+getSeenNodes :: (Monad m) => RebuildMonad dom m [NodeId] getSeenNodes = do (_,_,sn) <- ask return sn -codeMotion2 :: forall dom a+codeMotion2 :: forall dom m a . ( ConstrainedBy dom Typeable , AlphaEq dom dom dom [(VarId,VarId)] , AlphaEq dom dom (NodeDomain dom) [(VarId,VarId)] , Equality dom+ , MonadState VarId m ) => (forall c. ASTF dom c -> Bool) -- ^ Control wether a sub-expression can be hoisted over the given expression -> PrjDict dom -> MkInjDict dom -> ASTF dom a- -> State VarId (ASTF dom a)+ -> m (ASTF dom a) codeMotion2 hoistOver pd mkId a = rebuild pd mkId garr a' where (garr, a') = gather hoistOver pd a- + type ShareInfo dom = (NodeId, ASTSAT (NodeDomain dom), GatherInfo) -rebuild :: forall dom a+rebuild :: forall dom m a . ( ConstrainedBy dom Typeable , AlphaEq dom dom (NodeDomain dom) [(VarId,VarId)] , Equality dom+ , MonadState VarId m ) => PrjDict dom -> MkInjDict dom -> Array NodeId (Gathered dom) -> ASTF (NodeDomain dom) a- -> State VarId (ASTF dom a)+ -> m (ASTF dom a) rebuild pd mkId nodes (Sym (C' (InjL _))) = error "rebuild: root is a node" rebuild pd mkId nodes a = runRebuild $ rebuild' 0 a where@@ -297,7 +298,7 @@ rebuild' :: forall b . NodeId -> ASTF (NodeDomain dom) b- -> RebuildMonad dom (ASTF dom b)+ -> RebuildMonad dom m (ASTF dom b) rebuild' n a@(Sym (C' (InjR lam)) :$ ns@(Sym (C' (InjL (Node nb))))) | Just v <- prjLambda pd lam = addSeenNode n $ shareExprsIn (Just v) n a@@ -308,7 +309,7 @@ . Maybe VarId -- if the last argument is a lambda, this contains the lambda VarId, otherwise Nothing. -> NodeId -> ASTF (NodeDomain dom) b- -> RebuildMonad dom (ASTF dom b)+ -> RebuildMonad dom m (ASTF dom b) shareExprsIn mlv n a = do bv <- getBoundVars seenNodes <- getSeenNodes@@ -318,7 +319,7 @@ let unshareable = nubBy ((==) `on` (\(n,_,_) -> n)) $ unshareableNodes n a ++ unshareable2Nodes mlv a unshare mlv unshareable $ shareEm mlv sorted a - unshare :: Maybe VarId -> [ShareInfo dom] -> RebuildMonad dom b -> RebuildMonad dom b+ unshare :: Maybe VarId -> [ShareInfo dom] -> RebuildMonad dom m b -> RebuildMonad dom m b unshare mlv [] m = m unshare mlv ((n, ASTB b, gi):sis) m = do b' <- rebuildMaybeUnderLambda mlv n b@@ -328,7 +329,7 @@ :: Maybe VarId -> [ShareInfo dom] -> ASTF (NodeDomain dom) b- -> RebuildMonad dom (ASTF dom b)+ -> RebuildMonad dom m (ASTF dom b) shareEm mlv [] a = fixNodeExprSub a shareEm mlv ((n, ASTB b, gi) : sis) a = do bv <- getBoundVars@@ -343,11 +344,11 @@ a' <- addNodeExpr n (ASTB b') $ shareEm mlv sis a return a' - rebuildMaybeUnderLambda + rebuildMaybeUnderLambda :: Maybe VarId -> NodeId -> ASTF (NodeDomain dom) b- -> RebuildMonad dom (ASTF dom b)+ -> RebuildMonad dom m (ASTF dom b) rebuildMaybeUnderLambda (Just lv) n a = addBoundVar lv $ rebuild' n a rebuildMaybeUnderLambda Nothing n a = rebuild' n a @@ -357,14 +358,15 @@ , Equality dom ) => AST (NodeDomain dom) b- -> RebuildMonad dom (AST dom b)+ -> RebuildMonad dom m (AST dom b) fixNodeExprSub (Sym (C' (InjR s))) = return (Sym s) fixNodeExprSub (s :$ b) = do b' <- fixNodeExpr b s' <- fixNodeExprSub s return (s' :$ b')- - fixNodeExpr :: forall b . ASTF (NodeDomain dom) b -> RebuildMonad dom (ASTF dom b)++ fixNodeExpr :: forall b+ . ASTF (NodeDomain dom) b -> RebuildMonad dom m (ASTF dom b) fixNodeExpr (ns@(Sym (C' (InjL (Node n))))) = do nodeMap <- getNodeExprMap let a = lookNode nodeMap@@ -505,7 +507,7 @@ gatherRoot :: ASTF dom b -> GatherMonad dom (ASTF (NodeDomain dom) b) gatherRoot a@(Sym lam :$ _) | Just v <- prjLambda pd lam- , Dict <- exprDict a + , Dict <- exprDict a = addScopeVar v $ gatherRec (hoistOver a) a gatherRoot a | Dict <- exprDict a = gatherRec (hoistOver a) a @@ -535,7 +537,7 @@ (Map.findWithDefault [] (geNodeId g) propagateAdditionals) propagateAdditionals :: Additional- propagateAdditionals = foldr propAdditional (additionals st) $ Map.toDescList (additionals st) + propagateAdditionals = foldr propAdditional (additionals st) $ Map.toDescList (additionals st) where propAdditional :: (NodeId, [(NodeId, GatherInfo)]) -> Additional -> Additional propAdditional (n, gi) ad = propAdditionalNode n gi ad@@ -557,7 +559,7 @@ varHash :: Map.Map VarId Hash varHash = lambdaHashes pd a - gather' + gather' :: Bool -> ASTF dom b -> GatherMonad dom (ASTF (NodeDomain dom) b)
src/Language/Syntactic/Sharing/SimpleCodeMotion.hs view
@@ -158,20 +158,21 @@ -- | Perform common sub-expression elimination and variable hoisting-codeMotion :: forall dom a+codeMotion :: forall dom m a . ( ConstrainedBy dom Typeable , AlphaEq dom dom dom [(VarId,VarId)]+ , MonadState VarId m ) => (forall c. ASTF dom c -> Bool) -- ^ Control wether a sub-expression can be hoisted over the given expression -> PrjDict dom -> MkInjDict dom -> ASTF dom a- -> State VarId (ASTF dom a)+ -> m (ASTF dom a) codeMotion hoistOver pd mkId a | Just (Chosen id b) <- choose hoistOver pd mkId a = share id b | otherwise = descend a where- share :: InjDict dom b a -> ASTF dom b -> State VarId (ASTF dom a)+ share :: InjDict dom b a -> ASTF dom b -> m (ASTF dom a) share id b = do b' <- codeMotion hoistOver pd mkId b v <- get; put (v+1)@@ -182,7 +183,7 @@ :$ b' :$ (Sym (injLambda id v) :$ body) - descend :: AST dom b -> State VarId (AST dom b)+ descend :: AST dom b -> m (AST dom b) descend (f :$ a) = liftM2 (:$) (descend f) (codeMotion hoistOver pd mkId a) descend a = return a
src/Language/Syntactic/Syntax.hs view
@@ -1,7 +1,6 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE UndecidableInstances #-}--{-# OPTIONS_GHC -cpp #-} -- | Generic representation of typed syntax trees --
syntactic.cabal view
@@ -1,5 +1,5 @@ Name: syntactic-Version: 1.14+Version: 1.15 Synopsis: Generic abstract syntax, and utilities for embedded languages Description: This library provides: .@@ -100,7 +100,7 @@ build-depends: array,- base >= 4 && < 4.8,+ base >= 4 && < 4.9, containers, constraints, data-hash,