coollang/lib/interp.ml

(* 트리 워킹 인터프리터.

   여기 도달한 프로그램은 이미 타입, effect, capability, ownership 검사를
   통과했다. 그러므로 이 파일은 검사하지 않는다 — 검사기가 이미 답한 질문을
   실행 시점에 다시 묻는 것은 두 번째 진실을 만드는 일이다.

   실행 시점 오류로 남는 것은 검사기가 원리적으로 못 잡는 것뿐이다:
   0으로 나누기, 리스트 범위, 그리고 아직 없는 표준 라이브러리 이름.

   권한의 유일한 출처는 런타임이다. 소스에는 capability를 만드는 문법이 없고,
   main은 자기가 선언한 capability만 받는다. 선언하지 않은 권한은 프로그램
   어디에도 존재하지 않는다 — 보안 정리 (i)의 실행 시점 대응물이다. *)

type value =
  | VUnit
  | VInt of int
  | VBool of bool
  | VStr of string
  | VList of value list
  | VStruct of string * (string * value ref) list
  | VEnum of string * string * value list (* enum, variant, 인자 *)
  | VClosure of { params : string list; body : Ir.t; env : env }
  | VFn of Ir.fn
  | VCtor of string * string * int (* 아직 인자를 안 받은 생성자 *)
  | VBuiltin of string
  | VNative of (value list -> value)
  | VCap of string * (string * (value list -> value)) list
  | VScope of string

and env = (string * value ref) list list

exception Return_exc of value
exception Fail of Token.pos * string

let fail pos msg = raise (Fail (pos, msg))

let rec show = function
  | VUnit -> "unit"
  | VInt n -> string_of_int n
  | VBool b -> if b then "true" else "false"
  | VStr s -> s
  | VList xs -> "[" ^ String.concat ", " (List.map show xs) ^ "]"
  | VStruct (n, fs) ->
      n ^ "{"
      ^ String.concat ", " (List.map (fun (k, v) -> k ^ ": " ^ show !v) fs)
      ^ "}"
  | VEnum (_, v, []) -> v
  | VEnum (_, v, args) ->
      v ^ "(" ^ String.concat ", " (List.map show args) ^ ")"
  | VClosure _ | VFn _ | VBuiltin _ | VCtor _ | VNative _ -> "<fn>"
  | VCap (n, _) -> "<capability " ^ n ^ ">"
  | VScope n -> "<scope " ^ n ^ ">"

let rec eq a b =
  match (a, b) with
  | VInt x, VInt y -> x = y
  | VBool x, VBool y -> x = y
  | VStr x, VStr y -> x = y
  | VUnit, VUnit -> true
  | VList x, VList y -> List.length x = List.length y && List.for_all2 eq x y
  | VEnum (_, v1, a1), VEnum (_, v2, a2) ->
      v1 = v2 && List.length a1 = List.length a2 && List.for_all2 eq a1 a2
  | _ -> false

(* ------------------------------------------------------------------ *)
(* 환경                                                                *)
(* ------------------------------------------------------------------ *)

let lookup (env : env) n =
  let rec go = function
    | [] -> None
    | s :: r -> (
        match List.assoc_opt n s with Some v -> Some v | None -> go r)
  in
  go env

let bind (env : env) n v : env =
  match env with s :: r -> ((n, ref v) :: s) :: r | [] -> [ [ (n, ref v) ] ]

(* ------------------------------------------------------------------ *)
(* 런타임이 제공하는 것                                                *)
(* ------------------------------------------------------------------ *)

let out = Buffer.create 1024

let root_capability name : value option =
  match name with
  | "Console" ->
      Some
        (VCap
           ( "Console",
             [
               ( "print",
                 fun args ->
                   List.iter (fun v -> Buffer.add_string out (show v)) args;
                   Buffer.add_char out '\n';
                   VUnit );
             ] ))
  | "TaskScope" ->
      (* 루트 스코프. 구조적 동시성의 뿌리도 런타임이 준다 — 프로그램이
         스스로 만들 수 있으면 부모 없는 작업이 생긴다. *)
      Some (VScope "root")
  | _ -> None

let builtin pos name (args : value list) : value =
  match (name, args) with
  | "string.concat", [ VStr a; VStr b ] -> VStr (a ^ b)
  | "string.len", [ VStr a ] -> VInt (String.length a)
  | "int.show", [ VInt n ] -> VStr (string_of_int n)
  | "int.abs", [ VInt n ] -> VInt (abs n)
  | "bool.show", [ VBool b ] -> VStr (if b then "true" else "false")
  | "list.len", [ VList xs ] -> VInt (List.length xs)
  | _ ->
      fail pos (Printf.sprintf "%s은(는) 런타임이 제공하지 않습니다 (표준 라이브러리가 아직 없습니다)" name)

(* ------------------------------------------------------------------ *)
(* 실행                                                                *)
(* ------------------------------------------------------------------ *)

type st = { prog : Ir.program }

let rec eval st (env : env) (e : Ir.t) : value =
  match e with
  | Ir.I_unit -> VUnit
  | Ir.I_lit (Ast.L_int n) -> VInt (int_of_string n)
  | Ir.I_lit (Ast.L_str s) -> VStr s
  | Ir.I_lit (Ast.L_bool b) -> VBool b
  | Ir.I_ref (k, pos) -> eval_ref st env k pos
  | Ir.I_list xs -> VList (List.map (eval st env) xs)
  | Ir.I_make (n, fields) ->
      VStruct (n, List.map (fun (k, e) -> (k, ref (eval st env e))) fields)
  | Ir.I_closure c -> VClosure { params = c.c_params; body = c.c_body; env }
  | Ir.I_if { cond; then_; else_ } -> (
      match eval st env cond with
      | VBool true -> eval st ([] :: env) then_
      | _ -> eval st ([] :: env) else_)
  | Ir.I_match { scrutinee; arms; pos } ->
      let v = eval st env scrutinee in
      let rec go = function
        | [] -> fail pos "match에서 어떤 팔도 맞지 않았습니다"
        | (p, body) :: rest -> (
            match match_pat v p with
            | None -> go rest
            | Some binds ->
                let env =
                  List.fold_left (fun e (n, v) -> bind e n v) ([] :: env) binds
                in
                eval st env body)
      in
      go arms
  | Ir.I_scope { name; body; _ } ->
      (* v0의 실행 의미: 자식 작업은 순차로 돈다. 블록을 나가는 것이 join이다.
         구조가 먼저고 병렬성은 그 위의 최적화다 — 순서가 반대면 취소와
         전파를 나중에 끼워 넣게 된다. *)
      let env = bind ([] :: env) name (VScope name) in
      eval st env body
  | Ir.I_seq (stmts, tail) ->
      let env = List.fold_left (fun env s -> exec st env s) ([] :: env) stmts in
      eval st env tail
  | Ir.I_call { callee; args; pos } ->
      let f = eval st env callee in
      let args = List.map (eval st env) args in
      apply st pos f args
  | Ir.I_field { obj; name; pos } -> (
      match eval st env obj with
      | VStruct (sn, fields) -> (
          match List.assoc_opt name fields with
          | Some r -> !r
          | None -> fail pos (Printf.sprintf "%s에 %s 필드가 없습니다" sn name))
      | VCap (cn, meths) -> (
          (* capability 메서드는 값을 통해서만 나온다. 여기가 권한이 코드로
             흐르는 유일한 통로다. *)
          match List.assoc_opt name meths with
          | Some f -> VNative f
          | None ->
              fail pos (Printf.sprintf "capability %s에 %s이(가) 없습니다" cn name))
      | VScope _ when name = "spawn" ->
          VNative
            (fun args ->
              match args with
              | [ f ] -> apply st pos f []
              | _ -> fail pos "spawn은 함수 하나를 받습니다")
      | other -> fail pos (Printf.sprintf "%s에는 필드가 없습니다" (show other)))
  | Ir.I_unary (op, e, pos) -> (
      match (op, eval st env e) with
      | Ast.U_not, VBool b -> VBool (not b)
      | Ast.U_neg, VInt n -> VInt (-n)
      | _ -> fail pos "단항 연산자의 피연산자가 맞지 않습니다")
  | Ir.I_binary (op, a, b, pos) -> eval_binary st env op a b pos

