Source

olfend / vm.ml

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
open Spotlib.Spot
open Sexplib.Conv
module Sexp = Sexplib.Sexp (* open Sexplib causes some name space confusion *)
open Opcode

(** Abstracted environment.
    The content type, Value.t, is defined later, so defined as parameterized.
 *)
module VMEnv0: sig
  type 'elt t with sexp
  val get : ('elt -> Sexp.t) (* debugging *) -> 'elt t -> (int * Ident.t) -> 'elt
  (** access by address *)
  val push : 'elt t -> Ident.t -> 'elt -> 'elt t
  (** extend t. The new binding comes at 0. The existing bindings are shifted *)
  val pop : 'elt t -> ((Ident.t * 'elt) * 'elt t) option
  val empty : 'elt t
  val of_list : (Ident.t * 'elt) list -> 'elt t
end = struct
  type 'elt t = (Ident.t * 'elt) list with sexp (* CR jfuruse: slow implementation *)
  let get sexp_of_elt env (pos, ident) = 
    let (ident', value) = 
      try List.nth env pos with Failure _ ->
        Format.eprintf "VMEnv lookup by name: %d %a overran the stack %a@." pos Ident.format ident Sexp.pp_hum (sexp_of_t sexp_of_elt env);
        assert false;
    in (* CR jfuruse: slow! *)
    if ident <> ident' then begin
      Format.eprintf "VMEnv lookup by a wrong name: %d %a (actually %a)@ %a@." pos Ident.format ident Ident.format ident' Sexp.pp_hum (sexp_of_t sexp_of_elt env);
      assert false;
    end;
    value
  let push env ident value = (ident, value) :: env
  let pop = function
    | [] -> None
    | x::xs -> Some (x,xs)
  let empty = []
  let of_list id_elts = id_elts
end

(** values *)
module Value = struct

  type t =
    | Const of Const.t

    | Clos of (** zero/partially applied prims *)
        Label.t       (** code *)
        * Ident.t list (** waiting arg names *)
        * env         (** freevars+applied args *)

    | Fix of (** zero/partially applied prims *)
        Ident.t
        * Label.t     (** code *)
        * Ident.t list (** initial waiting *)
        * env         (** initial env *)

    | Frame of (** return information from function call *)
        int (** return adrs *)
        * env       (** return environment *)

    | Block of Tag.t * t list

  and env = t VMEnv0.t with sexp
  (** CR jfuruse: slow! *)

  let rec short_sexp_of_t = 
    let open Sexp in
    function
    | Const c -> Const.sexp_of_t c
    | Clos (l, idents, _env) ->
        List [ Atom "Clos";
               Label.sexp_of_t l;
               List (List.map Ident.sexp_of_t idents);
               Atom "..." ]
    | Fix (id, l, idents, _env ) ->
        List [ Atom "Fix";
               Ident.sexp_of_t id;
               Label.sexp_of_t l;
               List (List.map Ident.sexp_of_t idents) ]
    | Frame (i, _env) ->
        List [ Atom "Frame";
               sexp_of_int i;
               Atom "..." ]
    | Block (i, vs) ->
        List ( Tag.sexp_of_t i :: List.map short_sexp_of_t vs)

  and short_sexp_of_env idts = VMEnv0.sexp_of_t short_sexp_of_t idts

  let detailed_format = ref false
  let sexp_of_t t = (if !detailed_format then sexp_of_t else short_sexp_of_t) t
  let sexp_of_env t = (if !detailed_format then sexp_of_env else short_sexp_of_env) t

  let detailed_format = ref false
  let format ppf t = Sexp.pp_hum ppf (sexp_of_t t)

  let bool b = Const (Const.Bool b)
  let true_ = Const (Const.Bool true)
  let false_ = Const (Const.Bool false)
  let int n = Const (Const.Int n)
  let zero = int 0
  let string s = Const (Const.String s)
  let char c = Const (Const.Char c)
end

module VMEnv = struct
  type t = Value.t VMEnv0.t with sexp
  type elt = Value.t with sexp
  let get = VMEnv0.get sexp_of_elt
  let push = VMEnv0.push
  let pop = VMEnv0.pop
  let empty = VMEnv0.empty
  let of_list = VMEnv0.of_list
end

module XPrim : sig
  val eval : string -> Value.t list -> Value.t
  (** semantics of primitives *)
end = struct
  open Value
  open Const

  let eval prim args = match prim, args with
    | "int_add", [ Const (Int n); Const (Int m) ] -> int (n+m)
    | "int_sub", [ Const (Int n); Const (Int m) ] -> int (n-m)
    | "int_mul", [ Const (Int n); Const (Int m) ] -> int (n*m)
    | "int_div", [ Const (Int n); Const (Int m) ] -> int (n/m)
    | "minus", [ Const (Int n); Const (Int m) ] -> int (n-m)
    | "eq", [ Const c1; Const c2 ] -> bool (c1 = c2)
    | "eq", [ _; _ ] -> false_

    | "eq_tag", [ Block (tag, _); Const (Int n) ] -> bool (Tag.to_int tag = n)
    | "eq_tag", [ _; Const (Int _) ] -> false_

    | "field", [ Block (_, args); Const (Int n) ] -> List.nth args n

    | "print", [ v ] ->
        Format.eprintf "%a@." format v;
        zero

    | "show", [ v ] -> string (Format.sprintf "%a" format v)

    | "string_concat", [ Const (String s1); Const (String s2) ] -> string (s1 ^ s2)
    | "string_length", [ Const (String s) ] -> int (String.length s)
    | "string_sub", [ Const (String s); Const (Int off); Const (Int len)] -> string (String.sub s off len)
    | "string_get", [ Const (String s); Const (Int off)] -> char s.[off]
    | "string_index", [ Const (String s); Const (Char c)] -> int (try String.index s c with Not_found -> -1)

    | "assert", [ Const (Bool true) ] -> zero
    | "assert", [ _ ] -> failwith "Assert failure!"

    | _ -> failwith ("Prim.eval failed for " ^ prim)
end

module Prim = struct
  include Prim
  include XPrim
end

module Stack = struct
  type t = Value.t list with sexp
end

module State = struct
  type t = {
    pc : int;
    env : VMEnv.t; (** heap *)
    stack : Stack.t;
    modules : (string * Value.t) list; (** loaded modules *)
  } with sexp

  let initial = { pc= 0; env= VMEnv.empty; stack= []; modules = [] }

  let format ppf t = Sexp.pp_hum ppf (sexp_of_t t)
end

module Eval = struct

  open State

  module C = Code

  let print_step = ref false

  (** One step evaluation *)    
  let step code_groups { pc; env; stack; modules } =
    let code = code_groups.(pc) in
    match code with
    | C.Comment _ -> { pc = pc + 1; env; stack; modules } (* NOP *)
    | _ -> 
        if !print_step then begin
          Format.eprintf "%d %a@." pc Sexp.pp_hum (Code.sexp_of_t code);
          Format.eprintf "    STACK %a@." Sexp.pp_hum (Stack.sexp_of_t stack);
(*
          Format.eprintf "    ENV %a@." Sexp.pp_hum (VMEnv.sexp_of_t env);
*)
        end;
        match code with
        | C.Comment _ -> assert false
        | C.Label _ -> { pc = pc + 1; env; stack; modules } (* NOP *)
            
        | C.Jmp l -> { pc = l.Label.adrs; env; stack; modules }
            
        | C.Jmpc l ->
  	    begin match stack with
  	    | [] -> failwith "stack empty at Jmpc"
  	    | Value.Const (Const.Bool false) :: stack -> { pc = l.Label.adrs; env; stack; modules }
  	    | Value.Const (Const.Bool true) :: stack -> { pc = pc + 1; env; stack; modules }
  	    | _ -> failwith "jmpc type error"
  	    end
              
        | C.JmpWithFrame l -> { pc = l.Label.adrs; env; stack = Value.Frame(pc+1, env) :: stack; modules }
              
        | C.Access (pos, ident) ->
  	    { pc = pc + 1;
              env;
              stack = VMEnv.get env (pos, ident) :: stack;
              modules;
            }
  
        | C.Push_const c ->
  	    { pc = pc + 1;
  	      env;
  	      stack = Value.Const c :: stack;
              modules;
            }
  
        |  C.Push_closure (l, names, fvars) ->
            let env_minimum = VMEnv.of_list (List.map (fun (pos, id) -> id, VMEnv.get env (pos, id)) fvars) in
  	    { pc = pc + 1;
  	      env;
  	      stack = Value.Clos (l, names, env_minimum) :: stack;
              modules;
            }
  
        | C.Push_fix (ident, l, names, fvars) ->
            (* fvars contains ident but not in env *)
            let env_minimum = VMEnv.of_list (List.map (fun (pos, id) -> id, VMEnv.get env (pos, id)) fvars) in
  	    { pc = pc + 1;
  	      env;
  	      stack = Value.Fix (ident, l, names, env_minimum) :: stack;
              modules;
            }
  
        | C.Swap ident ->
  	    begin match stack with
  	    | [] -> failwith "stack empty at Swap"
  	    | v::stack ->
                { pc = pc + 1;
                  env = VMEnv.push env ident v;
                  stack;
                  modules;
                }
  	    end
  
        | C.Swaps idents ->
  	    begin match stack with
  	    | [] -> failwith "stack empty at Swap"
  	    | Value.Block(_, vs)::stack when List.length idents = List.length vs ->
                { pc = pc + 1;
                  env = List.fold_left (fun env (id, v) -> VMEnv.push env id v) env (List.combine idents vs);
                  stack;
                  modules;
                }
  	    | _::_stack -> failwith "stack top is not block for Swaps"
  	    end
  
        | C.Return ->
  	    begin match stack with
  	    | v :: Value.Frame(adrs, env') :: stack ->
  	        { pc = adrs;
                  env = env';
                  stack = v :: stack;
                  modules;
              }
  	    | [_] ->
                (* Stupid way of ending *)
  	        { pc = -1;
                  env;
                  stack;
                  modules;
                }
  	    | [] -> failwith "short stack at Return"
  	    | _ -> 
                Format.eprintf "%d %a@." pc Sexp.pp_hum (Code.sexp_of_t code);
                Format.eprintf "    STACK %a@." Sexp.pp_hum (Stack.sexp_of_t stack);
                failwith "wrong stack at Return (second is not a frame)";
  	    end

        | C.ReturnAt n ->
            let rec get_n st pos = function
              | [] when pos = 0 -> (* no return address. end of program *)
                  None, List.rev st
              | [] -> assert false (* stack too short *)
              | x::xs when pos = 0 -> Some x, List.rev_append st xs
              | x::xs -> get_n (x::st) (pos-1) xs
            in
            begin match get_n [] n stack with
            | Some (Value.Frame(adrs,env')), stack ->
                { pc = adrs;
                  env = env';
                  stack = stack;
                  modules
                }
            | Some _, _ -> assert false
            | None, stack ->
                { pc = -1;
                  env = env;
                  stack = stack;
                  modules
                }
  	    end

        | C.Prim (name, arity) ->
            let args, stack =
              let rec split_at n xs =
                if n = 0 then [], xs
                else match xs with
                | [] -> assert false
                | x::xs -> 
                    let l1, l2 = split_at (n-1) xs in
                    x::l1, l2
              in
              split_at arity stack
            in
  	    { pc = pc + 1;
  	      env;
  	      stack = Prim.eval name (List.rev args) :: stack;
              modules;
            }

        | C.MkBlock (tag, arity) ->
            let args, stack =
              let rec split_at n xs =
                if n = 0 then [], xs
                else match xs with
                | [] -> assert false
                | x::xs -> 
                    let l1, l2 = split_at (n-1) xs in
                    x::l1, l2
              in
              split_at arity stack
            in
  	    { pc = pc + 1;
  	      env;
  	      stack = Value.Block (tag, List.rev args) :: stack;
              modules;
            }
  
        
        | C.DeBlock label_patvars_list -> 
            let (label, patvars), args = match stack with
              | Value.Const(Const.Int n)::_ -> List.nth label_patvars_list n, []
              | Value.Block(n, args)::_ -> List.nth label_patvars_list (Tag.to_int n), args
              | _ -> assert false
            in
            { pc = label.Label.adrs;
              env = List.fold_right (fun (var, v) env -> VMEnv.push env var v) (List.combine patvars args) env ;
              stack = List.tl stack; modules }

        | C.Field pos ->
            let stack' = match stack with
              | Value.Const _::_ -> assert false
              | Value.Block(_, args)::rem -> 
                  List.nth args pos::rem
              | _ -> assert false
            in
            { pc = pc + 1; env; stack = stack'; modules }

        | C.Apply ->
  	    begin match stack with
  	    | v :: Value.Clos(l, [var], env') :: stack -> (* closure full app *)
  	        { pc = l.Label.adrs;
  	          env = VMEnv.push env' var v;
  	          stack = Value.Frame(pc + 1, env) :: stack; (* store the return address *)
                  modules;
                }
  
  	    | v :: Value.Clos(l, var::vars, env') :: stack -> (* closure partial app *)
  	        { pc = pc + 1;
  	          env;
  	          stack = Value.Clos(l, vars, VMEnv.push env' var v) :: stack;
                  modules;
                }
  
  	    | _ :: Value.Clos(_l, [], _env) :: _ -> failwith "malformed Clos at Apply"
  
  	    | v :: Value.Fix(ident, l, argv0, env0) :: stack ->
                { pc;
                  env;
                  stack = v :: Value.Clos(l, argv0, VMEnv.push env0 ident 
                    (Value.Fix(ident, l, argv0, env0))) :: stack; modules } 
  	    | _ -> failwith "short stack at Apply"
  	    end
  
        | C.Pop_env ->
  	    begin match VMEnv.pop env with
  	    | Some (_, env) -> { pc = pc + 1; env; stack; modules }
  	    | None -> failwith "short env at Pop_env"
  	    end

        | C.Pop_stack ->
  	    begin match stack with
  	    | _::stack -> { pc = pc + 1; env; stack; modules }
  	    | [] -> failwith "short stack at Pop_stack"
  	    end

        | C.LoadModule name ->
            (* The runtime knows id=>value *)
            begin try
              let mdl = List.assoc name modules in
              { pc = pc + 1; env; stack = mdl :: stack; modules }
              with Not_found -> failwithf "LoadModule %s failed" name
            end

        | C.RegisterModule name ->
            begin match stack with
            | (Value.Block _ as m) :: rem ->
                { pc = pc + 1; env; stack = rem; modules = (name, m) :: modules; }
            | _ -> assert false
            end
            

  let run codes state =
    let rec loop state =
      let state = step codes state in
      if state.pc = -1 then 
        state.stack, state.env
      else loop state
    in
    loop state

  let run codes pc venv = 
    Format.eprintf "@.exec@.";
    let state = { pc = pc; stack = []; env = venv; modules = [] } in
    let vstack, venv = run codes state in
    Format.eprintf "@.result=%a@." Sexp.pp_hum (sexp_of_list Value.sexp_of_t vstack);
    Format.printf "%a@." Sexp.pp_hum (sexp_of_list Value.sexp_of_t vstack);
    vstack, venv

end