Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

intraprocedural graphs printed to graphviz

  • Loading branch information...
commit b4b1bd9fd060c4c48848f2766d4f9e748831f5a5 1 parent 923c046
Arjun Guha authored
View
3  WebBits.cabal
@@ -54,7 +54,8 @@ Executable webbits
Hs-Source-Dirs: src
Build-Depends:
base>=4, mtl>=1.1.0.1, parsec<3.0.0, pretty>=0.1, containers>=0.1, syb>=0.1,
- HUnit>=1.2.0.3,filepath>=1.1.0.1,directory>=1.0.0.2
+ HUnit>=1.2.0.3,filepath>=1.1.0.1,directory>=1.0.0.2,process,fgl,bytestring,
+ graphviz
ghc-options:
-fwarn-incomplete-patterns
Extensions:
View
2  scripts/ghci
@@ -12,7 +12,7 @@ fi
OBJS=$BASE/dist/build/HSWebBits-0.10.0.o
SRCS=$BASE/dist/build/autogen:$BASE/src
-PKGS="-package mtl -package parsec-2.1.0.1 -package pretty -package containers"
+PKGS="-package mtl -package parsec-2.1.0.1 -package pretty -package containers -package fgl"
if [ $MODE = "obj" ]; then
# You need to ':m +' the modules you want after this.
View
15 src/WebBits/JavaScript/ANFUtils.hs
@@ -0,0 +1,15 @@
+module WebBits.JavaScript.ANFUtils where
+
+import Data.Generics
+import Text.ParserCombinators.Parsec.Pos
+import WebBits.Common
+import WebBits.JavaScript.Core
+
+allFuncExprs :: [Stmt SourcePos] -> [Expr SourcePos]
+allFuncExprs stmts = everything (++) (mkQ [] getFuncExpr) stmts where
+
+ getFuncExpr :: Expr SourcePos -> [Expr SourcePos]
+ getFuncExpr fn@(FuncExpr{}) = [fn]
+ getFuncExpr _ = []
+
+
View
34 src/WebBits/JavaScript/Core.hs
@@ -9,6 +9,7 @@ module WebBits.JavaScript.Core
import Data.Generics
import Control.Arrow (first,second,(***))
+import Text.Printf
type Id = String
@@ -89,7 +90,7 @@ data Stmt a
| SwitchStmt a Id [(Lit a,Stmt a)]
| EnterStmt a
| ExitStmt a
- deriving (Show,Data,Typeable,Eq,Ord)
+ deriving (Data,Typeable,Eq,Ord)
stmtLabel :: Stmt a -> a
stmtLabel stmt = case stmt of
@@ -113,6 +114,7 @@ stmtLabel stmt = case stmt of
(SwitchStmt a v cs) -> a
(EnterStmt a) -> a
(ExitStmt a) -> a
+ ThrowStmt a _ -> a
-- Instances
@@ -132,6 +134,7 @@ instance Functor Expr where
fmap f (This a) = This (f a)
fmap f (VarRef a v) = VarRef (f a) v
fmap f (BracketRef a e1 e2) = BracketRef (f a) (fmap f e1) (fmap f e2)
+ fmap f (DotRef a e1 m) = DotRef (f a) (fmap f e1) m
fmap f (OpExpr a op es) = OpExpr (f a) op (map (fmap f) es)
fmap f (FuncExpr a args locals s) =
FuncExpr (f a) args locals (fmap f s)
@@ -161,3 +164,32 @@ instance Functor Stmt where
SwitchStmt (f a) v (map (fmap f *** fmap f) cs)
fmap f (EnterStmt a) = EnterStmt (f a)
fmap f (ExitStmt a) = ExitStmt (f a)
+ fmap f (ThrowStmt a e) = ThrowStmt (f a) (fmap f e)
+
+instance Show (Stmt a) where
+ show stmt = case stmt of
+ SeqStmt a ss -> "Seq ..."
+ EmptyStmt a -> "No-op ..."
+ AssignStmt a v e -> v ++ " := ..."
+ DeleteStmt a v1 v2 -> printf "%s := delete ..." v1
+ NewStmt a result constr args ->
+ printf "%s := new %s (...)" result constr
+ CallStmt a result fn args ->
+ printf "%s := %s (...)" result fn
+ MethodCallStmt a result obj method args ->
+ printf "%s := %s.%s(...)" result obj method
+ IndirectMethodCallStmt a result obj method args ->
+ printf "%s := %s[%s](...)" result obj method
+ IfStmt a e s1 s2 -> "if ..."
+ WhileStmt a e s -> "while ..."
+ ForInStmt a v e s -> printf "for (%s in ..." v
+ TryStmt a s1 v s2 s3 -> "try ..."
+ ReturnStmt a Nothing -> "return;"
+ ReturnStmt a (Just e) -> "return ...;"
+ LabelledStmt a v s -> printf "Label %s" v
+ BreakStmt a v -> printf "break %s" v
+ ContinueStmt a v -> printf "continue %s" v
+ SwitchStmt a v cs -> "switch ..."
+ EnterStmt a -> "ENTER"
+ ExitStmt a -> "EXIT"
+ ThrowStmt _ _ -> "throw ..."
View
135 src/WebBits/JavaScript/Intraprocedural.hs
@@ -2,28 +2,32 @@
-- procedure.
module WebBits.JavaScript.Intraprocedural
( intraprocGraph
- , Edges
+ , intraprocGraph'
+ , Graph
) where
import qualified Data.List as L
import qualified Data.Map as M
+import qualified Data.Graph.Inductive as G
+import Data.Graph.Inductive.PatriciaTree (Gr)
import Control.Monad.State.Strict
import Text.ParserCombinators.Parsec.Pos (SourcePos, initialPos)
import Data.Generics
import WebBits.JavaScript.Core
import WebBits.Common() -- Data SourcePos
+import System.IO.Unsafe
noPos = initialPos "Intraprocedural.hs"
-numStmts :: Stmt (Int,SourcePos) -> Int
-numStmts s = gcount (mkQ False isStmt) s where
- isStmt :: Stmt (Int,SourcePos) -> Bool
- isStmt _ = True
+type Node = (Int,Stmt (Int,SourcePos))
+type Graph = Gr (Stmt (Int,SourcePos)) ()
numberStmts :: Stmt SourcePos -> Stmt (Int,SourcePos)
-numberStmts stmts = evalState (gmapM (mkM numberM) stmts') 0 where
+numberStmts stmts = evalState (everywhereM (mkM numberM) stmts') 0 where
+
stmts' :: Stmt (Int,SourcePos)
stmts' = fmap (\p -> (0,p)) stmts
+
numberM :: (Int,SourcePos) -> State Int (Int,SourcePos)
numberM (_,p) = do
n <- get
@@ -41,96 +45,125 @@ mapM2 f (x:xs) (y:ys) = do
-- ^The control stack of statements, along with the next statement
-- for each statement in this stack.
-type Stack = [(String,(Stmt (Int,SourcePos),Stmt (Int,SourcePos)))]
+type Stack = [(String,(Int,Int))]
-type Edges = M.Map Int [Int]
-stackReturn :: Stack -> Stmt (Int,SourcePos)
+stackReturn :: Stack -> Int
stackReturn [] = error "stackReturn : empty stack (should have return)"
stackReturn stack = fst $ snd $ L.last stack
initStack :: Stmt (Int,SourcePos) -> Stack
-initStack exitStmt = [("$exit not find",(exitStmt,error "next of ExitStmt"))]
+initStack exitStmt =
+ [("$exit not find",(fst $ stmtLabel exitStmt,error "next of ExitStmt"))]
-nextStmt :: String -> Stack -> Stmt (Int,SourcePos)
+nextStmt :: String -> Stack -> Int
nextStmt n stack = case lookup n stack of
Just (_,s) -> s
Nothing -> error "nextStmt: not on stack"
-toStmt :: String -> Stack -> Stmt (Int,SourcePos)
+toStmt :: String -> Stack -> Int
toStmt n stack = case lookup n stack of
Just (s,_) -> s
Nothing -> error "toStmt: not on stack"
-edge :: Stmt (Int,SourcePos) -> Stmt (Int,SourcePos) -> State Edges ()
-edge s1 s2 = do
- m <- get
- let l1 = fst $ stmtLabel s1
- let l2 = fst $ stmtLabel s2
- put (M.insertWith' (const $ (l2:)) l1 [l2] m)
+edge :: Int -> Int -> State Graph ()
+edge i1 i2 = do
+ gr <- get
+ put (G.insEdge (i1,i2,()) gr)
+
+edgeCreate :: Stmt (Int,SourcePos)
+ -> Int
+ -> State Graph ()
+edgeCreate stmtSrc dest = do
+ src <- node stmtSrc
+ edge src dest
+
+node :: Stmt (Int,SourcePos) -> State Graph Int
+node stmt = do
+ gr <- get
+ let ix = fst $ stmtLabel stmt
+ put (G.insNode (ix,stmt) gr)
+ return ix
stmt :: Stack
-- ^The control stack is used to translate "structured gotos"
- -> Stmt (Int,SourcePos)
+ -> Int
-- ^The next statement. We will usually add an edge to this statement.
-> Stmt (Int,SourcePos)
- -> State Edges ()
+ -> State Graph ()
stmt stack next s = case s of
SeqStmt a [] -> fail "empty sequence"
SeqStmt a ss -> do
- edge s (head ss)
- mapM2 (stmt stack) ss (tail ss ++ [next])
+ edgeCreate s (fst $ stmtLabel (head ss))
+ -- s1 -> s2, s2 -> s3, ... , s_n -> next
+ mapM2 (stmt stack) (tail (map (fst.stmtLabel) ss) ++ [next]) ss
return ()
- BreakStmt a n ->
- edge s (nextStmt n stack)
- ContinueStmt _ n -> edge s (toStmt n stack)
- EmptyStmt _ -> edge s next
- AssignStmt _ _ _ -> edge s next
- DeleteStmt _ _ _ -> edge s next
- NewStmt _ _ _ _ -> edge s next -- TODO: node splitting?
- CallStmt _ _ _ _ -> edge s next
- MethodCallStmt _ _ _ _ _ -> edge s next
- IndirectMethodCallStmt _ _ _ _ _ -> edge s next
+ BreakStmt a n -> edgeCreate s (nextStmt n stack)
+ ContinueStmt _ n -> edgeCreate s (toStmt n stack)
+ EmptyStmt _ -> edgeCreate s next
+ AssignStmt _ _ _ -> edgeCreate s next
+ DeleteStmt _ _ _ -> edgeCreate s next
+ NewStmt _ _ _ _ -> edgeCreate s next -- TODO: node splitting?
+ CallStmt _ _ _ _ -> edgeCreate s next
+ MethodCallStmt _ _ _ _ _ -> edgeCreate s next
+ IndirectMethodCallStmt _ _ _ _ _ -> edgeCreate s next
IfStmt _ _ s1 s2 -> do
- edge s s1
- edge s s2
+ i <- node s
+ edge i (fst $ stmtLabel s1)
+ edge i (fst $ stmtLabel s2)
stmt stack next s1
stmt stack next s2
WhileStmt _ _ s1 -> do
+ i <- node s
-- The next statement after executing the body, is to renter the loop
- stmt stack s s1
+ stmt stack i s1
-- Eventually, the loop condition will be false and the next statement will
-- be next. The only way to directly jump to next out of the body, is to
-- break.
- edge s next
+ edge i next
ForInStmt _ _ _ s1 -> do
- stmt stack s s1
- edge s next
+ i <- node s
+ stmt stack i s1
+ edge i next
TryStmt _ body _ catch finally -> do
-- TODO: account for catch
-- TODO: This treatment of finally is incorrect
- stmt stack finally body
+ edgeCreate s (fst $ stmtLabel body)
+ stmt stack (fst $ stmtLabel finally) body
stmt stack next finally
ThrowStmt _ _ -> return () -- TODO: um...
ReturnStmt _ _ ->
- edge s (stackReturn stack)
+ edgeCreate s (stackReturn stack)
LabelledStmt _ lbl s1 -> do
- edge s s1
- stmt ((lbl,(s,next)):stack) next s1
+ i <- node s
+ edge i (fst $ stmtLabel s1)
+ stmt ((lbl,(i,next)):stack) next s1
SwitchStmt _ _ cases -> do
- mapM (edge s) (map snd cases)
- mapM2 (stmt stack) (map snd cases)
- (map snd (tail cases) ++ [next])
+ i <- node s
+ mapM (edge i) (map (fst.stmtLabel.snd) cases)
+ -- Each block may fallthrough to the next block
+ mapM2 (stmt stack)
+ (map (fst.stmtLabel.snd) (tail cases) ++ [next])
+ (map snd cases)
return ()
+ EnterStmt _ -> edgeCreate s next
ExitStmt _ -> return () -- next == s for convenience
+
+stmtToNode :: Stmt (Int,SourcePos)
+ -> (Int,Stmt (Int,SourcePos))
+stmtToNode stmt = (fst $ stmtLabel stmt,stmt)
+
+intraprocGraph' :: Stmt SourcePos -> Graph
+intraprocGraph' stmt = snd (intraprocGraph noPos noPos stmt)
+
-- |Build an intraprocedural graph for the body of a procedure. This function
-- will add the 'EnterStmt' and 'ExitStmt' nodes. All the nodes will be
-- labelled with integers starting from zero.
intraprocGraph :: SourcePos -- ^location of the entry point
-> SourcePos -- ^location of the exit point
- -> Stmt SourcePos -> (Stmt (Int,SourcePos), Edges)
+ -> Stmt SourcePos -> (Stmt (Int,SourcePos),Graph)
intraprocGraph enterPos exitPos body = (full,graph) where
-- Small trick to turn the EnterStmt and the body into a single numbered
@@ -138,10 +171,14 @@ intraprocGraph enterPos exitPos body = (full,graph) where
body' = SeqStmt noPos [SeqStmt noPos [EnterStmt enterPos, body],
ExitStmt exitPos]
full@(SeqStmt _ [labelledBody,labelledExitStmt]) = numberStmts body'
+
+ exitNode = stmtToNode labelledExitStmt
+ initialGraph :: Gr (Stmt (Int,SourcePos)) ()
+ initialGraph = G.insNode exitNode G.empty
graph = execState
(stmt (initStack labelledExitStmt)
- labelledExitStmt
+ (fst $ stmtLabel labelledExitStmt)
labelledBody)
- M.empty
-
+ initialGraph
+
View
22 src/Webbits.hs
@@ -4,13 +4,27 @@ import Control.Monad (liftM )
import WebBits.Test
import WebBits.JavaScript.Simplify (simplify)
+import WebBits.JavaScript.Core
import WebBits.JavaScript.ToCore (jsToCore)
import WebBits.JavaScript.Env
+import WebBits.JavaScript.ANFUtils
+import WebBits.JavaScript.Intraprocedural
+import qualified Data.Graph.Inductive as G
+import qualified Data.GraphViz as GV
+
+intraprocGraphToDot :: Graph -> GV.DotGraph
+intraprocGraphToDot gr = GV.graphToDot gr [] -- attributes
+ (\(n,s) -> [GV.Label (show s)]) -- node attributes
+ (const []) -- edge attributes
main = do
str <- getContents
let script = parse "" str
- putStrLn (show (localVars script))
- let simplified = simplify script
- putStrLn $ pretty simplified
- putStrLn $ show (jsToCore simplified)
+ -- putStrLn (show (localVars script))
+ putStrLn (pretty $ simplify script)
+ let core = jsToCore (simplify script)
+ let funcExprs = allFuncExprs core
+ let graphs = map (intraprocGraph'.funcExprBody) funcExprs
+ mapM_ (putStrLn.show.(G.labEdges)) graphs
+ let vizs = map (show.intraprocGraphToDot) graphs
+ mapM_ (putStrLn) vizs
Please sign in to comment.
Something went wrong with that request. Please try again.