and eval_ref st env k pos =
  match k with
  | Ir.R_local n -> (
      match lookup env n with
      | Some r -> !r
      | None -> fail pos (Printf.sprintf "%s이(가) 묶여 있지 않습니다" n))
  | Ir.R_ctor (enum, name) -> (
      match Hashtbl.find_opt st.prog.Ir.ctors name with
      | Some (_, 0) -> VEnum (enum, name, [])
      | Some (_, n) -> VCtor (enum, name, n)
      | None -> VEnum (enum, name, []))
  | Ir.R_global n -> (
      match Hashtbl.find_opt st.prog.Ir.fns n with
      | Some f -> VFn f
      | None -> (
          match Hashtbl.find_opt st.prog.Ir.consts n with
          | Some e -> eval st [ [] ] e
          | None -> fail pos (Printf.sprintf "%s을(를) 찾을 수 없습니다" n)))
  | Ir.R_builtin n -> VBuiltin n

and apply st pos f args =
  match f with
  | VFn fn -> (
      let env = [ List.map2 (fun p a -> (p, ref a)) fn.Ir.fn_params args ] in
      try eval st env fn.Ir.fn_body with Return_exc v -> v)
  | VClosure { params; body; env } -> (
      let env = List.map2 (fun p a -> (p, ref a)) params args :: env in
      try eval st env body with Return_exc v -> v)
  | VCtor (enum, name, _) -> VEnum (enum, name, args)
  (* 고차 builtin은 여기서 처리한다 — apply를 다시 부를 수 있어야 하므로 *)
  | VBuiltin "list.each" -> (
      match args with
      | [ VList xs; f ] ->
          List.iter (fun x -> ignore (apply st pos f [ x ])) xs;
          VUnit
      | _ -> fail pos "list.each는 리스트와 함수를 받습니다")
  | VBuiltin "list.map" -> (
      match args with
      | [ VList xs; f ] -> VList (List.map (fun x -> apply st pos f [ x ]) xs)
      | _ -> fail pos "list.map은 리스트와 함수를 받습니다")
  | VBuiltin n -> builtin pos n args
  | VNative f -> f args
  | other -> fail pos (Printf.sprintf "%s은(는) 부를 수 없습니다" (show other))

and exec st env (s : Ir.stmt) : env =
  match s with
  | Ir.S_do e ->
      ignore (eval st env e);
      env
  | Ir.S_return (e, _) -> raise (Return_exc (eval st env e))
  | Ir.S_let (p, e, pos) -> (
      let v = eval st env e in
      match match_pat v p with
      | None -> fail pos "let 패턴이 값과 맞지 않습니다"
      | Some binds -> List.fold_left (fun e (n, v) -> bind e n v) env binds)
  | Ir.S_assign { place; value; pos } -> (
      let v = eval st env value in
      match place with
      | Ir.I_ref (Ir.R_local n, _) -> (
          match lookup env n with
          | Some r ->
              r := v;
              env
          | None -> fail pos (Printf.sprintf "%s이(가) 묶여 있지 않습니다" n))
      | Ir.I_field { obj; name; _ } -> (
          match eval st env obj with
          | VStruct (_, fields) -> (
              match List.assoc_opt name fields with
              | Some r ->
                  r := v;
                  env
              | None -> fail pos (Printf.sprintf "%s 필드가 없습니다" name))
          | _ -> fail pos "필드에 대입할 수 없습니다")
      | _ -> fail pos "대입할 수 없는 자리입니다")

