Commit f2d9ef9f authored by Sven Keidel's avatar Sven Keidel

jimple: start work on concrete interpreter

parent 18f5b760
Pipeline #30306 failed with stages
in 46 minutes and 45 seconds
......@@ -12,6 +12,7 @@ dependencies:
- unordered-containers
- hashable
- logfloat
- profunctors
- mtl
- random
- sturdy-lib
......
This diff is collapsed.
This diff is collapsed.
......@@ -33,31 +33,34 @@ import Control.Arrow.Utils (map)
import GHC.Exts
import Syntax
import Text.Printf
data Frame val =
data Frame addr =
Frame
{ this :: val
, params :: Vector val
, locals :: HashMap Text val
{ this :: addr
, params :: Vector addr
, locals :: HashMap Text addr
, stmts :: Vector Statement
, handlers :: HashMap ClassId CatchClause
, caughtException :: Maybe val
, caughtException :: Maybe addr
}
type PC = Int
type StmtInterpreter c = c PC ()
type ArrowInterp val e c =
( IsString e, IsVal val c
, ArrowChoice c, ArrowReturn val c
, ArrowFrame (Frame val) c, ArrowEnv Variable val c
, ArrowExcept val c, ArrowFail e c
, ArrowFix (StmtInterpreter c)
, JoinVal () c, JoinVal val c, Env.Join val c, Except.Join () c
type StmtInterpreter val c = c PC val
type ArrowInterp addr val err c =
( IsString err, IsVal val c
, ArrowChoice c
, ArrowFrame (Frame addr) c
, ArrowEnv Variable val c
, ArrowExcept val c
, ArrowFail err c
, ArrowFix (StmtInterpreter val c)
, JoinVal () c, JoinVal val c, Env.Join val c, Except.Join val c
)
eval :: ArrowInterp val e c => StmtInterpreter c -> c Expr val
eval :: ArrowInterp addr val err c => StmtInterpreter val c -> c Expr val
eval run' = proc expr -> case expr of
New typ -> new -< typ
NewArray typ e -> do
......@@ -103,7 +106,7 @@ eval run' = proc expr -> case expr of
MethodHandle {} -> fail -< "Unsupported operation: MethodHandle"
{-# INLINE eval #-}
evalImmediate :: ArrowInterp val e c => c Immediate val
evalImmediate :: ArrowInterp addr val err c => c Immediate val
evalImmediate = proc i -> case i of
Local name -> lookup' -< LocalVar name
DoubleConstant f -> doubleConstant -< f
......@@ -112,10 +115,10 @@ evalImmediate = proc i -> case i of
LongConstant f -> longConstant -< f
NullConstant -> nullConstant -< ()
StringConstant s -> stringConstant -< s
ClassConstant c -> classConstant -< c
ClassConstant c -> fail -< "Unsupported operation: ClassConstant"
{-# INLINE evalImmediate #-}
evalInvoke :: ArrowInterp val e c => StmtInterpreter c -> c Invoke val
evalInvoke :: ArrowInterp addr val err c => StmtInterpreter val c -> c Invoke val
evalInvoke run' = proc e -> case e of
InvokeVirtual obj klass methodSig args -> do
receiver <- lookup' -< obj
......@@ -141,18 +144,18 @@ evalInvoke run' = proc e -> case e of
, handlers = catchClauses body
, caughtException = Nothing
}
newFrame (handleReturn run') -< (frame,0)
newFrame run' -< (frame,0)
) -< (receiver,klass,methodSig,argVals)
{-# INLINE invoke #-}
{-# INLINE evalInvoke #-}
run :: ArrowInterp val e c => StmtInterpreter c
run :: ArrowInterp addr val err c => StmtInterpreter val c
run = fix $ \run' -> handleExceptions $ proc pc -> do
let nextStmt = pc + 1
frame <- askFrame -< ()
case stmts frame !? pc of
Nothing -> returnA -< ()
Nothing -> failString -< printf "PC out of range: PC=%d, #instr=%d" pc (Vec.length (stmts frame))
Just stmt -> case stmt of
Goto lab -> run' -< lab
Label {} -> run' -< nextStmt
......@@ -174,8 +177,8 @@ run = fix $ \run' -> handleExceptions $ proc pc -> do
InvokeStmt invoke -> do
evalInvoke run' -< invoke
run' -< nextStmt
Return Nothing -> returnA -< ()
Return (Just e) -> return <<< evalImmediate -< e
Return Nothing -> void -< ()
Return (Just e) -> evalImmediate -< e
Throw e -> throw <<< evalImmediate -< e
Nop -> run' -< nextStmt
Breakpoint {} -> run' -< nextStmt
......@@ -186,15 +189,15 @@ run = fix $ \run' -> handleExceptions $ proc pc -> do
ExitMonitor {} -> fail -< "JVM monitor statements are not supported"
{-# INLINE run #-}
handleExceptions :: ArrowInterp val e c => StmtInterpreter c -> StmtInterpreter c
handleExceptions :: ArrowInterp addr val err c => StmtInterpreter val c -> StmtInterpreter val c
handleExceptions run' = catch run' $ proc (pc,exc) -> do
frame <- askFrame -< ()
matchException (proc (exc,handler) -> Env.extend run' -< (CaughtException,exc,withLabel handler)) -< (exc,pc,handlers frame)
{-# INLINE handleExceptions #-}
class ArrowReturn v c where
return :: c v x
handleReturn :: c x y -> c x v
-- class ArrowReturn v c where
-- return :: c v x
-- handleReturn :: c x y -> c x v
-- | Interface for value operations.
class IsVal v c | c -> v where
......@@ -208,13 +211,14 @@ class IsVal v c | c -> v where
matchException :: JoinVal y c => c (v,CatchClause) y -> c (v,PC,HashMap ClassId CatchClause) y
new :: c Type v
newArray :: c (Type,[v]) v
void :: c () v
doubleConstant :: c Double v
floatConstant :: c Float v
intConstant :: c Int32 v
longConstant :: c Int64 v
nullConstant :: c () v
stringConstant :: c Text v
classConstant :: c Text v
-- classConstant :: c Text v
and :: c (v,v) v
or :: c (v,v) v
xor :: c (v,v) v
......
......@@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: 683be31214f2b83403a0b2eddd3a28777bcd124ce83864dfbda0e2595288614d
-- hash: 91e00a073e975c0eb74fa8700e7e75c901cb57428c57daf92c4603dc4919d1a4
name: sturdy-jimple
version: 0.1.0.0
......@@ -17,7 +17,7 @@ build-type: Simple
library
exposed-modules:
ConcreteSemantics
ConcreteInterpreter
Data.Abstract.Exception
Data.Concrete.Exception
GenericInterpreter
......@@ -35,6 +35,7 @@ library
, hashable
, logfloat
, mtl
, profunctors
, random
, sturdy-lib
, text
......@@ -76,6 +77,7 @@ test-suite spec
, hspec
, logfloat
, mtl
, profunctors
, random
, sturdy-lib
, sturdy-pcf
......
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FunctionalDependencies #-}
module Control.Arrow.Frame where
import Control.Arrow
import Control.Arrow.Trans
import Data.Profunctor
class (Arrow c, Profunctor c) => ArrowFrame frame c | c -> frame where
newFrame :: c x y -> c (frame,x) y
askFrame :: c () frame
newFrame :: c x y -> c (frame,x) y
default askFrame :: (c ~ t c', ArrowLift t, ArrowFrame frame c') => c () frame
askFrame = lift' askFrame
{-# INLINE askFrame #-}
......@@ -17,6 +17,7 @@ import Control.Arrow
import Control.Arrow.Cont
import Control.Arrow.Const
import Control.Arrow.Transformer.Reader
import Control.Arrow.Frame
import Control.Arrow.Reader as Reader
import Control.Arrow.State
import Control.Arrow.Store
......@@ -55,6 +56,10 @@ runEnvT' :: (IsList env, Item env ~ (var,val), Profunctor c) => EnvT env c x y -
runEnvT' f = lmap (first fromList) (runEnvT f)
{-# INLINE runEnvT' #-}
instance (Arrow c, Profunctor c) => ArrowFrame env (EnvT env c) where
newFrame (EnvT f) = EnvT $ Reader.local f
askFrame = EnvT Reader.ask
instance (Identifiable var, UpperBounded val, ArrowChoice c, Profunctor c) => ArrowEnv var val (EnvT (SM.Map var val) c) where
type Join y (EnvT (SM.Map var val) c) = ArrowComplete y c
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
......
......@@ -19,6 +19,7 @@ import Control.Arrow.Closure as Closure
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Frame
import Control.Arrow.Reader as Reader
import Control.Arrow.State
import Control.Arrow.Store
......@@ -40,6 +41,10 @@ newtype EnvT env c x y = EnvT (ReaderT env c x y)
ArrowFail e,ArrowExcept e,ArrowState s,ArrowConst r,
ArrowStore var' val', ArrowRun)
instance (Arrow c, Profunctor c) => ArrowFrame env (EnvT env c) where
newFrame (EnvT f) = EnvT $ Reader.local f
askFrame = EnvT Reader.ask
instance (Identifiable var, ArrowChoice c, Profunctor c) => ArrowEnv var val (EnvT (HashMap var val) c) where
type Join y (EnvT (HashMap var val) c) = ()
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
......
......@@ -26,6 +26,7 @@ import Control.Arrow.Fix.Cache
import Control.Arrow.Fix.Chaotic
import Control.Arrow.Fix.Context
import Control.Arrow.Fix.Stack
import Control.Arrow.Frame
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Reader
......@@ -43,7 +44,7 @@ import Data.Coerce
newtype ConstT r c x y = ConstT (StaticT ((->) r) c x y)
deriving (Category,Profunctor,Arrow,ArrowChoice,ArrowLowerBounded,ArrowLift,ArrowJoin,ArrowPrimitive,
ArrowState s,ArrowReader r',ArrowWriter w, ArrowLetRec var val,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore var val,
ArrowFrame frame, ArrowEnv var val, ArrowClosure expr cls, ArrowStore var val,
ArrowFail e, ArrowExcept e,
ArrowContext ctx, ArrowStack a, ArrowCache a b, ArrowChaotic a)
......
......@@ -18,6 +18,7 @@ import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
import Control.Arrow.Except as Exc
import Control.Arrow.Fail
import Control.Arrow.Frame
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Reader as Reader
......@@ -148,6 +149,11 @@ instance (Applicative f, ArrowLetRec var val c) => ArrowLetRec var val (StaticT
{-# INLINE letRec #-}
{-# SPECIALIZE instance ArrowLetRec var val c => ArrowLetRec var val (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowFrame frame c) => ArrowFrame frame (StaticT f c) where
newFrame (StaticT f) = StaticT $ newFrame <$> f
{-# INLINE newFrame #-}
{-# SPECIALIZE instance ArrowFrame frame c => ArrowFrame frame (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowStore var val c) => ArrowStore var val (StaticT f c) where
type Join y (StaticT f c) = Store.Join y c
read (StaticT f) (StaticT g) = StaticT $ Store.read <$> f <*> g
......
......@@ -28,6 +28,7 @@ import Control.Arrow.Cont
import Control.Arrow.Const
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Frame
import Control.Arrow.Trans
import Control.Arrow.Order
import Control.Arrow.Environment
......@@ -41,7 +42,7 @@ import Data.Coerce
newtype ValueT val c x y = ValueT { runValueT :: c x y }
deriving (Profunctor,Category,Arrow,ArrowChoice, ArrowConst r,
ArrowEnv var val', ArrowLetRec var val', ArrowStore addr val',
ArrowFrame frame, ArrowEnv var val', ArrowLetRec var val', ArrowStore addr val',
ArrowExcept exc,ArrowFail e,
ArrowLowerBounded, ArrowReader r, ArrowState s, ArrowCont)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment