SharedSemantics.hs 11.3 KB
Newer Older
1
{-# LANGUAGE AllowAmbiguousTypes #-}
2
3
4
5
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
6
{-# LANGUAGE FunctionalDependencies #-}
7
8
9
10
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
11
module SharedSemantics where
12

13
import           Prelude hiding (rem,div,id,or,and,fail)
14

15
import           Data.List (find,elemIndex)
16

17
import           Control.Category
18
19

import           Control.Arrow
20
import           Control.Arrow.Environment
Wouter Raateland's avatar
Wouter Raateland committed
21
import           Control.Arrow.Except
22
import           Control.Arrow.Fail
23
import           Control.Arrow.Fix
24
import           Control.Arrow.Reader
Wouter Raateland's avatar
Wouter Raateland committed
25
import qualified Control.Arrow.Utils as U
26
27
28
29

import           Text.Printf
import           Syntax

30
type CanFail ex val c = (ArrowChoice c,ArrowFail (ex val) c,UseException ex val c)
31

32
type CanInterp env envval val ex bool c = (
33
  UseVal val c,
34
  UseBool bool val c,
35
  UseConst c,
36
  UseEnv (env String envval) c,
37
  CanFail ex val c,
38
  ArrowEnv String envval (env String envval) c,
39
40
  ArrowExcept EInvoke (Maybe val) (ex val) c,
  ArrowExcept ([Statement],[CatchClause]) (Maybe val) (ex val) c,
41
42
  ArrowFix [Statement] (Maybe val) c,
  ArrowReader ([Statement],[CatchClause]) c)
43

44
assert :: (CanFail e v c) => c (Bool,String) ()
45
46
assert = proc (prop,msg) -> if prop
  then returnA -< ()
47
  else failStatic -< msg
48

49
justOrFail :: (CanFail e v c) => c (Maybe x,String) x
50
51
justOrFail = proc (x,e) -> case x of
  Just v -> returnA -< v
52
  Nothing -> failStatic -< e
53
54
55
56
57

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
58

59
60
61
getFieldSignatures :: ([Modifier] -> Bool) -> CompilationUnit -> [FieldSignature]
getFieldSignatures p unit =
  [fieldSignature unit m | FieldMember m <- fileBody unit, p (fieldModifiers m)]
62

63
readCompilationUnit :: (CanFail e v c,UseConst c) => c String CompilationUnit
64
readCompilationUnit = proc n -> do
65
  compilationUnits <- askCompilationUnits -< ()
66
  justOrFail -< (find (\u -> fileName u == n) compilationUnits,printf "CompilationUnit %s not loaded" (show n))
67

68
evalInvoke :: CanInterp env envval val ex bool c => c EInvoke (Maybe val)
69
evalInvoke = proc e -> case e of
70
71
72
  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)
73
  StaticInvoke m params -> runMethod -< (Nothing,m,params)
74
  DynamicInvoke{} -> failStatic -< "DynamicInvoke is not implemented"
75

76
evalImmediate :: (ArrowChoice c,UseVal val c) => c Immediate val
77
evalImmediate = proc i -> case i of
78
  Local name -> readVar -< name
79
80
81
82
83
84
85
86
  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

87
evalAtIdentifier :: (ArrowChoice c,UseVal val c) => c AtIdentifier val
88
89
90
91
92
evalAtIdentifier = proc i -> case i of
  ThisRef -> evalImmediate -< Local "@this"
  ParameterRef n -> evalImmediate -< Local ("@parameter" ++ show n)
  CaughtExceptionRef -> evalImmediate -< Local "@caughtexception"

93
evalBool :: (ArrowChoice c,UseBool bool val c,UseVal val c) => c BoolExpr bool
94
95
96
97
98
99
100
101
102
103
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)
104

105
eval :: CanInterp env envval val ex bool c => c Expr val
106
eval = proc e -> case e of
107
  NewExpr t -> do
108
    assert -< (isBaseType t,"Expected a base type for new")
109
110
    newSimple -< t
  NewArrayExpr t i -> do
111
    assert -< (isNonvoidType t,"Expected a nonvoid type for newarray")
112
    v <- evalImmediate -< i
113
    newArray -< (t,[v])
114
  NewMultiArrayExpr t is -> do
115
    assert -< (isBaseType t,"Expected a nonvoid base type for newmultiarray")
116
    vs <- U.map evalImmediate -< is
117
    newArray -< (t,vs)
118
119
  InstanceOfExpr i t -> first evalImmediate >>> instanceOf -< (i,t)
  CastExpr t i -> first evalImmediate >>> (id &&& instanceOf) >>> cast -< (i,t)
120
  InvokeExpr invokeExpr -> do
Wouter Raateland's avatar
Wouter Raateland committed
121
    v <- tryCatch evalInvoke (U.pi2 >>> fail) -< invokeExpr
122
    justOrFail -< (v,"Method returned nothing")
123
124
125
126
  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
127
128
129
  BinopExpr i1 op i2 -> do
    v1 <- evalImmediate -< i1
    v2 <- evalImmediate -< i2
130
    case op of
131
132
133
      And -> and -< (v1,v2)
      Or -> or -< (v1,v2)
      Xor -> xor -< (v1,v2)
134
135
136
137
      Rem -> rem -< (v1,v2)
      Cmp -> cmp -< (v1,v2)
      Cmpg -> cmpg -< (v1,v2)
      Cmpl -> cmpl -< (v1,v2)
138
139
140
      Shl -> shl -< (v1,v2)
      Shr -> shr -< (v1,v2)
      Ushr -> ushr -< (v1,v2)
141
142
143
144
145
      Plus -> plus -< (v1,v2)
      Minus -> minus -< (v1,v2)
      Mult -> mult -< (v1,v2)
      Div -> div -< (v1,v2)
  UnopExpr op i -> do
146
    v <- evalImmediate -< i
147
    case op of
148
      Lengthof -> lengthOf -< v
149
      Neg -> neg -< v
150
  ImmediateExpr i -> evalImmediate -< i
151
  MethodHandle _ -> failStatic -< "Evaluation of method handles is not implemented"
152

153
runStatements :: CanInterp env envval val ex bool c => c [Statement] (Maybe val)
154
runStatements = fix $ \run -> proc stmts -> case stmts of
155
156
  [] -> returnA -< Nothing
  (stmt:rest) -> case stmt of
157
    Label labelName -> do
158
159
      (_,cs) <- ask -< ()
      let clauses = filter (\c -> fromLabel c == labelName && Label (toLabel c) `elem` stmts) cs
160
161
162
163
164
      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
165
166
    Ret i -> liftAMaybe evalImmediate -< i
    Return i -> liftAMaybe evalImmediate -< i
167
    Throw i -> evalImmediate >>> failDynamic -< i
168
169
    Identity l i _ -> first (second evalAtIdentifier) >>> updateVar run -< ((l,i),rest)
    IdentityNoType l i -> first (second evalAtIdentifier) >>> updateVar run -< ((l,i),rest)
170
171
172
    Assign var e -> do
      v <- eval -< e
      case var of
173
        LocalVar l -> updateVar run -< ((l,v),rest)
174
        ReferenceVar ref -> case ref of
175
176
          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)
177
178
          SignatureRef f -> do
            updateStaticField -< (f,v)
179
            run -< rest
180
181
    Invoke e -> do
      evalInvoke -< e
182
183
184
      run -< rest
    Nop -> run -< rest
    Breakpoint -> run -< rest
Wouter Raateland's avatar
Wouter Raateland committed
185
  where
186
    atLabel f = statementsFromLabel >>> f
Wouter Raateland's avatar
Wouter Raateland committed
187
    statementsFromLabel = proc label -> do
188
189
190
      (ss,_) <- ask -< ()
      case Label label `elemIndex` ss of
        Just i -> returnA -< drop i ss
191
192
193
        Nothing -> failStatic -< printf "Undefined label: %s" label
    catchException f = proc ((_,clauses),exception) ->
      catch (handleException f) -< (exception,clauses)
194
195
196
    handleException f = proc (val,clause) ->
      declare (atLabel f) -< (("@caughtexception",val),withLabel clause)
    runSwitch f = first evalImmediate >>> case_ (atLabel f)
