mirror of
https://github.com/ProgramSnail/pass_strategy_synthesis.git
synced 2025-12-24 17:58:44 +00:00
language simplification, original language is moved to the lib_next module
This commit is contained in:
ProgramSnail
parent
b64cf6e9ce
commit
f770620742
3 changed files with 192 additions and 152 deletions
16
lib/dune
16
lib/dune
|
|
@ -18,3 +18,19 @@
|
|||
GT.ppx
|
||||
GT.ppx_all
|
||||
ppx_inline_test)))
|
||||
|
||||
(library
|
||||
(name lib2)
|
||||
(modules lib_next)
|
||||
(flags (-rectypes))
|
||||
(libraries OCanren OCanren.tester)
|
||||
(inline_tests)
|
||||
(wrapped false)
|
||||
(preprocess
|
||||
(pps
|
||||
OCanren-ppx.ppx_repr
|
||||
OCanren-ppx.ppx_fresh
|
||||
OCanren-ppx.ppx_distrib
|
||||
GT.ppx
|
||||
GT.ppx_all
|
||||
ppx_inline_test)))
|
||||
|
|
|
|||
159
lib/lib.ml
159
lib/lib.ml
|
|
@ -1,158 +1,13 @@
|
|||
open OCanren
|
||||
|
||||
(* TODO: lift to logic domain *)
|
||||
type tag = Ref | ConstRef | ShallowCopy | ConstShallowCopy | DeepCopy | NoneRef;;
|
||||
(* MoveShallowCopy ? *)
|
||||
type data = int
|
||||
|
||||
type typ = UnitT | IntT | BoolT | RefT of typ | PairT of typ * typ;;
|
||||
type mode = InM | OutM | InOutM;;
|
||||
type arg = Arg of tag * mode * typ;;
|
||||
type tag = Ref | Value
|
||||
type stmt = Call of data * data list | Read of data | Write of data
|
||||
|
||||
type op = AddOp | SubOp | NotOp | LessOp | MoreOp | LessEqOp | MoreEqOp | EqOp | NotEqOp;;
|
||||
type body = stmt list
|
||||
|
||||
type expr = IntE of int
|
||||
| BoolE of bool
|
||||
| VarE of string
|
||||
(* pair *)
|
||||
| PairE of expr * expr
|
||||
| FstE of expr
|
||||
| SndE of expr
|
||||
(* pointers *)
|
||||
| DerefE of expr
|
||||
| RefE of expr;;
|
||||
type arg = data * tag
|
||||
type fun_decl = data * arg list * body
|
||||
|
||||
type stmt = DeclS of string * typ
|
||||
| AssignS of string * expr (* TODO: rvalue exprs *)
|
||||
| SeqS of stmt * stmt
|
||||
| ExprS of expr
|
||||
| CallS of string * string list (* TODO: exprs?? *)
|
||||
| IfS of expr * stmt * stmt;;
|
||||
|
||||
type func_def = {
|
||||
f_args: arg list;
|
||||
f_body: stmt;
|
||||
};;
|
||||
|
||||
type prog = {
|
||||
p_func: (string * func_def) list;
|
||||
p_code: stmt;
|
||||
};;
|
||||
|
||||
(* ------ *)
|
||||
|
||||
type value = IntV of int
|
||||
| BoolV of bool
|
||||
| BoxV of string (* ref to box, lvalue *)
|
||||
| RefV of value
|
||||
| PairV of value * value
|
||||
| UnitV;;
|
||||
|
||||
module M = Map.Make (String);;
|
||||
|
||||
type func_env = func_def M.t;;
|
||||
type 'a frame = {
|
||||
f_vars: 'a M.t;
|
||||
};;
|
||||
type 'a state = {
|
||||
s_func: func_env;
|
||||
s_frames: 'a frame list;
|
||||
(* s_value: 'a; *)
|
||||
};;
|
||||
|
||||
let init_state prog = { s_func = prog.p_func |> List.to_seq |> M.of_seq;
|
||||
s_frames = [];
|
||||
(* s_value = UnitV; *)
|
||||
};;
|
||||
|
||||
let find_func name state = M.find_opt name state.s_func
|
||||
|
||||
let find_frame_var name frame = M.find_opt name frame.f_vars;;
|
||||
let rec find_frames_var name frames =
|
||||
match frames with
|
||||
| [] -> None
|
||||
| fr :: frs -> (match find_frame_var name fr with
|
||||
| Some x -> Some x
|
||||
| None -> find_frames_var name frs);;
|
||||
let find_var name state = find_frames_var name state.s_frames;;
|
||||
|
||||
let add_var name value state =
|
||||
match state.s_frames with
|
||||
| [] -> failwith "No frames found"
|
||||
| fr :: frs -> { state with s_frames = {f_vars = M.add name value fr.f_vars} :: frs};;
|
||||
|
||||
let update_frame_var name value frame =
|
||||
if M.find_opt name frame.f_vars != None then Some {f_vars = M.add name value frame.f_vars} else None;;
|
||||
let rec update_frames_var name value frames =
|
||||
match frames with
|
||||
| [] -> None
|
||||
| fr :: frs -> (match update_frame_var name value fr with
|
||||
| Some fr -> Some (fr :: frs)
|
||||
| None -> Option.map (fun frs -> fr :: frs) @@ update_frames_var name value frs);;
|
||||
let update_var name value state =
|
||||
Option.map (fun frs -> {state with s_frames = frs}) @@
|
||||
update_frames_var name value state.s_frames ;;
|
||||
|
||||
let check_op_types expr state = ();;
|
||||
|
||||
(* TODO *)
|
||||
(* let ( let* ) = Option.bind;; *)
|
||||
|
||||
(* TODO *)
|
||||
(* TODO: handle refs in proper way *)
|
||||
(* NOTE: exprs are pure and do not change state *)
|
||||
let rec check_expr_types expr state =
|
||||
match expr with
|
||||
| IntE _ -> IntT
|
||||
| BoolE b -> BoolT
|
||||
| VarE name -> RefT (Option.get @@ find_var name state)
|
||||
(* pair *)
|
||||
| PairE (fst_e, snd_e) -> PairT (check_expr_types fst_e state, check_expr_types snd_e state)
|
||||
| FstE e ->
|
||||
(match check_expr_types e state with
|
||||
| PairT (t, _) -> t
|
||||
| _ -> failwith "Fst type error")
|
||||
| SndE e ->
|
||||
(match check_expr_types e state with
|
||||
| PairT (_, t) -> t
|
||||
| _ -> failwith "Snd type error")
|
||||
(* pointers *)
|
||||
| DerefE e ->
|
||||
(match check_expr_types e state with
|
||||
| RefT t -> t
|
||||
| _ -> failwith "Deref type eror")
|
||||
| RefE e -> RefT (check_expr_types e state);;
|
||||
|
||||
let expect_eq fst_val snd_val msg =
|
||||
if fst_val == snd_val then fst_val else failwith msg;;
|
||||
|
||||
let expect_neq fst_val snd_val msg =
|
||||
if fst_val != snd_val then fst_val else failwith msg;;
|
||||
|
||||
(* TODO *)
|
||||
let rec check_stmt_types stmt (state : typ state) =
|
||||
match stmt with
|
||||
| DeclS (name, typ) -> add_var name typ state
|
||||
| AssignS (name, val_e) ->
|
||||
let val_t = check_expr_types val_e state in
|
||||
(match find_var name state with
|
||||
| Some t -> ignore @@ expect_eq t val_t "Can't assign value of the different type"
|
||||
| None -> failwith "Varible to assign is not found");
|
||||
state
|
||||
| SeqS (fst_e, snd_e) ->
|
||||
let state = check_stmt_types fst_e state in
|
||||
check_stmt_types snd_e state
|
||||
| ExprS e -> ignore @@ check_expr_types e state; state
|
||||
| CallS (name, args) ->
|
||||
let func = find_func name state in
|
||||
(* (match *)
|
||||
(* ) *)
|
||||
failwith "Unimplemened"
|
||||
| IfS (cond_e, then_e, else_e) ->
|
||||
ignore @@ expect_eq (check_expr_types cond_e state) BoolT "If condition is not bool";
|
||||
failwith "Unimplemened"
|
||||
;;
|
||||
|
||||
(* TODO *)
|
||||
let parse str = ();;
|
||||
(* TODO *)
|
||||
let eval stmt state = ();;
|
||||
type prog = fun_decl list * body
|
||||
|
|
|
|||
169
lib/lib_next.ml
Normal file
169
lib/lib_next.ml
Normal file
|
|
@ -0,0 +1,169 @@
|
|||
open OCanren
|
||||
|
||||
(* TODO: lift to logic domain *)
|
||||
type tag = Ref | ConstRef | ShallowCopy | ConstShallowCopy | DeepCopy | NoneRef;;
|
||||
(* MoveShallowCopy ? *)
|
||||
|
||||
type typ = UnitT | IntT | BoolT | RefT of typ | PairT of typ * typ;;
|
||||
type mode = InM | OutM | InOutM;;
|
||||
type arg = {
|
||||
tag: tag;
|
||||
mode: mode;
|
||||
typ: typ;
|
||||
};;
|
||||
|
||||
type op = AddOp | SubOp | NotOp | LessOp | MoreOp | LessEqOp | MoreEqOp | EqOp | NotEqOp;;
|
||||
|
||||
type expr = IntE of int
|
||||
| BoolE of bool
|
||||
| VarE of string
|
||||
(* pair *)
|
||||
| PairE of expr * expr
|
||||
| FstE of expr
|
||||
| SndE of expr
|
||||
(* pointers *)
|
||||
| DerefE of expr
|
||||
| RefE of expr
|
||||
;; (* TODO: op *)
|
||||
|
||||
type stmt = DeclS of string * typ
|
||||
| AssignS of string * expr (* TODO: rvalue exprs *)
|
||||
| SeqS of stmt * stmt
|
||||
| ExprS of expr
|
||||
| CallS of string * string list (* TODO: exprs?? *)
|
||||
| IfS of expr * stmt * stmt;;
|
||||
|
||||
type func_def = {
|
||||
f_args: arg list;
|
||||
f_body: stmt;
|
||||
};;
|
||||
|
||||
type prog = {
|
||||
p_func: (string * func_def) list;
|
||||
p_code: stmt;
|
||||
};;
|
||||
|
||||
(* ------ *)
|
||||
|
||||
type value = IntV of int
|
||||
| BoolV of bool
|
||||
| BoxV of string (* ref to box, lvalue *)
|
||||
| RefV of value
|
||||
| PairV of value * value
|
||||
| UnitV;;
|
||||
|
||||
module M = Map.Make (String);;
|
||||
|
||||
type func_env = func_def M.t;;
|
||||
type 'a frame = {
|
||||
f_vars: 'a M.t;
|
||||
};;
|
||||
type 'a state = {
|
||||
s_func: func_env;
|
||||
s_frames: 'a frame list;
|
||||
(* s_value: 'a; *)
|
||||
};;
|
||||
|
||||
let init_state prog = { s_func = prog.p_func |> List.to_seq |> M.of_seq;
|
||||
s_frames = [];
|
||||
(* s_value = UnitV; *)
|
||||
};;
|
||||
|
||||
let find_func name state = M.find_opt name state.s_func
|
||||
|
||||
let find_frame_var name frame = M.find_opt name frame.f_vars;;
|
||||
let rec find_frames_var name frames =
|
||||
match frames with
|
||||
| [] -> None
|
||||
| fr :: frs -> (match find_frame_var name fr with
|
||||
| Some x -> Some x
|
||||
| None -> find_frames_var name frs);;
|
||||
let find_var name state = find_frames_var name state.s_frames;;
|
||||
|
||||
let add_var name value state =
|
||||
match state.s_frames with
|
||||
| [] -> failwith "No frames found"
|
||||
| fr :: frs -> { state with s_frames = {f_vars = M.add name value fr.f_vars} :: frs};;
|
||||
|
||||
let update_frame_var name value frame =
|
||||
if M.find_opt name frame.f_vars != None then Some {f_vars = M.add name value frame.f_vars} else None;;
|
||||
let rec update_frames_var name value frames =
|
||||
match frames with
|
||||
| [] -> None
|
||||
| fr :: frs -> (match update_frame_var name value fr with
|
||||
| Some fr -> Some (fr :: frs)
|
||||
| None -> Option.map (fun frs -> fr :: frs) @@ update_frames_var name value frs);;
|
||||
let update_var name value state =
|
||||
Option.map (fun frs -> {state with s_frames = frs}) @@
|
||||
update_frames_var name value state.s_frames ;;
|
||||
|
||||
let check_op_types expr state = ();;
|
||||
|
||||
(* TODO *)
|
||||
(* let ( let* ) = Option.bind;; *)
|
||||
|
||||
(* TODO *)
|
||||
(* TODO: handle refs in proper way *)
|
||||
(* NOTE: exprs are pure and do not change state *)
|
||||
let rec check_expr_types expr state =
|
||||
match expr with
|
||||
| IntE _ -> IntT
|
||||
| BoolE b -> BoolT
|
||||
| VarE name -> RefT (Option.get @@ find_var name state)
|
||||
(* pair *)
|
||||
| PairE (fst_e, snd_e) -> PairT (check_expr_types fst_e state, check_expr_types snd_e state)
|
||||
| FstE e ->
|
||||
(match check_expr_types e state with
|
||||
| PairT (t, _) -> t
|
||||
| _ -> failwith "Fst type error")
|
||||
| SndE e ->
|
||||
(match check_expr_types e state with
|
||||
| PairT (_, t) -> t
|
||||
| _ -> failwith "Snd type error")
|
||||
(* pointers *)
|
||||
| DerefE e ->
|
||||
(match check_expr_types e state with
|
||||
| RefT t -> t
|
||||
| _ -> failwith "Deref type eror")
|
||||
| RefE e -> RefT (check_expr_types e state);;
|
||||
|
||||
let expect_eq fst_val snd_val msg =
|
||||
if fst_val == snd_val then fst_val else failwith msg;;
|
||||
|
||||
let expect_neq fst_val snd_val msg =
|
||||
if fst_val != snd_val then fst_val else failwith msg;;
|
||||
|
||||
let expect_some value msg =
|
||||
if value != None then Option.get value else failwith msg;;
|
||||
|
||||
(* TODO *)
|
||||
let rec check_stmt_types stmt (state : typ state) =
|
||||
match stmt with
|
||||
| DeclS (name, typ) -> add_var name typ state
|
||||
| AssignS (name, val_e) ->
|
||||
let val_t = check_expr_types val_e state in
|
||||
(match find_var name state with
|
||||
| Some t -> ignore @@ expect_eq t val_t "Can't assign value of the different type"
|
||||
| None -> failwith "Varible to assign to is not found");
|
||||
state
|
||||
| SeqS (fst_s, snd_s) ->
|
||||
let state = check_stmt_types fst_s state in
|
||||
check_stmt_types snd_s state
|
||||
| ExprS e -> ignore @@ check_expr_types e state; state
|
||||
| CallS (name, args) ->
|
||||
let func = expect_some (find_func name state) "Called function not found" in
|
||||
List.iter2 (fun arg_t arg_v ->
|
||||
let arg_vt = expect_some (find_var arg_v state) "Call: arg var not found" in
|
||||
ignore @@ expect_eq arg_t.typ arg_vt "Call: wrong argument type"
|
||||
) func.f_args args;
|
||||
state
|
||||
| IfS (cond_e, then_s, else_s) ->
|
||||
ignore @@ expect_eq (check_expr_types cond_e state) BoolT "If condition is not bool";
|
||||
ignore @@ check_stmt_types then_s state;
|
||||
ignore @@ check_stmt_types else_s state;
|
||||
state
|
||||
|
||||
(* TODO *)
|
||||
let parse str = ();;
|
||||
(* TODO *)
|
||||
let eval stmt state = ();;
|
||||
Loading…
Add table
Add a link
Reference in a new issue