Verified Commit bc1b0b6f authored by Sven Keidel's avatar Sven Keidel
Browse files

jimple: fix generic interpreter

parent cc365f16
name: sturdy-jimple
version: 0.1.0.0
license: BSD3
license-file: LICENSE
author: Wouter Raateland
maintainer: Sven Keidel <svenkeidel@gmail.com>
category: Language
dependencies:
- base
- containers
- unordered-containers
- hashable
- logfloat
- mtl
- random
- sturdy-lib
- text
- vector
- vector-instances
library:
source-dirs:
- src
ghc-options: -Wall
tests:
spec:
main: Spec.hs
source-dirs:
- test
ghc-options: -Wall
dependencies:
- sturdy-pcf
- hspec
{ pkgs ? import <nixpkgs> {} }:
let
haskellPackagesWithProfiling = pkgs.haskellPackages.override {
overrides = self: super: {
mkDerivation = args: super.mkDerivation (args // {
enableLibraryProfiling = false;
});
};
};
hsEnv = haskellPackagesWithProfiling.ghcWithPackages(p: with p; [
Cabal cabal-install hlint text containers hspec mtl numeric-limits criterion fgl
(p.callPackage ../lib/default.nix { })
]);
in pkgs.stdenv.mkDerivation {
name = "sturdy-jimple";
version = "0.0.1";
src = ./.;
buildInputs = [
hsEnv
];
}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module GenericInterpreter where
import Prelude hiding (rem,mod,div,id,or,and,fail,return,map)
import Data.Text (Text)
import Data.Vector (Vector,(!?))
import qualified Data.Vector as Vec
import Data.Int
import Data.IntMap (IntMap)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as Map
import Control.Category
import Control.Arrow
import Control.Arrow.Environment as Env
import Control.Arrow.Frame as Frame
import Control.Arrow.Except as Except
import Control.Arrow.Fail
import Control.Arrow.Fix (ArrowFix(..))
import Control.Arrow.Utils (map)
import GHC.Exts
import Syntax
data Frame val =
Frame
{ this :: val
, params :: Vector val
, locals :: HashMap Text val
, stmts :: Vector Statement
, handlers :: HashMap ClassId CatchClause
, caughtException :: Maybe val
}
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
)
eval :: ArrowInterp val e c => StmtInterpreter c -> c Expr val
eval run' = proc expr -> case expr of
New typ -> new -< typ
NewArray typ e -> do
len <- evalImmediate -< e
newArray -< (typ,[len])
NewMultiArray typ es -> do
lens <- map evalImmediate -< es
newArray -< (typ,lens)
Cast typ e -> do
val <- evalImmediate -< e
cast -< (typ,val)
InstanceOf e typ -> do
val <- evalImmediate -< e
instanceOf -< (val,typ)
InvokeExpr method ->
evalInvoke run' -< method
Ref ref -> lookup' -< ReferenceVar ref
Binop e1 op e2 -> do
v1 <- evalImmediate -< e1
v2 <- evalImmediate -< e2
case op of
And -> and -< (v1,v2)
Or -> or -< (v1,v2)
Xor -> xor -< (v1,v2)
Rem -> rem -< (v1,v2)
Mod -> mod -< (v1,v2)
Cmp -> cmp -< (v1,v2)
Cmpl -> cmpl -< (v1,v2)
Cmpg -> cmpg -< (v1,v2)
Shl -> shl -< (v1,v2)
Shr -> shr -< (v1,v2)
Ushr -> ushr -< (v1,v2)
Plus -> plus -< (v1,v2)
Minus -> minus -< (v1,v2)
Mult -> mult -< (v1,v2)
Div -> div -< (v1,v2)
Unop op e -> do
v <- evalImmediate -< e
case op of
Lengthof -> lengthOf -< v
Neg -> neg -< v
Immediate e -> evalImmediate -< e
MethodHandle {} -> fail -< "Unsupported operation: MethodHandle"
{-# INLINE eval #-}
evalImmediate :: ArrowInterp val e c => c Immediate val
evalImmediate = proc i -> case i of
Local name -> lookup' -< LocalVar name
DoubleConstant f -> doubleConstant -< f
FloatConstant f -> floatConstant -< f
IntConstant n -> intConstant -< n
LongConstant f -> longConstant -< f
NullConstant -> nullConstant -< ()
StringConstant s -> stringConstant -< s
ClassConstant c -> classConstant -< c
{-# INLINE evalImmediate #-}
evalInvoke :: ArrowInterp val e c => StmtInterpreter c -> c Invoke val
evalInvoke run' = proc e -> case e of
InvokeVirtual obj klass methodSig args -> do
receiver <- lookup' -< obj
invoke -< (receiver,klass,methodSig,args)
InvokeSpecial obj klass methodSig args -> do
receiver <- lookup' -< obj
invoke -< (receiver,klass,methodSig,args)
InvokeInterface obj klass methodSig args -> do
receiver <- lookup' -< obj
invoke -< (receiver,klass,methodSig,args)
InvokeStatic klass methodSig args -> do
receiver <- lookup' -< StaticInstance klass
invoke -< (receiver,klass,methodSig,args)
-- InvokeDynamic {} -> fail -< "We currently do not support dynamic method lookup"
where
invoke = proc (receiver,klass,methodSig,args) -> do
argVals <- map evalImmediate -< args
lookupMethod (proc (receiver,body,argVals) -> do
let frame = Frame { this = receiver
, params = Vec.fromList argVals
, locals = Map.empty
, stmts = statements body
, handlers = catchClauses body
, caughtException = Nothing
}
newFrame (handleReturn run') -< (frame,0)
) -< (receiver,klass,methodSig,argVals)
{-# INLINE invoke #-}
{-# INLINE evalInvoke #-}
run :: ArrowInterp val e c => StmtInterpreter c
run = fix $ \run' -> handleExceptions $ proc pc -> do
let nextStmt = pc + 1
frame <- askFrame -< ()
case stmts frame !? pc of
Nothing -> returnA -< ()
Just stmt -> case stmt of
Goto lab -> run' -< lab
Label {} -> run' -< nextStmt
If e lab -> do
condition <- eval run' -< e
if_ run' run' -< (condition,(lab,nextStmt))
TableSwitch key offset cases def -> do
val <- evalImmediate -< key
tableswitch run' -< (val,offset,cases,def)
LookupSwitch key cases def -> do
val <- evalImmediate -< key
lookupswitch run' -< (val,cases,def)
Identity var ident _maybeTyp -> do
val <- lookup' -< ident
extend run' -< (LocalVar var,val,nextStmt)
Assign var e -> do
val <- eval run' -< e
extend run' -< (var,val,nextStmt)
InvokeStmt invoke -> do
evalInvoke run' -< invoke
run' -< nextStmt
Return Nothing -> returnA -< ()
Return (Just e) -> return <<< evalImmediate -< e
Throw e -> throw <<< evalImmediate -< e
Nop -> run' -< nextStmt
Breakpoint {} -> run' -< nextStmt
-- Unsupported Operations
Ret {} -> fail -< "JVM subroutines are not supported"
EnterMonitor {} -> fail -< "JVM monitor statements are not supported"
ExitMonitor {} -> fail -< "JVM monitor statements are not supported"
{-# INLINE run #-}
handleExceptions :: ArrowInterp val e c => StmtInterpreter c -> StmtInterpreter 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
-- | Interface for value operations.
class IsVal v c | c -> v where
-- | In case of the abstract interpreter allows to join the result
-- of an @if@ statement.
type family JoinVal x (c :: * -> * -> *) :: Constraint
if_ :: JoinVal z c => c x z -> c y z -> c (v, (x, y)) z
tableswitch :: JoinVal y c => c x y -> c (v, Int, Vector Label, Label) y
lookupswitch :: JoinVal y c => c x y -> c (v, IntMap Label, Label) y
lookupMethod :: JoinVal y c => c (v,MethodBody,x) y -> c (v,ClassId,MethodSignature,x) y
matchException :: JoinVal y c => c (v,CatchClause) y -> c (v,PC,HashMap ClassId CatchClause) y
new :: c Type v
newArray :: c (Type,[v]) 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
and :: c (v,v) v
or :: c (v,v) v
xor :: c (v,v) v
rem :: c (v,v) v
mod :: c (v,v) v
cmp :: c (v,v) v
cmpg :: c (v,v) v
cmpl :: c (v,v) v
shl :: c (v,v) v
shr :: c (v,v) v
ushr :: c (v,v) v
plus :: c (v,v) v
minus :: c (v,v) v
mult :: c (v,v) v
lengthOf :: c v v
div :: c (v,v) v
neg :: c v v
cast :: c (Type,v) v
instanceOf :: c (v,Type) v
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module SharedSemantics where
import Prelude hiding (rem,div,id,or,and,fail)
import Data.List (find,elemIndex)
import Control.Category
import Control.Arrow
import Control.Arrow.Environment
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Reader
import qualified Control.Arrow.Utils as U
import Text.Printf
import Syntax
type CanFail ex val c = (ArrowChoice c,ArrowFail (ex val) c,UseException ex val c)
type CanInterp env envval val ex bool c = (
UseVal val c,
UseBool bool val c,
UseConst c,
UseEnv (env String envval) c,
CanFail ex val c,
ArrowEnv String envval (env String envval) c,
ArrowExcept EInvoke (Maybe val) (ex val) c,
ArrowExcept ([Statement],[CatchClause]) (Maybe val) (ex val) c,
ArrowFix [Statement] (Maybe val) c,
ArrowReader ([Statement],[CatchClause]) c)
assert :: (CanFail e v c) => c (Bool,String) ()
assert = proc (prop,msg) -> if prop
then returnA -< ()
else failStatic -< msg
justOrFail :: (CanFail e v c) => c (Maybe x,String) x
justOrFail = proc (x,e) -> case x of
Just v -> returnA -< v
Nothing -> failStatic -< e
liftAMaybe :: ArrowChoice c => c x z -> c (Maybe x) (Maybe z)
liftAMaybe f = proc m -> case m of
Just x -> f >>^ Just -< x
Nothing -> returnA -< Nothing
getFieldSignatures :: ([Modifier] -> Bool) -> CompilationUnit -> [FieldSignature]
getFieldSignatures p unit =
[fieldSignature unit m | FieldMember m <- fileBody unit, p (fieldModifiers m)]
readCompilationUnit :: (CanFail e v c,UseConst c) => c String CompilationUnit
readCompilationUnit = proc n -> do
compilationUnits <- askCompilationUnits -< ()
justOrFail -< (find (\u -> fileName u == n) compilationUnits,printf "CompilationUnit %s not loaded" (show n))
evalInvoke :: CanInterp env envval val ex bool c => c EInvoke (Maybe val)
evalInvoke = proc e -> case e of
SpecialInvoke this m params -> runMethod -< (Just this,m,params)
VirtualInvoke this m params -> runMethod -< (Just this,m,params)
InterfaceInvoke this m params -> runMethod -< (Just this,m,params)
StaticInvoke m params -> runMethod -< (Nothing,m,params)
DynamicInvoke{} -> failStatic -< "DynamicInvoke is not implemented"
evalImmediate :: (ArrowChoice c,UseVal val c) => c Immediate val
evalImmediate = proc i -> case i of
Local name -> readVar -< name
DoubleConstant f -> doubleConstant -< f
FloatConstant f -> floatConstant -< f
IntConstant n -> intConstant -< n
LongConstant f -> longConstant -< f
NullConstant -> nullConstant -< ()
StringConstant s -> stringConstant -< s
ClassConstant c -> classConstant -< c
evalAtIdentifier :: (ArrowChoice c,UseVal val c) => c AtIdentifier val
evalAtIdentifier = proc i -> case i of
ThisRef -> evalImmediate -< Local "@this"
ParameterRef n -> evalImmediate -< Local ("@parameter" ++ show n)
CaughtExceptionRef -> evalImmediate -< Local "@caughtexception"
evalBool :: (ArrowChoice c,UseBool bool val c,UseVal val c) => c BoolExpr bool
evalBool = proc (BoolExpr i1 op i2) -> do
v1 <- evalImmediate -< i1
v2 <- evalImmediate -< i2
case op of
Cmpeq -> eq -< (v1,v2)
Cmpne -> neq -< (v1,v2)
Cmpgt -> gt -< (v1,v2)
Cmpge -> ge -< (v1,v2)
Cmplt -> lt -< (v1,v2)
Cmple -> le -< (v1,v2)
eval :: CanInterp env envval val ex bool c => c Expr val
eval = proc e -> case e of
NewExpr t -> do
assert -< (isBaseType t,"Expected a base type for new")
newSimple -< t
NewArrayExpr t i -> do
assert -< (isNonvoidType t,"Expected a nonvoid type for newarray")
v <- evalImmediate -< i
newArray -< (t,[v])
NewMultiArrayExpr t is -> do
assert -< (isBaseType t,"Expected a nonvoid base type for newmultiarray")
vs <- U.map evalImmediate -< is
newArray -< (t,vs)
InstanceOfExpr i t -> first evalImmediate >>> instanceOf -< (i,t)
CastExpr t i -> first evalImmediate >>> (id &&& instanceOf) >>> cast -< (i,t)
InvokeExpr invokeExpr -> do
v <- tryCatch evalInvoke (U.pi2 >>> fail) -< invokeExpr
justOrFail -< (v,"Method returned nothing")
RefExpr refExpr -> case refExpr of
ArrayRef l i -> (readVar *** evalImmediate) >>> readIndex -< (l,i)
FieldRef l f -> first readVar >>> readField -< (l,f)
SignatureRef f -> readStaticField -< f
BinopExpr i1 op i2 -> do
v1 <- evalImmediate -< i1
v2 <- evalImmediate -< i2
case op of
And -> and -< (v1,v2)
Or -> or -< (v1,v2)
Xor -> xor -< (v1,v2)
Rem -> rem -< (v1,v2)
Cmp -> cmp -< (v1,v2)
Cmpg -> cmpg -< (v1,v2)
Cmpl -> cmpl -< (v1,v2)
Shl -> shl -< (v1,v2)
Shr -> shr -< (v1,v2)
Ushr -> ushr -< (v1,v2)
Plus -> plus -< (v1,v2)
Minus -> minus -< (v1,v2)
Mult -> mult -< (v1,v2)
Div -> div -< (v1,v2)
UnopExpr op i -> do
v <- evalImmediate -< i
case op of
Lengthof -> lengthOf -< v
Neg -> neg -< v
ImmediateExpr i -> evalImmediate -< i
MethodHandle _ -> failStatic -< "Evaluation of method handles is not implemented"
runStatements :: CanInterp env envval val ex bool c => c [Statement] (Maybe val)
runStatements = fix $ \run -> proc stmts -> case stmts of
[] -> returnA -< Nothing
(stmt:rest) -> case stmt of
Label labelName -> do
(_,cs) <- ask -< ()
let clauses = filter (\c -> fromLabel c == labelName && Label (toLabel c) `elem` stmts) cs
tryCatch (U.pi1 >>> run) (catchException run) -< (rest,clauses)
Tableswitch i cases -> runSwitch run -< (i,cases)
Lookupswitch i cases -> runSwitch run -< (i,cases)
If e label -> first (evalBool &&& id) >>> if_ (atLabel run) run -< (e,(label,rest))
Goto label -> (atLabel run) -< label
Ret i -> liftAMaybe evalImmediate -< i
Return i -> liftAMaybe evalImmediate -< i
Throw i -> evalImmediate >>> failDynamic -< i
Identity l i _ -> first (second evalAtIdentifier) >>> updateVar run -< ((l,i),rest)
IdentityNoType l i -> first (second evalAtIdentifier) >>> updateVar run -< ((l,i),rest)
Assign var e -> do
v <- eval -< e
case var of
LocalVar l -> updateVar run -< ((l,v),rest)
ReferenceVar ref -> case ref of
ArrayRef l i -> first (first (readVar *** evalImmediate)) >>> updateIndex run -< (((l,i),v),rest)
FieldRef l f -> first (first readVar) >>> updateField run -< ((l,(f,v)),rest)
SignatureRef f -> do
updateStaticField -< (f,v)
run -< rest
Invoke e -> do
evalInvoke -< e
run -< rest
Nop -> run -< rest
Breakpoint -> run -< rest
where
atLabel f = statementsFromLabel >>> f
statementsFromLabel = proc label -> do
(ss,_) <- ask -< ()
case Label label `elemIndex` ss of
Just i -> returnA -< drop i ss
Nothing -> failStatic -< printf "Undefined label: %s" label
catchException f = proc ((_,clauses),exception) ->
catch (handleException f) -< (exception,clauses)
handleException f = proc (val,clause) ->
declare (atLabel f) -< (("@caughtexception",val),withLabel clause)
runSwitch f = first evalImmediate >>> case_ (atLabel f)
runMethod :: CanInterp env envval val ex bool c => c (Maybe String,MethodSignature,[Immediate]) (Maybe val)
runMethod = proc (this,sig,params) -> do
method <- askMethod -< sig
(decs,stmts,clauses) <- askMethodBody -< method
thisVal <- liftAMaybe readVar -< this
case this of
Just _ -> assert -< (Static `notElem` methodModifiers method,"Expected a non-static method for non-static invoke")
Nothing -> assert -< (Static `elem` methodModifiers method,"Expected a static method for static invoke")
let thisBinding = maybe [] (\x -> [("@this",x)]) thisVal
paramVals <- U.map evalImmediate -< params
let paramBindings = zip (map (\i -> "@parameter" ++ show i) [(0 :: Int)..]) paramVals
decBindings <- U.map (second defaultValue) -< concatMap (\(t,d) -> zip d (repeat t)) decs
env <- emptyEnv -< ()
localEnv runWithBindings -< (env,(thisBinding ++ paramBindings ++ decBindings,(stmts,clauses)))
where
askMethod = proc sig@(MethodSignature c _ n _) -> do
unit <- readCompilationUnit -< c
case [m | MethodMember m <- fileBody unit, methodSignature unit m == sig] of
m:_ -> returnA -< m
[] -> failStatic -< printf "Method %s not defined for class %s" (show n) (show c)
askMethodBody = proc m -> case methodBody m of
EmptyBody -> failStatic -< "Cannot run method with empty body"
FullBody{declarations=decs,statements=stmts,catchClauses=clauses} ->
returnA -< (decs,stmts,clauses)
runWithBindings = proc (bs,(stmts,clauses)) -> case bs of
[] -> local runStatements -< ((stmts,clauses),stmts)
(binding:rest) -> declare runWithBindings -< (binding,(rest,(stmts,clauses)))
runProgram :: CanInterp env envval val ex bool c => c (MethodSignature,[Immediate]) (Maybe val)
runProgram = proc (main,params) -> do
units <- askCompilationUnits -< ()
U.map (second defaultValue >>> updateStaticField) -< concatMap staticFieldsWithType units
U.map runMethod -< concatMap clinitMethodWithArgs units
runMethod -< (Nothing,main,params)
where
staticFieldsWithType u =
[(fieldSignature u m,fieldType m) | FieldMember m <- fileBody u, Static `elem` fieldModifiers m]
clinitMethodWithArgs u =
[(Nothing,methodSignature u m,[]) | MethodMember m <- fileBody u, methodName m == "<clinit>"]
class Arrow c => UseVal v c | c -> v where
doubleConstant :: c Float v
floatConstant :: c Float v
intConstant :: c Int v
longConstant :: c Int v
nullConstant :: c () v
stringConstant :: c String v
classConstant :: c String v
newSimple :: c Type v
newArray :: c (Type,[v]) v
and :: c (v,v) v
or :: c (v,v) v
xor :: c (v,v) v
rem :: c (v,v) v
cmp :: c (v,v) v
cmpg :: c (v,v) v
cmpl :: c (v,v) v
shl :: c (v,v) v
shr :: c (v,v) v
ushr :: c (v,v) v
plus :: c (v,v) v
minus :: c (v,v) v
mult :: c (v,v) v
div :: c (v,v) v
lengthOf :: c v v
neg :: c v v
instanceOf :: c (v,Type) v
cast :: c ((v,Type),v) v
defaultValue :: c Type v
declare :: c x (Maybe v) -> c ((String,v),x) (Maybe v)
readVar :: c String v
updateVar :: c x (Maybe v) -> c ((String,v),x) (Maybe v)
readIndex :: c (v,v) v
updateIndex :: c x (Maybe v) -> c (((v,v),v),x) (Maybe v)
readField :: c (v,FieldSignature) v
updateField :: c x (Maybe v) -> c ((v,(FieldSignature,v)),x) (Maybe v)
readStaticField :: c FieldSignature v
updateStaticField :: c (FieldSignature,v) ()
case_ :: c String (Maybe v) -> c (v,[CaseStatement]) (Maybe v)
class (ArrowChoice c,ArrowFail (e v) c) => UseException e v c | c -> e v where
failStatic :: c String a
failDynamic :: c v a
catch :: c (v,CatchClause) (Maybe v) -> c (e v,[CatchClause]) (