Permalink
Browse files

integer labelling done by Intraprocedural.hs

  • Loading branch information...
1 parent 7e7e785 commit afb834d7877bd9b15e3eddd4b58c30bd8f6a85a8 Arjun Guha committed Mar 12, 2009
Showing with 52 additions and 58 deletions.
  1. +2 −2 scripts/ghci
  2. +2 −2 src/WebBits/JavaScript/Core.hs
  3. +31 −19 src/WebBits/JavaScript/Intraprocedural.hs
  4. +17 −35 src/WebBits/JavaScript/ToCore.hs
View
@@ -12,12 +12,12 @@ fi
OBJS=$BASE/dist/build/HSWebBits-0.10.0.o
SRCS=$BASE/dist/build/autogen:$BASE/src
-PKGS="-package mtl -package parsec -package pretty -package containers"
+PKGS="-package mtl -package parsec-2.1.0.1 -package pretty -package containers"
if [ $MODE = "obj" ]; then
# You need to ':m +' the modules you want after this.
ghci $PKGS $OBJS;
elif [ $MODE = "src" ]; then
# You need to ':load' the modules you want after this.
- ghci -fglasgow-exts -i$SRCS;
+ ghci -fglasgow-exts $PKGS -i$SRCS;
fi
@@ -84,8 +84,8 @@ data Stmt a
| ThrowStmt a (Expr a)
| ReturnStmt a (Maybe (Expr a))
| LabelledStmt a Id (Stmt a)
- | BreakStmt a Int
- | ContinueStmt a Int
+ | BreakStmt a String
+ | ContinueStmt a String
| SwitchStmt a Id [(Lit a,Stmt a)]
| EnterStmt a
| ExitStmt a
@@ -1,6 +1,9 @@
-- |Generates an intraprocedural control flow graph for a single JavaScript
-- procedure.
-module WebBits.JavaScript.Intraprocedural where
+module WebBits.JavaScript.Intraprocedural
+ ( intraprocGraph
+ , Edges
+ ) where
import qualified Data.List as L
import qualified Data.Map as M
@@ -38,17 +41,24 @@ 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 = [(Stmt (Int,SourcePos),Stmt (Int,SourcePos))]
+type Stack = [(String,(Stmt (Int,SourcePos),Stmt (Int,SourcePos)))]
type Edges = M.Map Int [Int]
-nextStmt :: Int -> Stack -> Stmt (Int,SourcePos)
-nextStmt n stack = case L.find ((==n).fst.stmtLabel.fst) stack of
+stackReturn :: Stack -> Stmt (Int,SourcePos)
+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"))]
+
+nextStmt :: String -> Stack -> Stmt (Int,SourcePos)
+nextStmt n stack = case lookup n stack of
Just (_,s) -> s
Nothing -> error "nextStmt: not on stack"
-toStmt :: Int -> Stack -> Stmt (Int,SourcePos)
-toStmt n stack = case L.find ((==n).fst.stmtLabel.fst) stack of
+toStmt :: String -> Stack -> Stmt (Int,SourcePos)
+toStmt n stack = case lookup n stack of
Just (s,_) -> s
Nothing -> error "toStmt: not on stack"
@@ -59,16 +69,18 @@ edge s1 s2 = do
let l2 = fst $ stmtLabel s2
put (M.insertWith' (const $ (l2:)) l1 [l2] m)
+
stmt :: Stack
- -- |The next statement. We will usually add an edge to this statement.
+ -- ^The control stack is used to translate "structured gotos"
-> Stmt (Int,SourcePos)
+ -- ^The next statement. We will usually add an edge to this statement.
-> Stmt (Int,SourcePos)
-> State Edges ()
stmt stack next s = case s of
SeqStmt a [] -> fail "empty sequence"
SeqStmt a ss -> do
edge s (head ss)
- mapM2 (stmt ((s,next):stack)) ss (tail ss ++ [next])
+ mapM2 (stmt stack) ss (tail ss ++ [next])
return ()
BreakStmt a n ->
edge s (nextStmt n stack)
@@ -83,32 +95,32 @@ stmt stack next s = case s of
IfStmt _ _ s1 s2 -> do
edge s s1
edge s s2
- stmt ((s,next):stack) next s1
- stmt ((s,next):stack) next s2
+ stmt stack next s1
+ stmt stack next s2
WhileStmt _ _ s1 -> do
-- The next statement after executing the body, is to renter the loop
- stmt ((s,next):stack) s s1
+ stmt stack s 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
ForInStmt _ _ _ s1 -> do
- stmt ((s,next):stack) s s1
+ stmt stack s s1
edge s next
TryStmt _ body _ catch finally -> do
-- TODO: account for catch
-- TODO: This treatment of finally is incorrect
- stmt ((s,finally):stack) finally body
- stmt ((s,next):stack) next finally
+ stmt stack finally body
+ stmt stack next finally
ThrowStmt _ _ -> return () -- TODO: um...
ReturnStmt _ _ ->
- edge s (fst $ L.last stack)
- LabelledStmt _ _ s1 -> do
+ edge s (stackReturn stack)
+ LabelledStmt _ lbl s1 -> do
edge s s1
- stmt stack next s1
+ stmt ((lbl,(s,next)):stack) next s1
SwitchStmt _ _ cases -> do
mapM (edge s) (map snd cases)
- mapM2 (stmt ((s,next):stack)) (map snd cases)
+ mapM2 (stmt stack) (map snd cases)
(map snd (tail cases) ++ [next])
return ()
ExitStmt _ -> return () -- next == s for convenience
@@ -128,7 +140,7 @@ intraprocGraph enterPos exitPos body = (full,graph) where
full@(SeqStmt _ [labelledBody,labelledExitStmt]) = numberStmts body'
graph = execState
- (stmt [(labelledExitStmt, error "next of ExitStmt")]
+ (stmt (initStack labelledExitStmt)
labelledExitStmt
labelledBody)
M.empty
@@ -15,20 +15,9 @@ import qualified WebBits.JavaScript.Core as Core
import WebBits.JavaScript
import WebBits.JavaScript.Simplify (simplify)
-
-numberStmts :: [Statement SourcePos] -> [Statement (Int,SourcePos)]
-numberStmts stmts = evalState (gmapM (mkM numberM) stmts') 0 where
- stmts' :: [Statement (Int,SourcePos)]
- stmts' = map (fmap (\p -> (0,p))) stmts
- numberM :: (Int,SourcePos) -> State Int (Int,SourcePos)
- numberM (_,p) = do
- n <- get
- put (n+1)
- return (n,p)
-
jsToCore :: [Statement SourcePos]
- -> [Core.Stmt (Int,SourcePos)]
-jsToCore (VarDeclStmt{}:stmts) = map (stmt M.empty) (numberStmts stmts)
+ -> [Core.Stmt SourcePos]
+jsToCore (VarDeclStmt{}:stmts) = map stmt stmts
jsToCore stmts = error $ "jsToCore: missing global vars:\n" ++ show stmts
unId (Id _ v) = v
@@ -80,12 +69,11 @@ getLabel f = case Foldable.find (const True) f of
Nothing -> error "getLabel failed"
-- Takes a map from string labels to statement numbers
-stmt :: M.Map String Int
- -> Statement (Int,SourcePos)
- -> Core.Stmt (Int,SourcePos)
-stmt lbl (BlockStmt p ss) = Core.SeqStmt p (map (stmt lbl) ss)
-stmt lbl (EmptyStmt p) = Core.EmptyStmt p
-stmt lbl (ExprStmt p (AssignExpr _ OpAssign (VarRef _ (Id _ r)) rhs)) =
+stmt :: Statement SourcePos
+ -> Core.Stmt SourcePos
+stmt (BlockStmt p ss) = Core.SeqStmt p (map (stmt) ss)
+stmt (EmptyStmt p) = Core.EmptyStmt p
+stmt (ExprStmt p (AssignExpr _ OpAssign (VarRef _ (Id _ r)) rhs)) =
case rhs of
CallExpr p (DotRef _ f id) args ->
Core.MethodCallStmt p r (unVar f) (unId id) (map unVar args)
@@ -95,21 +83,15 @@ stmt lbl (ExprStmt p (AssignExpr _ OpAssign (VarRef _ (Id _ r)) rhs)) =
NewExpr p f args -> Core.NewStmt p r (unVar f) (map unVar args)
PrefixExpr p PrefixDelete id -> Core.DeleteStmt p r (unVar id)
e -> Core.AssignStmt p r (expr e)
-stmt lbl (IfStmt p e s1 s2) = Core.IfStmt p (expr e) (stmt lbl s1) (stmt lbl s2)
-stmt lbl (WhileStmt p e s) = Core.WhileStmt p (expr e) (stmt lbl s)
-stmt lbl (ForInStmt p (ForInNoVar id) e s) =
- Core.ForInStmt p (unId id) (expr e) (stmt lbl s)
-stmt lbl (ReturnStmt p maybeE) = Core.ReturnStmt p (liftM expr maybeE)
-stmt lbl (LabelledStmt p (Id _ id) s) =
- stmt (M.insert id (fst $ getLabel $ unlabelled s) lbl) s
-stmt lbl (BreakStmt p (Just (Id _ id))) = case M.lookup id lbl of
- Just n -> Core.BreakStmt p n
- Nothing -> error "invalid label for break"
-stmt lbl (ContinueStmt p (Just (Id _ id))) = case M.lookup id lbl of
- Just n -> Core.ContinueStmt p n
- Nothing -> error "invalid label for break"
-
-stmt _ s = error $ "cannot translate this statement to core syntax:\n" ++
+stmt (IfStmt p e s1 s2) = Core.IfStmt p (expr e) (stmt s1) (stmt s2)
+stmt (WhileStmt p e s) = Core.WhileStmt p (expr e) (stmt s)
+stmt (ForInStmt p (ForInNoVar id) e s) =
+ Core.ForInStmt p (unId id) (expr e) (stmt s)
+stmt (ReturnStmt p maybeE) = Core.ReturnStmt p (liftM expr maybeE)
+stmt (LabelledStmt p id s) = Core.LabelledStmt p (unId id) (stmt s)
+stmt (BreakStmt p (Just id)) = Core.BreakStmt p (unId id)
+stmt (ContinueStmt p (Just id)) = Core.ContinueStmt p (unId id)
+stmt s = error $ "cannot translate this statement to core syntax:\n" ++
(render $ pp s) ++ "\n" ++ show s
field (PropString _ s,e) = (Left s,expr e)
@@ -126,7 +108,7 @@ expr (ObjectLit p fields) = Core.Lit (Core.ObjectLit p $ map field fields)
expr (VarRef p (Id _ v)) = Core.VarRef p v
expr (FuncExpr p args (BlockStmt _ ((VarDeclStmt p' decls):body))) =
Core.FuncExpr p (map unId args) (map unDecl decls)
- (stmt M.empty (BlockStmt p' body))
+ (stmt (BlockStmt p' body))
expr (InfixExpr p op lhs rhs) =
Core.OpExpr p (unInfix op) [expr lhs,expr rhs]
expr (PrefixExpr p op e) = Core.OpExpr p (unPrefix op) [expr e]

0 comments on commit afb834d

Please sign in to comment.