197

198
runMethod :: CanInterp env envval val ex bool c => c (Maybe String,MethodSignature,[Immediate]) (Maybe val)
199
200
201
202
203
204
205
206
207
208
209
210
211
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)))
Wouter Raateland's avatar
Wouter Raateland committed
212
  where
213
214
215
216
    askMethod = proc sig@(MethodSignature c _ n _) -> do
      unit <- readCompilationUnit -< c
      case [m | MethodMember m <- fileBody unit, methodSignature unit m == sig] of
        m:_ -> returnA -< m
217
        [] -> failStatic -< printf "Method %s not defined for class %s" (show n) (show c)
218
    askMethodBody = proc m -> case methodBody m of
219
      EmptyBody -> failStatic -< "Cannot run method with empty body"
220
221
      FullBody{declarations=decs,statements=stmts,catchClauses=clauses} ->
        returnA -< (decs,stmts,clauses)
222
223
224
    runWithBindings = proc (bs,(stmts,clauses)) -> case bs of
      [] -> local runStatements -< ((stmts,clauses),stmts)
      (binding:rest) -> declare runWithBindings -< (binding,(rest,(stmts,clauses)))
225

226
runProgram :: CanInterp env envval val ex bool c => c (MethodSignature,[Immediate]) (Maybe val)
227
runProgram = proc (main,params) -> do
228
  units <- askCompilationUnits -< ()
229
230
  U.map (second defaultValue >>> updateStaticField) -< concatMap staticFieldsWithType units
  U.map runMethod -< concatMap clinitMethodWithArgs units
231
  runMethod -< (Nothing,main,params)
232
233
234
235
  where
    staticFieldsWithType u =
      [(fieldSignature u m,fieldType m) | FieldMember m <- fileBody u, Static `elem` fieldModifiers m]
    clinitMethodWithArgs u =
236
      [(Nothing,methodSignature u m,[]) | MethodMember m <- fileBody u, methodName m == "<clinit>"]
237

238
class Arrow c => UseVal v c | c -> v where
239
240
241
242
243
244
245
  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
246
  newSimple :: c Type v
247
  newArray :: c (Type,[v]) v
248
249
250
  and :: c (v,v) v
  or :: c (v,v) v
  xor :: c (v,v) v
251
252
253
254
  rem :: c (v,v) v
  cmp :: c (v,v) v
  cmpg :: c (v,v) v
  cmpl :: c (v,v) v
255
256
257
  shl :: c (v,v) v
  shr :: c (v,v) v
  ushr :: c (v,v) v
258
259
260
261
262
263
  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
264
265
  instanceOf :: c (v,Type) v
  cast :: c ((v,Type),v) v
266
  defaultValue :: c Type v
267
268
  declare :: c x (Maybe v) -> c ((String,v),x) (Maybe v)
  readVar :: c String v
269
  updateVar :: c x (Maybe v) -> c ((String,v),x) (Maybe v)
270
  readIndex :: c (v,v) v
271
  updateIndex :: c x (Maybe v) -> c (((v,v),v),x) (Maybe v)
272
  readField :: c (v,FieldSignature) v
273
  updateField :: c x (Maybe v) -> c ((v,(FieldSignature,v)),x) (Maybe v)
274
  readStaticField :: c FieldSignature v
275
  updateStaticField :: c (FieldSignature,v) ()
276
  case_ :: c String (Maybe v) -> c (v,[CaseStatement]) (Maybe v)
277
278
279
280
281

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]) (Maybe v)
282

283
class Arrow c => UseBool b v c | c -> b v where
284
285
286
287
288
289
  eq :: c (v,v) b
  neq :: c (v,v) b
  gt :: c (v,v) b
  ge :: c (v,v) b
  lt :: c (v,v) b
  le :: c (v,v) b
290
  if_ :: c String (Maybe v) -> c x (Maybe v) -> c ((b,BoolExpr),(String,x)) (Maybe v)
291

292
293
class Arrow c => UseEnv env c | c -> env where
  emptyEnv :: c () env
294
295

class Arrow c => UseConst c where
296
  askCompilationUnits :: c () [CompilationUnit]