and match_pat v (p : Ir.pat) : (string * value) list option =
  match (p, v) with
  | Ir.IP_wild, _ -> Some []
  | Ir.IP_bind n, _ -> Some [ (n, v) ]
  | Ir.IP_lit (Ast.L_int n), VInt m ->
      if int_of_string n = m then Some [] else None
  | Ir.IP_lit (Ast.L_str s), VStr t -> if s = t then Some [] else None
  | Ir.IP_lit (Ast.L_bool b), VBool c -> if b = c then Some [] else None
  | Ir.IP_ctor (name, ps), VEnum (_, vn, args) ->
      if name <> vn || List.length ps <> List.length args then None
      else
        List.fold_left2
          (fun acc p a ->
            match (acc, match_pat a p) with
            | Some xs, Some ys -> Some (xs @ ys)
            | _ -> None)
          (Some []) ps args
  | _ -> None

and eval_binary st env op a b pos =
  match op with
  (* 단축 평가. 오른쪽을 먼저 계산하면 && 의 의미가 달라진다 *)
  | Ast.B_and -> (
      match eval st env a with VBool false -> VBool false | _ -> eval st env b)
  | Ast.B_or -> (
      match eval st env a with VBool true -> VBool true | _ -> eval st env b)
  | _ -> (
      let x = eval st env a and y = eval st env b in
      match (op, x, y) with
      | Ast.B_eq, _, _ -> VBool (eq x y)
      | Ast.B_ne, _, _ -> VBool (not (eq x y))
      | Ast.B_lt, VInt m, VInt n -> VBool (m < n)
      | Ast.B_le, VInt m, VInt n -> VBool (m <= n)
      | Ast.B_gt, VInt m, VInt n -> VBool (m > n)
      | Ast.B_ge, VInt m, VInt n -> VBool (m >= n)
      | Ast.B_add, VInt m, VInt n -> VInt (m + n)
      | Ast.B_sub, VInt m, VInt n -> VInt (m - n)
      | Ast.B_mul, VInt m, VInt n -> VInt (m * n)
      | Ast.B_div, VInt _, VInt 0 -> fail pos "0으로 나눌 수 없습니다"
      | Ast.B_div, VInt m, VInt n -> VInt (m / n)
      | Ast.B_rem, VInt _, VInt 0 -> fail pos "0으로 나눌 수 없습니다"
      | Ast.B_rem, VInt m, VInt n -> VInt (m mod n)
      | _ -> fail pos "연산자의 피연산자 타입이 맞지 않습니다")

(* ------------------------------------------------------------------ *)
(* 진입                                                                *)
(* ------------------------------------------------------------------ *)

(* main이 선언한 capability만 런타임이 넘긴다. 선언하지 않은 권한은
   프로그램 안에 존재하지 않는다. *)
let run (prog : Ir.program) (entry : string)
    (main_params : (string * string) list) : (string, Token.pos * string) result
    =
  Buffer.clear out;
  let st = { prog } in
  match Hashtbl.find_opt prog.Ir.fns (entry ^ "#main") with
  | None -> Error (Token.{ line = 0; col = 0 }, "main 함수가 없습니다")
  | Some fn -> (
      let args =
        List.map
          (fun (_, tyname) ->
            match root_capability tyname with
            | Some v -> Ok v
            | None ->
                Error (Printf.sprintf "런타임이 %s capability를 제공하지 않습니다" tyname))
          main_params
      in
      match List.find_opt Result.is_error args with
      | Some (Error m) -> Error (Token.{ line = 0; col = 0 }, m)
      | _ -> (
          let args = List.map Result.get_ok args in
          try
            ignore (apply st Token.{ line = 0; col = 0 } (VFn fn) args);
            Ok (Buffer.contents out)
          with
          | Fail (pos, msg) -> Error (pos, msg)
          | Return_exc _ -> Ok (Buffer.contents out)))