Permalink
Browse files

try/switch accounted for in ANF

  • Loading branch information...
1 parent a0bcbd8 commit 2130844b701cc2f39db11189c2d74ff2c36eb3c6 Arjun Guha committed Feb 26, 2009
Showing with 179 additions and 28 deletions.
  1. +81 −3 src/WebBits/JavaScript/Core.hs
  2. +39 −3 src/WebBits/JavaScript/Simplify.hs
  3. +59 −22 src/WebBits/JavaScript/ToCore.hs
@@ -1,6 +1,14 @@
-module WebBits.JavaScript.Core where
+module WebBits.JavaScript.Core
+ ( Id
+ , FOp(..)
+ , Lit(..)
+ , Expr(..)
+ , Stmt(..)
+ , stmtLabel
+ ) where
import Data.Generics
+import Control.Arrow (first,second,(***))
type Id = String
@@ -76,10 +84,80 @@ data Stmt a
| ThrowStmt a (Expr a)
| ReturnStmt a (Maybe (Expr a))
| LabelledStmt a Id (Stmt a)
- | BreakStmt a
- | ContinueStmt a
+ | BreakStmt a Int
+ | ContinueStmt a Int
| SwitchStmt a Id [(Lit a,Stmt a)]
| EnterStmt a
| ExitStmt a
deriving (Show,Data,Typeable,Eq,Ord)
+stmtLabel :: Stmt a -> a
+stmtLabel stmt = case stmt of
+ (SeqStmt a ss) -> a
+ (EmptyStmt a) -> a
+ (AssignStmt a v e) -> a
+ (DeleteStmt a v1 v2) -> a
+ (NewStmt a result constr args) -> a
+ (CallStmt a result fn args) -> a
+ (MethodCallStmt a result obj method args) -> a
+ (IndirectMethodCallStmt a result obj method args) -> a
+ (IfStmt a e s1 s2) -> a
+ (WhileStmt a e s) -> a
+ (ForInStmt a v e s) -> a
+ (TryStmt a s1 v s2 s3) -> a
+ (ReturnStmt a Nothing) -> a
+ (ReturnStmt a (Just e)) -> a
+ (LabelledStmt a v s) -> a
+ (BreakStmt a v) -> a
+ (ContinueStmt a v) -> a
+ (SwitchStmt a v cs) -> a
+ (EnterStmt a) -> a
+ (ExitStmt a) -> a
+
+
+-- Instances
+
+instance Functor Lit where
+ fmap f (StringLit a s) = StringLit (f a) s
+ fmap f (RegexpLit a s g ci) = RegexpLit (f a) s g ci
+ fmap f (NumLit a d) = NumLit (f a) d
+ fmap f (IntLit a n) = IntLit (f a) n
+ fmap f (BoolLit a b) = BoolLit (f a) b
+ fmap f (NullLit a) = NullLit (f a)
+ fmap f (ArrayLit a es) = ArrayLit (f a) (map (fmap f) es)
+ fmap f (ObjectLit a es) = ObjectLit (f a) (map (second (fmap f)) es)
+
+instance Functor Expr where
+ fmap f (Lit l) = Lit (fmap f l)
+ 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 (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)
+
+instance Functor Stmt where
+ fmap f (SeqStmt a ss) = SeqStmt (f a) (map (fmap f) ss)
+ fmap f (EmptyStmt a) = EmptyStmt (f a)
+ fmap f (AssignStmt a v e) = AssignStmt (f a) v (fmap f e)
+ fmap f (DeleteStmt a v1 v2) = DeleteStmt (f a) v1 v2
+ fmap f (NewStmt a result constr args) = NewStmt (f a) result constr args
+ fmap f (CallStmt a result fn args) = CallStmt (f a) result fn args
+ fmap f (MethodCallStmt a result obj method args) =
+ MethodCallStmt (f a) result obj method args
+ fmap f (IndirectMethodCallStmt a result obj method args) =
+ IndirectMethodCallStmt (f a) result obj method args
+ fmap f (IfStmt a e s1 s2) = IfStmt (f a) (fmap f e) (fmap f s1) (fmap f s2)
+ fmap f (WhileStmt a e s) = WhileStmt (f a) (fmap f e) (fmap f s)
+ fmap f (ForInStmt a v e s) = ForInStmt (f a) v (fmap f e) (fmap f s)
+ fmap f (TryStmt a s1 v s2 s3) =
+ TryStmt (f a) (fmap f s1) v (fmap f s2) (fmap f s3)
+ fmap f (ReturnStmt a Nothing) = ReturnStmt (f a) Nothing
+ fmap f (ReturnStmt a (Just e)) = ReturnStmt (f a) (Just (fmap f e))
+ fmap f (LabelledStmt a v s) = LabelledStmt (f a) v (fmap f s)
+ fmap f (BreakStmt a v) = BreakStmt (f a) v
+ fmap f (ContinueStmt a v) = ContinueStmt (f a) v
+ fmap f (SwitchStmt a v cs) =
+ SwitchStmt (f a) v (map (fmap f *** fmap f) cs)
+ fmap f (EnterStmt a) = EnterStmt (f a)
+ fmap f (ExitStmt a) = ExitStmt (f a)
@@ -83,6 +83,7 @@ removeForStmt (ForStmt p init maybeTest maybeIncr body) = stmts where
Just e -> ExprStmt p e
removeForStmt stmt = stmt
+-- TODO: This won't work. A break/continue in the body will fail.
removeDoWhileStmt :: Statement SourcePos -> Statement SourcePos
removeDoWhileStmt (DoWhileStmt p body test) = stmts where
stmts = BlockStmt p [body,WhileStmt p test body]
@@ -146,7 +147,7 @@ newStmtLabel :: State Int (Id SourcePos)
newStmtLabel = do
n <- get
put (n+1)
- return (Id noPos ("+label" ++ show n))
+ return (Id noPos ("__webbitslabel" ++ show n))
-- |If the expression is not a variable-reference, create a name for it.
@@ -332,7 +333,12 @@ purifyStmt labels stmt = case stmt of
s1' <- purifyStmt labels s1
s2' <- purifyStmt labels s2
return (BlockStmt p [BlockStmt p ess,IfStmt p e' s1' s2'])
- SwitchStmt p e cases -> fail "cannot handle switch yet"
+ SwitchStmt p e cases -> do
+ (eStmts,e') <- purifyExpr e
+ l <- newStmtLabel
+ cases' <- mapM (purifyCase ((l,ImplicitSwitchLabel):labels)) cases
+ return $ BlockStmt p [BlockStmt p eStmts,
+ LabelledStmt p l $ SwitchStmt p e' cases']
WhileStmt p e s -> do
(ess,e') <- purifyExpr e
l <- newStmtLabel
@@ -366,7 +372,15 @@ purifyStmt labels stmt = case stmt of
l <- newStmtLabel
body' <- purifyStmt ((l,ImplicitLoopLabel):labels) body
return (BlockStmt p [BlockStmt p exprStmts,ForInStmt p init expr' body'])
- TryStmt p body catches finally -> fail "cannot handle try yet"
+ TryStmt p body catches Nothing -> do
+ body' <- purifyStmt labels body
+ catches' <- mapM (purifyCatch labels) catches
+ return (TryStmt p body' catches' Nothing)
+ TryStmt p body catches (Just finally) -> do
+ body' <- purifyStmt labels body
+ catches' <- mapM (purifyCatch labels) catches
+ finally' <- purifyStmt labels finally
+ return (TryStmt p body' catches' (Just finally'))
ThrowStmt p e -> do
(es,e') <- purifyExpr e
return (BlockStmt p [BlockStmt p es,ThrowStmt p e'])
@@ -393,3 +407,25 @@ purifyDecl decl@(VarDecl p id rhs) = case rhs of
Just expr -> do
(ss,e) <- purifyExpr expr
return (ss,VarDecl p id (Just e))
+
+-- TODO: binding for id?
+purifyCatch labels (CatchClause p id s) = do
+ s' <- purifyStmt labels s
+ return (CatchClause p id s')
+
+
+-- |Assumes that the head of 'labels' is an 'ImplicitSwitchLabel'. After
+-- purification, the list of statements in the body is a single block
+-- statement.
+purifyCase :: [(Id SourcePos,LabelType)]
+ -> CaseClause SourcePos -> State Int (CaseClause SourcePos)
+purifyCase labels (CaseDefault p ss) = do
+ s' <- purifyStmt labels (BlockStmt p ss)
+ return (CaseDefault p [s'])
+purifyCase labels (CaseClause p e ss) = do
+ (es,e') <- purifyExpr e
+ case es of
+ [] -> do s' <- purifyStmt labels (BlockStmt p ss)
+ return (CaseClause p e' [s'])
+ otherwise -> fail $ "semantic error(!!!) at " ++ show p ++ "\n" ++
+ "the case expression should be side-effect free"
@@ -4,14 +4,31 @@ module WebBits.JavaScript.ToCore
) where
import Control.Monad
+import Data.Generics
+import Control.Monad.State.Strict
+import qualified Data.Map as M
+import qualified Data.Foldable as Foldable
+
import WebBits.Common (pp)
import Text.PrettyPrint.HughesPJ (render)
import qualified WebBits.JavaScript.Core as Core
import WebBits.JavaScript
import WebBits.JavaScript.Simplify (simplify)
-jsToCore :: Show a => [Statement a] -> [Core.Stmt a]
-jsToCore (VarDeclStmt{}:stmts) = map stmt stmts
+
+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)
jsToCore stmts = error $ "jsToCore: missing global vars:\n" ++ show stmts
unId (Id _ v) = v
@@ -55,31 +72,50 @@ unPrefix op = case op of
PrefixVoid -> Core.PrefixVoid
otherwise -> error $ "unPrefix cannot translate:\n" ++ show op
-stmt :: Show a => Statement a -> Core.Stmt a
-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)
- CallExpr p (BracketRef _ f m) args ->
- Core.IndirectMethodCallStmt p r (unVar f) (unVar m) (map unVar args)
- CallExpr p f args -> Core.CallStmt p r (unVar f) (map unVar args)
- 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 (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 s = error $ "cannot translate this statement to core syntax:\n" ++
+unlabelled (LabelledStmt _ _ s) = unlabelled s
+unlabelled s = s
+
+getLabel f = case Foldable.find (const True) f of
+ Just a -> a
+ 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)) =
+ case rhs of
+ CallExpr p (DotRef _ f id) args ->
+ Core.MethodCallStmt p r (unVar f) (unId id) (map unVar args)
+ CallExpr p (BracketRef _ f m) args ->
+ Core.IndirectMethodCallStmt p r (unVar f) (unVar m) (map unVar args)
+ CallExpr p f args -> Core.CallStmt p r (unVar f) (map unVar args)
+ 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" ++
(render $ pp s) ++ "\n" ++ show s
field (PropString _ s,e) = (Left s,expr e)
field (PropNum _ n,e) = (Right n,expr e)
field (PropId _ (Id _ s),e) = (Left s,expr e)
-expr :: Show a => Expression a -> Core.Expr a
expr (StringLit p s) = Core.Lit (Core.StringLit p s)
expr (RegexpLit p s b0 b1) = Core.Lit (Core.RegexpLit p s b0 b1)
expr (NumLit p x) = Core.Lit (Core.NumLit p x)
@@ -89,7 +125,8 @@ expr (ArrayLit p es) = Core.Lit (Core.ArrayLit p (map expr es))
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 (BlockStmt p' body))
+ Core.FuncExpr p (map unId args) (map unDecl decls)
+ (stmt M.empty (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 2130844

Please sign in to comment.