module Knuth1 where import Pretty import ExecutionPlan import CommonTypes import Control.Monad import Control.Monad.ST import Data.Maybe import Data.List import Data.STRef import Debug.Trace import Data.Array (Array) import qualified Data.Array as Array import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set -- | Trace a message in the ST monad traceST :: String -> ST s () traceST s = trace s (return ()) ------------------------------------------------------------------------------- -- Dependency graph representation ------------------------------------------------------------------------------- -- Vertices data AttrType = Inh | Syn | Loc deriving (Eq, Ord, Show) data Vertex = VAttr AttrType Identifier Identifier | VChild Identifier | VRule Identifier deriving (Eq, Ord) instance Show Vertex where show (VAttr ty ch at) = show ty ++ " @" ++ show ch ++ "." ++ show at show (VChild ch) = "Child " ++ show ch show (VRule ru) = "Rule " ++ show ru -- | Check if a vertex is an attribute isVertexAttr :: Vertex -> Bool isVertexAttr (VAttr _ _ _) = True isVertexAttr _ = False -- | Get the child name of an attribute getAttrChildName :: Vertex -> Identifier getAttrChildName (VAttr _ n _) = n -- | Set the child name of an attribute setAttrChildName :: Vertex -> Identifier -> Vertex setAttrChildName (VAttr t _ a) n = VAttr t n a -- | Get the type of an attribute getAttrType :: Vertex -> AttrType getAttrType (VAttr t _ _) = t -- | Get the name of an attribute getAttrName :: Vertex -> Identifier getAttrName (VAttr _ _ a) = a -- Edges type Edge = (Vertex, Vertex) -- Internal representation of a vertex type IVertex = Int type IEdge = (IVertex, IVertex) -- Representation of the graph data DependencyGraph s = DependencyGraph { vertexIMap :: Map Vertex IVertex , vertexOMap :: Array IVertex Vertex , successors :: Array IVertex (STRef s (Set IVertex)) , predecessors :: Array IVertex (STRef s (Set IVertex)) } ------------------------------------------------------------------------------- -- Dependency graph fuctions ------------------------------------------------------------------------------- -- | Construct a dependency graph graphConstruct :: [Vertex] -> ST s (DependencyGraph s) graphConstruct vs = do let nv = length vs let ivs = [0..nv-1] let ivb = (0,nv-1) let vimap = Map.fromList (zip vs ivs) let vomap = Array.array ivb (zip ivs vs) succs <- replicateM nv (newSTRef Set.empty) preds <- replicateM nv (newSTRef Set.empty) let su = Array.array ivb (zip ivs succs) let pr = Array.array ivb (zip ivs preds) let graph = DependencyGraph { vertexIMap = vimap , vertexOMap = vomap , successors = su , predecessors = pr } return graph -- | Construct a transitivelly closed graph graphConstructTRC :: [Vertex] -> [Edge] -> ST s (DependencyGraph s) graphConstructTRC vs es = do g <- graphConstruct vs -- Insert all initial edges graphInsertEdgesTRC g es return g -- | Return all successors of a vertex graphSuccessors :: DependencyGraph s -> Vertex -> ST s (Set Vertex) graphSuccessors g v = do sucs <- readSTRef $ (successors g) Array.! (graphGetIVertex g v) return $ Set.map (graphGetVertex g) sucs -- | Return all predecessors of a vertex graphPredecessors :: DependencyGraph s -> Vertex -> ST s (Set Vertex) graphPredecessors g v = do sucs <- readSTRef $ (predecessors g) Array.! (graphGetIVertex g v) return $ Set.map (graphGetVertex g) sucs -- | Check if the graph contains an edge graphContainsEdge :: DependencyGraph s -> Edge -> ST s Bool graphContainsEdge g (v1,v2) = do let iv1 = graphGetIVertex g v1 let iv2 = graphGetIVertex g v2 sucs <- readSTRef $ (successors g) Array.! iv1 return $ iv2 `Set.member` sucs -- | Insert an edge in the graph graphInsert :: DependencyGraph s -> Edge -> ST s () graphInsert g (v1,v2) = do let iv1 = graphGetIVertex g v1 let iv2 = graphGetIVertex g v2 -- Add v2 to the successors of v1 and v1 to predecessors of v2 modifySTRef ((successors g) Array.! iv1) $ Set.insert iv2 modifySTRef ((predecessors g) Array.! iv2) $ Set.insert iv1 -- | Insert an edge in a transtive closed graph and return all other edges that were -- added due to transtivity graphInsertTRC :: DependencyGraph s -> Edge -> ST s [(IVertex, Set IVertex)] graphInsertTRC g (v1,v2) = do let iv1 = graphGetIVertex g v1 let iv2 = graphGetIVertex g v2 -- Read predecessors of v1 and successors of v2 pred1 <- readSTRef $ (predecessors g) Array.! iv1 succ2 <- readSTRef $ (successors g) Array.! iv2 -- First insert all edges from v1 let rsucc1 = (successors g) Array.! iv1 succ1 <- readSTRef rsucc1 let add1 = succ2 `Set.difference` succ1 modifySTRef rsucc1 (Set.union add1 . Set.insert iv2) -- All edges to v2 let rpred2 = (predecessors g) Array.! iv2 modifySTRef rpred2 (Set.union pred1 . Set.insert iv1) -- Connect every predecessor of v1 to every successor of v2 sucl <- forM (Set.toList pred1) $ \pred -> do -- Connect pred to v2 and all successors of v2 let rsucc = (successors g) Array.! pred csucc <- readSTRef rsucc let cadd = (Set.insert iv2 succ2) `Set.difference` csucc modifySTRef rsucc (Set.union cadd) return (pred, cadd) -- Connect every successor of v2 to every predecessor of v1 forM_ (Set.toList succ2) $ \succ -> do -- Connect succ to v1 and all predecessors of v1 let rpred = (predecessors g) Array.! succ cpred <- readSTRef rpred let cadd = (Set.insert iv1 pred1) `Set.difference` cpred modifySTRef rpred (Set.union cadd) -- Create return return $ (iv1,add1) : sucl -- | Return all vertices of the graph graphVertices :: DependencyGraph s -> ST s [Vertex] graphVertices = return . Array.elems . vertexOMap -- | Return all edges of the graph graphEdges :: DependencyGraph s -> ST s [Edge] graphEdges g = do let vs = Array.indices $ vertexOMap g perv <- forM vs $ \v -> do let rv = graphGetVertex g v sucs <- readSTRef $ (successors g) Array.! v let sucl = Set.toList sucs return $ map ((,) rv . graphGetVertex g) sucl return $ concat perv -- | Insert a list of edges in the graph graphInsertEdges :: DependencyGraph s -> [Edge] -> ST s () graphInsertEdges g ed = mapM_ (graphInsert g) ed -- | Insert a list of edges in the graph and return all other edges that -- were added due to transitivity graphInsertEdgesTRC :: DependencyGraph s -> [Edge] -> ST s [Edge] graphInsertEdgesTRC g ed = do -- rets :: [[(IVertex, Set IVertex)]] rets <- mapM (graphInsertTRC g) ed -- Combine all successor sets let f :: (IVertex, (Set IVertex)) -> [(IVertex, IVertex)] f (v,s) = map ((,) v) (Set.toList s) let comb :: [(IVertex, IVertex)] comb = concatMap (concatMap f) rets -- Construct edges from this return $ map (graphGetEdge g) $ comb -- | Check whether the graph is cyclic graphIsCyclic :: DependencyGraph s -> ST s Bool graphIsCyclic g = do s <- graphCyclicVertices g return $ not $ Set.null s graphCyclicVertices :: DependencyGraph s -> ST s (Set IVertex) graphCyclicVertices g = do vs <- return $ Array.indices $ vertexOMap g sets <- forM vs $ \v -> do sucs <- readSTRef $ (successors g) Array.! v let res | v `Set.member` sucs = Set.singleton v | otherwise = Set.empty return res return (Set.unions sets) graphCyclicVerticesExt :: DependencyGraph s -> ST s [Vertex] graphCyclicVerticesExt g = (map (graphGetVertex g) . Set.elems) `fmap` graphCyclicVertices g -- | Get internal representation of a vertex graphGetIVertex :: DependencyGraph s -> Vertex -> IVertex graphGetIVertex g v = vertexIMap g Map.! v -- | Get external representation of a vertex graphGetVertex :: DependencyGraph s -> IVertex -> Vertex graphGetVertex g v = vertexOMap g Array.! v -- | Get external representation of an edge graphGetEdge :: DependencyGraph s -> IEdge -> Edge graphGetEdge g (v1,v2) = (graphGetVertex g v1, graphGetVertex g v2) -- | Check if the graph is transitively closed graphIsTRC :: DependencyGraph s -> ST s Bool graphIsTRC g = do let vs = Array.indices $ vertexOMap g bs <- forM vs $ \v -> do succs <- readSTRef $ (successors g) Array.! v bs2 <- forM (Set.toList succs) $ \v2 -> do succs2 <- readSTRef $ (successors g) Array.! v2 return $ succs2 `Set.isSubsetOf` succs return $ and bs2 return $ and bs -- | Check consistency of the graph (successor and predecessor sets) graphCheckConsistency :: DependencyGraph s -> ST s Bool graphCheckConsistency g = do let vs = Array.indices $ vertexOMap g ret <- forM vs $ \v -> do -- V must appear in every predecessor set of its successors succs <- readSTRef $ (successors g) Array.! v r1 <- forM (Set.toList succs) $ \succ -> do preds2 <- readSTRef $ (predecessors g) Array.! succ return (v `Set.member` preds2) -- V must appear in every successor set of its predecessors preds <- readSTRef $ (predecessors g) Array.! v r2 <- forM (Set.toList preds) $ \pred -> do succs2 <- readSTRef $ (successors g) Array.! pred return (v `Set.member` succs2) return $ and $ r1 ++ r2 return $ and $ ret -- | Add edges to the graph so that it is topologically sorted (this will not work if graph is cyclic) graphTopSort :: DependencyGraph s -> ST s [Edge] graphTopSort g = do let vs = Array.indices $ vertexOMap g order <- foldM (graphTopSort' g) [] vs mb <- forM (zip order (tail order)) $ \(v1,v2) -> do let edg = graphGetEdge g (v2,v1) -- order is actually reverse order ce <- graphContainsEdge g edg if ce then return Nothing else do graphInsert g edg return $ Just edg return $ catMaybes mb -- | Helper function for graphTopSort graphTopSort' :: DependencyGraph s -> [IVertex] -> IVertex -> ST s [IVertex] graphTopSort' g prev cur | cur `elem` prev = return prev | otherwise = do pred <- readSTRef $ (predecessors g) Array.! cur order <- foldM (graphTopSort' g) prev $ Set.toList pred return $ cur : order ------------------------------------------------------------------------------- -- Dependency graph information wrappers ------------------------------------------------------------------------------- -- | Special wrapper for nonterminal dependency graphs (so that we can easily add other meta-information) data NontDependencyGraph = NontDependencyGraph { ndgVertices :: [Vertex] , ndgEdges :: [Edge] } -- | Special wrapper for production dependency graphs, including mapping between child names and nonterminals data ProdDependencyGraph = ProdDependencyGraph { pdgVertices :: [Vertex] , pdgEdges :: [Edge] , pdgRules :: ERules , pdgChilds :: EChildren , pdgProduction :: Identifier , pdgChildMap :: [(Identifier, Identifier)] , pdgConstraints :: [Type] , pdgParams :: [Identifier] } -- | Represent all information from the dependency graphs for a nonterminal data NontDependencyInformation = NontDependencyInformation { ndiNonterminal :: Identifier , ndiParams :: [Identifier] , ndiInh :: [Identifier] , ndiSyn :: [Identifier] , ndiDepGraph :: NontDependencyGraph , ndiProds :: [ProdDependencyGraph] , ndiRecursive :: Bool , ndiHoInfo :: HigherOrderInfo , ndiClassCtxs :: ClassContext } --- Monadic versions of these records, for use with the ST monad -- | Monadic wrapper of NontDependencyGraph data NontDependencyGraphM s = NontDependencyGraphM { ndgmDepGraph :: DependencyGraph s , ndgmOrig :: NontDependencyGraph } -- | Monadic wrapper of ProdDependencyGraph data ProdDependencyGraphM s = ProdDependencyGraphM { pdgmDepGraph :: DependencyGraph s , pdgmOrig :: ProdDependencyGraph } -- | Monadic wrapper of NontDependencyInformation data NontDependencyInformationM s = NontDependencyInformationM { ndimOrig :: NontDependencyInformation , ndimDepGraph :: NontDependencyGraphM s , ndimProds :: [ProdDependencyGraphM s] } -- | Convert a NontDependencyGraph to the corresponding monadic version mkNontDependencyGraphM :: NontDependencyGraph -> ST s (NontDependencyGraphM s) mkNontDependencyGraphM ndg = do g <- graphConstructTRC (ndgVertices ndg) (ndgEdges ndg) return $ NontDependencyGraphM { ndgmDepGraph = g , ndgmOrig = ndg } -- | Convert a ProdDependencyGraph to the corresponding monadic version mkProdDependencyGraphM :: Bool -> ProdDependencyGraph -> ST s (ProdDependencyGraphM s) mkProdDependencyGraphM trc pdg = do g <- if trc then graphConstructTRC (pdgVertices pdg) (pdgEdges pdg) else do g <- graphConstruct (pdgVertices pdg) mapM_ (graphInsert g) (pdgEdges pdg) return g return $ ProdDependencyGraphM { pdgmDepGraph = g , pdgmOrig = pdg } -- | Convert a NontDependencyInformation to the corresponding monadic version mkNontDependencyInformationM :: NontDependencyInformation -> ST s (NontDependencyInformationM s) mkNontDependencyInformationM ndi = do dg <- mkNontDependencyGraphM (ndiDepGraph ndi) prods <- mapM (mkProdDependencyGraphM True) (ndiProds ndi) return $ NontDependencyInformationM { ndimOrig = ndi , ndimDepGraph = dg , ndimProds = prods } -- | Construct the production graphs from the transitivelly closed graphs undoTransitiveClosure :: [NontDependencyInformationM s] -> ST s [NontDependencyInformationM s] undoTransitiveClosure ndis = do edgesl <- mapM (\ndi -> graphEdges (ndgmDepGraph $ ndimDepGraph ndi)) ndis let edges = concat edgesl forM ndis $ \ndi -> do prods <- mapM (mkProdDependencyGraphM False) (ndiProds $ ndimOrig ndi) forM_ (zip prods (ndimProds ndi)) $ \(nprod,oprod) -> do -- All possible edges let possa = do (v1,v2) <- edges -- Take a child of this nonterminal type guard $ isVertexAttr v1 guard $ isVertexAttr v2 let tp = getAttrChildName v1 (ch,chtp) <- pdgChildMap $ pdgmOrig nprod guard $ tp == chtp -- Construct edge as it should be in the production graph let nv1 = setAttrChildName v1 ch let nv2 = setAttrChildName v2 ch return (nv1, nv2) toadd <- filterM (graphContainsEdge (pdgmDepGraph oprod)) possa graphInsertEdges (pdgmDepGraph nprod) toadd return $ NontDependencyInformationM { ndimOrig = ndimOrig ndi , ndimDepGraph = ndimDepGraph ndi , ndimProds = prods } ------------------------------------------------------------------------------- -- Knuth-1 algorithm ------------------------------------------------------------------------------- -- | Combine the dependency and nonterminal graphs using Knuth-1 -- this function assumes that the nonterminal graphs initially contains no edges knuth1 :: [NontDependencyInformationM s] -> ST s () knuth1 ndis = do -- Create initial list of pending edges for each ndi per production (initially all prod edges) -- pndis :: [([[Edge]], NontDependencyInformation)] pndis <- forM ndis $ \ndi -> do ipend <- mapM (graphEdges . pdgmDepGraph) . ndimProds $ ndi return (ipend, ndi) knuth1' pndis -- | Helper function for |knuth1| which repeats the process until we are done knuth1' :: [([[Edge]], NontDependencyInformationM s)] -> ST s () knuth1' ndis = do -- Add edges from the production graphs to the nonterminal graph -- ndis' :: [[Edge]] ndis' <- mapM addProdNont ndis -- List of all newly added edges -- ntedge :: [Edge] let pntedge = concat ndis' -- Add backedges --bedges <- addBackEdges ndis -- All added nonterminal edges let ntedge = pntedge -- ++ bedges if null ntedge -- When no new edges have been added we are done then return () else do -- Otherwise, the next step is to add edges from nonterminal to production graphs -- ndis'' :: [[[Edge]]] ndis'' <- mapM (\(_,x) -> addNontProd True (ntedge, x)) ndis -- List of new states (production edges + dependency graphs) -- nndis' :: [([[Edge]], NontDependencyInformation)] nndis' <- zipWithM (\(_,ndi) me -> return (me, ndi)) ndis ndis'' if any (not . null) ndis'' -- We have added some edges, so continue the process then knuth1' nndis' -- No new edges added, we are done else return () -- | Add pending edges from the production graphs to the nonterminal graph -- and return the list of newly added nonterminal edges addProdNont :: ([[Edge]], NontDependencyInformationM s) -> ST s [Edge] addProdNont (pending, ndi) = do -- Unwrapping of the records let nontDepGraph = ndimDepGraph ndi let nontGraph = ndgmDepGraph nontDepGraph -- nub the list because multiple productions can result in the same new edges let possa = nub $ do (v1,v2) <- concat pending -- Take only edges from syn.lhs to inh.lhs guard $ isVertexAttr v1 guard $ getAttrChildName v1 == _LHS guard $ getAttrType v1 == Syn guard $ isVertexAttr v2 guard $ getAttrChildName v2 == _LHS guard $ getAttrType v2 == Inh -- Construct edge as it should be in nonterminal graph let nv1 = setAttrChildName v1 (ndiNonterminal $ ndimOrig ndi) let nv2 = setAttrChildName v2 (ndiNonterminal $ ndimOrig ndi) return (nv1, nv2) -- Edges that are not in the nonterminal graph yet toadd <- filterM (\e -> return not `ap` graphContainsEdge nontGraph e) possa -- Check whether new edges are to be added and return the added edges when (not $ null toadd) $ do graphInsertEdgesTRC nontGraph toadd return () return toadd -- | Add edges from the nonterminal graphs to the production graphs -- and return the list of newly added production edges and the updated graph addNontProd :: Bool -> ([Edge], NontDependencyInformationM s) -> ST s [[Edge]] addNontProd trc (pending, ndi) = do -- Just call the helper function for each nonterminal mapM (addNontProd' trc pending) (ndimProds ndi) -- | Helper function for |addNontProd| for a single production addNontProd' :: Bool -> [Edge] -> ProdDependencyGraphM s -> ST s [Edge] addNontProd' trc pend pdg = do -- Unwrapping of the records prodGraph <- return $ pdgmDepGraph pdg -- Construct all possible new edges let possa = do (v1,v2) <- pend -- Take a child of this nonterminal type guard $ isVertexAttr v1 guard $ isVertexAttr v2 let tp = getAttrChildName v1 (ch,chtp) <- pdgChildMap $ pdgmOrig pdg guard $ tp == chtp -- Construct edge as it should be in the production graph let nv1 = setAttrChildName v1 ch let nv2 = setAttrChildName v2 ch return (nv1, nv2) -- Edges that are not in the production graph yet toadd <- filterM (\e -> return not `ap` graphContainsEdge prodGraph e) possa -- Check whether new edges are to be added and return the result if null toadd then return [] else do -- Insert all edges and return transitive edges that are added in this process ret <- if trc then graphInsertEdgesTRC prodGraph toadd else do mapM_ (graphInsert prodGraph) toadd return [] -- Debug output --mapM_ (\edge -> traceST $ "Adding production edge " ++ show edge) toadd return ret -- | Add the "back edges" to the nonterminal graphs for creating a global ordering addBackEdges :: [([[Edge]], NontDependencyInformationM s)] -> ST s [Edge] addBackEdges ndis = do -- gather all backedges lBackEdges <- forM ndis $ \(aedg,ndi) -> do -- For every production bs <- forM (zip aedg (ndimProds ndi)) $ \(edg,prod) -> do -- Filter out the backedges return $ do (v1,v2) <- edg -- Backedges are from inh.ch to syn.ch guard $ isVertexAttr v1 guard $ getAttrChildName v1 /= _LHS guard $ getAttrType v1 == Inh guard $ isVertexAttr v2 guard $ getAttrChildName v2 /= _LHS guard $ getAttrType v2 == Syn guard $ getAttrChildName v1 == getAttrChildName v2 -- Find the correct child name (ch,chtp) <- pdgChildMap $ pdgmOrig prod let tp = getAttrChildName v1 guard $ tp == ch -- Construct the edge as it should be in the nonterminal graph let nv1 = setAttrChildName v1 chtp let nv2 = setAttrChildName v2 chtp return (nv1, nv2) return $ foldl' union [] bs -- Concatenate all lists of backedges let backedges = foldl' union [] lBackEdges -- Add backedges to every nonterminal graph ret <- forM ndis $ \(_,ndi) -> do -- Find the backedges for this nonterminal let nont = ndiNonterminal . ndimOrig $ ndi let thisbe = filter ((==) nont . getAttrChildName . fst) backedges -- Add them to the graph graphInsertEdgesTRC (ndgmDepGraph . ndimDepGraph $ ndi) thisbe return $ backedges ++ concat ret -- | Add all resulting edges from a topsort on the nonterminal graph to the production graph -- this will ignore edges that will make the graph cyclic addTopSortEdges :: [Edge] -> ProdDependencyGraphM s -> ST s () addTopSortEdges pend pdg = do -- Unwrapping of the records prodGraph <- return $ pdgmDepGraph pdg -- Construct all possible new edges let possa = do (v1,v2) <- pend -- Take a child of this nonterminal type guard $ isVertexAttr v1 guard $ isVertexAttr v2 let tp = getAttrChildName v1 (ch,chtp) <- pdgChildMap $ pdgmOrig pdg guard $ tp == chtp -- Construct edge as it should be in the production graph let nv1 = setAttrChildName v1 ch let nv2 = setAttrChildName v2 ch return (nv1, nv2) -- Edges that are not in the production graph yet forM_ possa $ \(v1,v2) -> do e1 <- graphContainsEdge prodGraph (v1,v2) e2 <- graphContainsEdge prodGraph (v2,v1) when (not $ e1 || e2) $ do graphInsertTRC prodGraph (v1,v2) return ()