This repository has been archived on 2024-01-18. You can view files and clone it, but cannot push or open issues or pull requests.
compilation/flap/src/hobix/hobixInterpreter.ml
2023-10-04 15:40:22 +02:00

418 lines
11 KiB
OCaml

open Error
open HobixAST
(** [error pos msg] reports runtime error messages. *)
let error positions msg =
errorN "execution" positions msg
(** Every expression of hobix evaluates into a [value]. *)
type 'e gvalue =
| VInt of Int64.t
| VChar of char
| VString of string
| VUnit
| VAddress of Memory.location
| VPrimitive of string * ('e gvalue list -> 'e gvalue)
| VBool of bool
| VFun of identifier list * expression * 'e
type ('a, 'e) coercion = 'e gvalue -> 'a option
let value_as_int = function VInt x -> Some x | _ -> None
let value_as_bool = function VBool x -> Some x | _ -> None
let value_as_char = function VChar c -> Some c | _ -> None
let value_as_addr = function VAddress a -> Some a | _ -> None
let ( >>= ) m f =
match m with
| None -> None
| Some x -> f x
let return x =
Some x
let trust_me = function
| None -> assert false (* Impossible. *)
| Some x -> x
type ('a, 'e) wrapper = 'a -> 'e gvalue
let int_as_value x = VInt x
let bool_as_value x = VBool x
let primitive name ?(error = fun () -> assert false) coercion wrapper f =
VPrimitive (name, fun x ->
match coercion x with
| None -> error ()
| Some x -> wrapper (f x)
)
let print_value m v =
let max_depth = 5 in
let rec print_value d v =
if d >= max_depth then "..." else
match v with
| VInt x ->
Int64.to_string x
| VBool true ->
"true"
| VBool false ->
"false"
| VChar c ->
"'" ^ Char.escaped c ^ "'"
| VString s ->
"\"" ^ String.escaped s ^ "\""
| VUnit ->
"()"
| VAddress a ->
print_block m d a
| VFun _ ->
"<fun>"
| VPrimitive (s, _) ->
Printf.sprintf "<primitive: %s>" s
and print_block m d a =
let b = Memory.dereference m a in
let vs = Array.to_list (Memory.array_of_block b) in
"[ " ^ String.concat "; " (List.map (print_value d) vs) ^ " ]"
in
print_value 0 v
module Environment : sig
type t
val empty : t
val bind : t -> identifier -> t gvalue -> t
val update : identifier -> t -> t gvalue -> unit
exception UnboundIdentifier of identifier
val lookup : identifier -> t -> t gvalue
val last : t -> (identifier * t gvalue * t) option
val print : t gvalue Memory.t -> t -> string
end = struct
type t =
| EEmpty
| EBind of identifier * t gvalue ref * t
let empty = EEmpty
let bind e x v =
EBind (x, ref v, e)
exception UnboundIdentifier of identifier
let lookup' x =
let rec aux = function
| EEmpty -> raise (UnboundIdentifier x)
| EBind (y, v, e) ->
if x = y then v else aux e
in
aux
let lookup x e = !(lookup' x e)
let update x e v =
lookup' x e := v
let last = function
| EBind (x, v, e) -> Some (x, !v, e)
| EEmpty -> None
let print_binding m (Id x, v) =
x ^ " = " ^ print_value m !v
let print m e =
let b = Buffer.create 13 in
let push x v = Buffer.add_string b (print_binding m (x, v)) in
let rec aux = function
| EEmpty -> Buffer.contents b
| EBind (x, v, EEmpty) -> push x v; aux EEmpty
| EBind (x, v, e) -> push x v; Buffer.add_string b "\n"; aux e
in
aux e
end
type value = Environment.t gvalue
type formals = identifier list
type runtime = {
memory : value Memory.t;
environment : Environment.t;
}
type observable = {
new_memory : value Memory.t;
new_environment : Environment.t;
}
(** [primitives] is an environment that contains the implementation
of all primitives (+, <, ...). *)
let primitives =
let intbin name out op =
VPrimitive (name, function [VInt x; VInt y] -> out (op x y)
| _ ->
Printf.printf "%s\n" name;
assert false (* By typing. *)
)
in
let bind_all what l x =
List.fold_left (fun env (x, v) -> Environment.bind env (Id x) (what x v)) x l
in
(* Define arithmetic binary operators. *)
let binarith name =
intbin name (fun x -> VInt x) in
let binarithops = Int64.(
[ ("`+`", add); ("`-`", sub); ("`*`", mul); ("`/`", div) ]
) in
(* Define arithmetic comparison operators. *)
let cmparith name = intbin name (fun x -> VBool x) in
let cmparithops =
[ ("`=?`", ( = )); ("`<?`", ( < )); ("`>?`", ( > ));
("`>=?`", ( >= )); ("`<=?`", ( <= )) ]
in
let boolbin name out op =
VPrimitive (name, function [VBool x; VBool y] -> out (op x y)
| _ -> assert false (* By typing. *)
)
in
let boolarith name = boolbin name (fun x -> VBool x) in
let boolarithops =
[ ("`||`", ( || )); ("`&&`", ( && )) ]
in
let print s =
output_string stdout s;
flush stdout;
VUnit
in
let print_int =
VPrimitive ("print_int", function
| [ VInt x ] -> print (Int64.to_string x)
| _ -> assert false (* By typing. *)
)
in
let print_string =
VPrimitive ("print_string", function
| [ VString x ] -> print x
| _ -> assert false (* By typing. *)
)
in
let equal_string =
VPrimitive ("equal_string", function
| [ VString x; VString y ] -> VBool (String.compare x y = 0)
| _ -> assert false (* By typing. *)
)
in
let equal_char =
VPrimitive ("equal_char", function
| [ VChar x; VChar y ] -> VBool (Char.compare x y = 0)
| _ -> assert false (* By typing. *)
)
in
let bind' x w env = Environment.bind env (Id x) w in
Environment.empty
|> bind_all binarith binarithops
|> bind_all cmparith cmparithops
|> bind_all boolarith boolarithops
|> bind' "print_int" print_int
|> bind' "print_string" print_string
|> bind' "equal_string" equal_string
|> bind' "equal_char" equal_char
|> bind' "true" (VBool true)
|> bind' "false" (VBool false)
|> bind' "nothing" VUnit
let initial_runtime () = {
memory = Memory.create (640 * 1024);
environment = primitives;
}
let rec evaluate runtime ast =
try
let runtime' = List.fold_left definition runtime ast in
(runtime', extract_observable runtime runtime')
with Environment.UnboundIdentifier (Id x) ->
Error.error "interpretation" Position.dummy (Printf.sprintf "`%s' is unbound." x)
(* [definition pos runtime d] evaluates the new definition [d]
into a new runtime [runtime']. In the specification, this
is the judgment:
E, M ⊢ dᵥ ⇒ E', M'
*)
and definition runtime d =
match d with
| DefineValue vd ->
value_definition runtime vd
| DeclareExtern _ ->
runtime
and value_definition runtime = function
| SimpleValue (x, e) ->
let v = expression runtime.environment runtime.memory e in
{ runtime with environment =
bind_identifier runtime.environment x v
}
| RecFunctions rdefs ->
{ runtime with environment =
define_recvalues runtime.environment runtime.memory rdefs
}
and define_recvalues environment memory rdefs =
let environment =
List.fold_left (fun env (x, _) ->
bind_identifier env x VUnit) environment rdefs
in
let vs = expressions environment memory (snd (List.split rdefs)) in
List.iter2 (fun (x, _) v ->
Environment.update x environment v
) rdefs vs;
environment
(* [expression pos runtime e] evaluates into a value [v] if
E, M ⊢ e ⇓ v, M'
and E = [runtime.environment], M = [runtime.memory].
*)
and expression environment memory = function
| Apply (a, b) ->
let vbs () = expressions environment memory b in
begin match expression environment memory a with
| VPrimitive ("`||", _) ->
begin match expression environment memory (List.nth b 0) with
| VBool true -> VBool true
| _ -> expression environment memory (List.nth b 1)
end
| VPrimitive ("`&&", _) ->
begin match expression environment memory (List.nth b 0) with
| VBool false -> VBool false
| _ -> expression environment memory (List.nth b 1)
end
| VPrimitive (_, f) ->
f (vbs ())
| VFun (xs, e, environment) ->
expression (List.fold_left2 bind_identifier environment xs (vbs ())) memory e
| _ ->
assert false (* By typing. *)
end
| While (c, e) ->
let rec aux () =
match expression environment memory c with
| VBool true ->
ignore (expression environment memory e);
aux ()
| VBool false ->
VUnit
| _ ->
assert false (* By typing. *)
in
aux ()
| Switch (e, branches, default) ->
begin match expression environment memory e with
| VInt i ->
let i = Int64.to_int i in
if i < 0 then assert false; (* By typing. *)
if i < Array.length branches && branches.(i) <> None then
match branches.(i) with
| None -> assert false (* By condition. *)
| Some t -> expression environment memory t
else begin match default with
| None -> assert false; (* By typing. *)
| Some t -> expression environment memory t
end
| _ -> assert false (* By typing. *)
end
| Fun (p, e) ->
VFun (p, e, environment)
| Literal l ->
literal l
| Variable x ->
Environment.lookup x environment
| Define (vd, e) ->
let runtime = value_definition { environment; memory } vd in
expression runtime.environment runtime.memory e
| IfThenElse (c, t, f) ->
let v = expression environment memory c in
begin match value_as_bool v with
| None -> assert false (* By typing. *)
| Some true -> expression environment memory t
| Some false -> expression environment memory f
end
| AllocateBlock e ->
begin match expression environment memory e with
| VInt x ->
let a = Memory.allocate memory x (VInt Int64.zero) in
VAddress a
| _ ->
assert false (* By typing. *)
end
| WriteBlock (b, i, v) ->
let bv = expression environment memory b in
(value_as_addr bv >>= fun a ->
let bi = expression environment memory i in
value_as_int bi >>= fun i ->
let bb = expression environment memory v in
let b = Memory.dereference memory a in
Memory.write b i bb;
return (VUnit)
) |> trust_me (* By typing. *)
| ReadBlock (b, i) ->
let bv = expression environment memory b in
(value_as_addr bv >>= fun a ->
let bi = expression environment memory i in
value_as_int bi >>= fun i ->
let b = Memory.dereference memory a in
return (Memory.read b i)
) |> trust_me (* By typing. *)
and expressions environment memory es =
let rec aux vs = function
| [] ->
List.rev vs
| e :: es ->
let v = expression environment memory e in
aux (v :: vs) es
in
aux [] es
and bind_identifier environment (x : identifier) v =
Environment.bind environment x v
and literal = function
| LInt x -> VInt x
| LChar c -> VChar c
| LString s -> VString s
and extract_observable runtime runtime' =
let rec substract new_environment env env' =
if env == env' then new_environment
else
match Environment.last env' with
| None -> assert false (* Absurd. *)
| Some (x, v, env') ->
let new_environment = Environment.bind new_environment x v in
substract new_environment env env'
in
{
new_environment =
substract Environment.empty runtime.environment runtime'.environment;
new_memory =
runtime'.memory
}
let print_observable _ observation =
Environment.print observation.new_memory observation.new_environment