diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Grasp/Interpreter.hs | 42 | ||||
| -rw-r--r-- | src/Grasp/Monad.hs | 77 |
2 files changed, 111 insertions, 8 deletions
diff --git a/src/Grasp/Interpreter.hs b/src/Grasp/Interpreter.hs index bca167a..c9d807e 100644 --- a/src/Grasp/Interpreter.hs +++ b/src/Grasp/Interpreter.hs @@ -152,12 +152,50 @@ pickI = GMonad.updateIP callI :: GraspM () -callI = GMonad.updateIP +callI = do + curNode <- GMonad.peekIP >>= return . Maybe.fromJust + + funcNodes <- GMonad.nodesOut (EL.mk "func") curNode + argEdges <- GMonad.edgesOut curNode + ae <- return (filter (\x -> (GE.toLabel x) /= (EL.mk "name") && (GE.toLabel x) /= (EL.mk "cond") && + (GE.toLabel x) /= (EL.mk "next") && (GE.toLabel x) /= (EL.mk "func")) argEdges) + possibleFuncs <- mapM GMonad.nodesWithName (map GN.toInst funcNodes) >>= return . concat + + Monad.when (length possibleFuncs < 1) (error "Instruction call has no applicable func candidates") + + r <- liftIO (Random.getStdRandom (Random.randomR (0, length possibleFuncs - 1))) + (sn, se) <- GMonad.subGraph (possibleFuncs !! r) + + sn' <- GMonad.newNodes (map GN.toInst sn) + let nodeMap = zip (map GN.toNode sn) (map GN.toNode sn') + translate = Maybe.fromJust . (flip lookup nodeMap) + se' <- return (map (\x -> GE.mk (translate . GE.toSrc $ x, translate . GE.toDest $ x, GE.toLabel x)) se) + + let calledNode = GN.mk (translate (GN.toNode (possibleFuncs !! r)), GN.toInst (possibleFuncs !! r)) + ae' <- return (map (\x -> GE.mk (GN.toNode calledNode, GE.toDest x, GE.toLabel x)) ae) + + GMonad.insNodes sn' + GMonad.insEdges (se' ++ ae') + + GMonad.pushIP calledNode retI :: GraspM () -retI = GMonad.updateIP +retI = do + curNode <- GMonad.peekIP >>= return . Maybe.fromJust + + retEdges <- GMonad.edgesOut curNode + re <- return (filter (\x -> (GE.toLabel x) /= (EL.mk "name") && (GE.toLabel x) /= (EL.mk "next") && + (GE.toLabel x) /= (EL.mk "cond")) retEdges) + + GMonad.popIP + GMonad.updateIP + curNode' <- GMonad.peekIP + + Monad.when (Maybe.isJust curNode') (do + re' <- return (map (\x -> GE.mk (GN.toNode . Maybe.fromJust $ curNode', GE.toDest x, GE.toLabel x)) re) + GMonad.insEdges re' ) diff --git a/src/Grasp/Monad.hs b/src/Grasp/Monad.hs index ba500af..86de9a2 100644 --- a/src/Grasp/Monad.hs +++ b/src/Grasp/Monad.hs @@ -15,6 +15,11 @@ module Grasp.Monad ( nodesOut, edgesOut, reLabel, + nodesWithName, + subGraph, + newNodes, + insNode, insNodes, + delNode, delNodes, insEdge, insEdges, delEdge, delEdges ) where @@ -81,7 +86,7 @@ construct (ns,es) = do Monad.when (noMain ns es) (error "could not find grasp:main") let graph = Graph.mkGraph (map GN.toLNode ns) (map GE.toLEdge es) - ips = map IP.singleton (nodesWithName ns es "grasp:main") + ips = map IP.singleton (getNodesWithName ns es "grasp:main") handles = Map.empty State.put (graph, ips, handles) @@ -111,14 +116,14 @@ nameNodeList ns es = -nodesWithName :: [GNode] -> [GEdge] -> String -> [GNode] -nodesWithName ns es name = +getNodesWithName :: [GNode] -> [GEdge] -> String -> [GNode] +getNodesWithName ns es name = (map fst) . (filter (\x -> (GN.toInst . snd $ x) == (IN.mk name))) $ (nameNodeList ns es) -namedNodes :: [GNode] -> [GEdge] -> [GNode] -namedNodes ns es = map fst (nameNodeList ns es) +getNamedNodes :: [GNode] -> [GEdge] -> [GNode] +getNamedNodes ns es = map fst (nameNodeList ns es) @@ -176,7 +181,7 @@ garbageCollect gr ips = reachable :: Gr Instruction EdgeLabel -> [IP] -> [Node] reachable gr ips = - let named = namedNodes (map GN.mk (Graph.labNodes gr)) (map GE.mk (Graph.labEdges gr)) + let named = getNamedNodes (map GN.mk (Graph.labNodes gr)) (map GE.mk (Graph.labEdges gr)) ipNodes = concatMap IP.toList ips start = (map GN.toNode) . List.nub $ named ++ ipNodes in reach gr start [] @@ -338,6 +343,66 @@ reLabel i n = do +nodesWithName :: Instruction -> GraspM [GNode] +nodesWithName x = do + (gr, ips, fh) <- State.get + let ns = map GN.mk (Graph.labNodes gr) + es = map GE.mk (Graph.labEdges gr) + return (getNodesWithName ns es (IN.toString x)) + + + +subGraph :: GNode -> GraspM ([GNode],[GEdge]) +subGraph n = do + (gr, ips, fh) <- State.get + let rNodes = reach gr [GN.toNode n] [] + rEdges = filter (\(x,y,z) -> x `elem` rNodes && y `elem` rNodes) (Graph.labEdges gr) + result = (map (\x -> GN.mk (x, Maybe.fromJust (Graph.lab gr x))) rNodes, map GE.mk rEdges) + return result + + + +newNodes :: [Instruction] -> GraspM [GNode] +newNodes is = do + (gr, ips, fh) <- State.get + let newNs = Graph.newNodes (length is) gr + newGNs = map GN.mk (zip newNs is) + return newGNs + + + +insNode :: GNode -> GraspM () +insNode n = do + (gr, ips, fh) <- State.get + let gr' = Graph.insNode (GN.toLNode n) gr + State.put (gr', ips, fh) + + + +insNodes :: [GNode] -> GraspM () +insNodes ns = do + (gr, ips, fh) <- State.get + let gr' = Graph.insNodes (map GN.toLNode ns) gr + State.put (gr', ips, fh) + + + +delNode :: GNode -> GraspM () +delNode n = do + (gr, ips, fh) <- State.get + let gr' = Graph.delNode (GN.toNode n) gr + State.put (gr', ips, fh) + + + +delNodes :: [GNode] -> GraspM () +delNodes ns = do + (gr, ips, fh) <- State.get + let gr' = Graph.delNodes (map GN.toNode ns) gr + State.put (gr', ips, fh) + + + insEdge :: GEdge -> GraspM () insEdge e = do (gr, ips, fh) <- State.get |