diff options
| -rw-r--r-- | Common.ml | 200 | ||||
| -rw-r--r-- | Environment.ml | 52 | ||||
| -rw-r--r-- | GNUmakefile | 7 | ||||
| -rw-r--r-- | Interpreter.ml | 464 | ||||
| -rw-r--r-- | Tamasheq.ml | 148 | ||||
| -rw-r--r-- | helpers.c | 108 |
6 files changed, 979 insertions, 0 deletions
diff --git a/Common.ml b/Common.ml new file mode 100644 index 0000000..a477b58 --- /dev/null +++ b/Common.ml @@ -0,0 +1,200 @@ +(* +Copyright (c) 2014, Grégoire Duchêne <gduchene@awhk.org> + +Permission to use, copy, modify, and/or distribute this software for +any purpose with or without fee is hereby granted, provided that the +above copyright notice and this permission notice appear in all +copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL +WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE +AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL +DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR +PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. +*) + +open Bigarray + +type bigstr = (char, int8_unsigned_elt, c_layout) Array1.t +type id = Ident.t +type term = Lambda.lambda +type value = Obj.t + +type _ ty = + | TyAny : 'a ty + | TyArray : value array ty + | TyBigStr : bigstr ty + | TyBool : bool ty + | TyChar : char ty + | TyExn : exn ty + | TyFloat : float ty + | TyInt : int ty + | TyInt32 : int32 ty + | TyInt64 : int64 ty + | TyLazy : value Lazy.t ty + | TyNatInt : nativeint ty + | TyStr : string ty + | TyUnit : unit ty + +let ( @$ ) f x = + f x + +let ( --> ) x y = + x, y + +let ( >> ) g f x = f (g x) + +let any = TyAny +let array = TyArray +let bigstr = TyBigStr +let bool = TyBool +let char = TyChar +let exn = TyExn +let float = TyFloat +let int = TyInt +let int32 = TyInt32 +let int64 = TyInt64 +let lazy' = TyLazy +let natint = TyNatInt +let str = TyStr +let unit = TyUnit + +external bittest : string -> int -> int = "caml_bitvect_test" + +external bswap16 : int -> int = "caml_bswap16" +external bbswap32 : int32 -> int32 = "caml_int32_bswap" +external bbswap64 : int64 -> int64 = "caml_int64_bswap" +external bbswapnative : nativeint -> nativeint = "caml_nativeint_bswap" + +external dup : 'a -> 'a = "caml_obj_dup" + +external e_bigstr_get_16 : bigstr -> int -> char = "caml_ba_uint8_get16" +external e_bigstr_get_32 : bigstr -> int -> char = "caml_ba_uint8_get32" +external e_bigstr_get_64 : bigstr -> int -> char = "caml_ba_uint8_get64" + +external e_bigstr_set_16 : bigstr -> int -> char -> unit = "caml_ba_uint8_get16" +external e_bigstr_set_32 : bigstr -> int -> char -> unit = "caml_ba_uint8_get32" +external e_bigstr_set_64 : bigstr -> int -> char -> unit = "caml_ba_uint8_get64" + +external e_str_get_16 : string -> int -> char = "caml_string_get16" +external e_str_get_32 : string -> int -> char = "caml_string_get32" +external e_str_get_64 : string -> int -> char = "caml_string_get64" + +external e_str_set_16 : string -> int -> char -> unit = "caml_string_set16" +external e_str_set_32 : string -> int -> char -> unit = "caml_string_set32" +external e_str_set_64 : string -> int -> char -> unit = "caml_string_set64" + +external tamasheq_call_1 : string -> 'a -> 'b + = "tamasheq_call_1" + +external tamasheq_call_2 : string -> 'a -> 'b -> 'c + = "tamasheq_call_2" + +external tamasheq_call_3 : string -> 'a -> 'b -> 'c -> 'd + = "tamasheq_call_3" + +external tamasheq_call_4 : string -> 'a -> 'b -> 'c -> 'd -> 'e + = "tamasheq_call_4" + +external tamasheq_call_5 : string -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f + = "tamasheq_call_5" + +external tamasheq_sys_init : string -> string array -> unit + = "tamasheq_sys_init" + +let array_of_queue queue = + let queue = Queue.copy queue in + let array = Array.make (Queue.length queue) @$ Queue.peek queue in + + for i = 0 to Array.length array - 1 do + array.(i) <- Queue.pop queue + done; + + array + +let bigstr_get_n prim unsafe bigstr i = + if not unsafe && (i < 0 || i >= Array1.dim bigstr) then + failwith "bigstr_get_n" + ; + + prim bigstr i + +let bigstr_get_16 = bigstr_get_n e_bigstr_get_16 +let bigstr_get_32 = bigstr_get_n e_bigstr_get_32 +let bigstr_get_64 = bigstr_get_n e_bigstr_get_64 + +let bigstr_set_n prim unsafe bigstr i v = + if not unsafe && (i < 0 || i >= Array1.dim bigstr) then + failwith "bigstr_get_n" + ; + + prim bigstr i v + +let bigstr_set_16 = bigstr_set_n e_bigstr_set_16 +let bigstr_set_32 = bigstr_set_n e_bigstr_set_32 +let bigstr_set_64 = bigstr_set_n e_bigstr_set_64 + +let str_get_n prim unsafe str i = + if not unsafe && (i < 0 || i >= String.length str) then + failwith "str_get_n" + ; + + prim str i + +let str_get_16 = str_get_n e_str_get_16 +let str_get_32 = str_get_n e_str_get_32 +let str_get_64 = str_get_n e_str_get_64 + +let str_set_n prim unsafe str i v = + if not unsafe && (i < 0 || i >= String.length str) then + failwith "str_set_n" + ; + + prim str i v + +let str_set_16 = str_set_n e_str_set_16 +let str_set_32 = str_set_n e_str_set_32 +let str_set_64 = str_set_n e_str_set_64 + +let sprintf = Printf.sprintf + +let module_name = + Misc.chop_extension_if_any >> Filename.basename >> String.capitalize + +let pp = Format.formatter_of_out_channel stdout + +let id_not_found id = + failwith (sprintf "unknown ID ``%s''" (Ident.name id)) + +let unsupported_arity expected got = + failwith (sprintf "unsupported arity (expected %d, got %d)" expected got) + +let unsupported_lambda_term t = + failwith "unsupported lambda term" + +let cast (type a) (ty : a ty) (v : value) : a = + Obj.obj v + +let lift (type a) (type b) + ((a, b) : a ty * b ty) + (f : a -> b) : value list -> value = + function + | [x] -> Obj.repr @$ f (cast a x) + | xs -> raise @$ unsupported_arity 1 @$ List.length xs + +let lift2 (type a) (type b) (type c) + (((a, b), c) : (a ty * b ty) * c ty) + (f : a -> b -> c) : value list -> value = + function + | [x; y] -> Obj.repr @$ f (cast a x) (cast b y) + | xs -> unsupported_arity 3 @$ List.length xs + +let lift3 (type a) (type b) (type c) (type d) + ((((a, b), c), d) : ((a ty * b ty) * c ty) * d ty) + (f : a -> b -> c -> d) : value list -> value = + function + | [x; y; z] -> Obj.repr @$ f (cast a x) (cast b y) (cast c z) + | xs -> unsupported_arity 3 @$ List.length xs diff --git a/Environment.ml b/Environment.ml new file mode 100644 index 0000000..dab9bce --- /dev/null +++ b/Environment.ml @@ -0,0 +1,52 @@ +(* +Copyright (c) 2014, Grégoire Duchêne <gduchene@awhk.org> + +Permission to use, copy, modify, and/or distribute this software for +any purpose with or without fee is hereby granted, provided that the +above copyright notice and this permission notice appear in all +copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL +WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE +AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL +DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR +PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. +*) + +open Common + +type t = { + global : (id, value) Hashtbl.t; + lexical : (id * value ref) list; +} + +let assign_lexical env id v = + List.assoc id env.lexical := v + +let bind_global env id v = + Hashtbl.add env.global id v + +let bind_lexical env id v = + { env with lexical = (id, ref v) :: env.lexical } + +let bind_lexical_all env l = + List.fold_left (fun env (id, v) -> bind_lexical env id v) env l + +let fresh () = + { global = Hashtbl.create 10; lexical = []; } + +let lookup_global env id = + try Hashtbl.find env.global id + with Not_found -> + try Symtable.get_global_value id + with Symtable.Error e -> id_not_found id + +let lookup_lexical env id = + try !(List.assoc id env.lexical) + with Not_found -> id_not_found id + +let lookup_lexical_str env id = + !(snd @$ List.find (fun (id', _) -> id = id'.Ident.name) env.lexical) diff --git a/GNUmakefile b/GNUmakefile new file mode 100644 index 0000000..13f3608 --- /dev/null +++ b/GNUmakefile @@ -0,0 +1,7 @@ +CFLAGS+= -Wall -Werror -D_GNU_SOURCE -std=c99 +CSRC= helpers.c +PKG= bigarray compiler-libs.bytecomp compiler-libs.common +PKG+= compiler-libs.toplevel +PROG= tamasheq + +include ostumake/gnu.ocaml.prog.mk diff --git a/Interpreter.ml b/Interpreter.ml new file mode 100644 index 0000000..63067d5 --- /dev/null +++ b/Interpreter.ml @@ -0,0 +1,464 @@ +(* +Copyright (c) 2014, Grégoire Duchêne <gduchene@awhk.org> + +Permission to use, copy, modify, and/or distribute this software for +any purpose with or without fee is hereby granted, provided that the +above copyright notice and this permission notice appear in all +copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL +WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE +AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL +DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR +PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. +*) + +open Asttypes +open Bigarray +open Common +open Environment +open Lambda +open Printf + +let nil = Obj.repr () + +let rec apply_fun f args = + let f = ((Obj.obj f) : 'a -> 'b) in + + match args with + | [] -> assert false + | [x] -> Obj.repr @$ f x + | x :: xs -> apply_fun (Obj.repr @$ f x) xs + +let rec eval env ks t = + match t with + | Lapply (body, args, loc) -> eval_apply env ks body args loc + + | Lassign (id, t) -> + assign_lexical env id @$ eval env ks t; + nil + + | Lconst const -> eval_const const + + | Levent (t, _) -> eval env ks t + + | Lfor (index, low, high, dir, body) -> + eval_for env ks index low high dir body + + | Lfunction (kind, ids, body) -> eval_fun env ks kind ids body + | Lifthenelse (pred, succ, fail) -> eval_if env ks pred succ fail + | Lifused _ -> unsupported_lambda_term t + + | Llet (_, id, def, body) -> + eval (bind_lexical env id @$ eval env ks def) ks body + + | Lletrec (defs, body) -> + eval_let_rec env ks defs body + + (* special case for predefined exceptions *) + | Lprim (Pmakeblock (tag, _), + (Lprim (Pgetglobal id, []) :: args)) when Ident.global id -> + let args = eval_all env ks args in + + begin + match Ident.name id with + | "Assert_failure" -> + let f s i j = Assert_failure (s, i, j) in + + lift3 (str --> int --> int --> exn) f args + + | "Division_by_zero" -> Obj.repr Division_by_zero + | "End_of_file" -> Obj.repr End_of_file + + | "Failure" -> + let f s = Failure s in + + lift (str --> exn) f args + + | "Invalid_arg" -> + let f s = Invalid_argument s in + + lift (str --> exn) f args + + | "Match_failure" -> + let f s i j = Match_failure (s, i, j) in + + lift3 (str --> int --> int --> exn) f args + + | "Not_found" -> Obj.repr Not_found + | "Stack_overflow" -> Obj.repr Stack_overflow + | "Sys_blocked_io" -> Obj.repr Sys_blocked_io + + | "Sys_error" -> + let f s = Sys_error s in + + lift (str --> exn) f args + + | "Undefined_recursive_module" -> + let f s i j = Undefined_recursive_module (s, i, j) in + + lift3 (str --> int --> int --> exn) f args + + | _ -> + failwith @$ sprintf "unknown global ``%s''!" @$ Ident.name id + end + + | Lprim (kind, ts) -> eval_prim env kind @$ eval_all env ks ts + + | Lsequence (fst, snd) -> + ignore @$ eval env ks fst; + eval env ks snd + + | Lsend _ -> unsupported_lambda_term t + + | Lstaticcatch (body, (tag, ids), hdl) -> eval_catch env ks body tag ids hdl + | Lstaticraise (tag, args) -> eval_raise ks tag args + + | Lswitch (body, switch) -> eval_switch env ks body switch + | Ltrywith (body, id, hdl) -> eval_try_with env ks body id hdl + | Lvar id -> lookup_lexical env id + | Lwhile (pred, body) -> eval_while env ks pred body + +and eval_all env ks ts = + List.map (eval env ks) ts + +and eval_apply env ks body args loc = + apply_fun (eval env ks body) @$ eval_all env ks args + +and eval_catch env ks body tag ids k = + eval env ((tag, eval_fun env ks Curried ids k) :: ks) body + +and eval_const = function + | Const_base (Const_int x) -> Obj.repr x + | Const_base (Const_char x) -> Obj.repr x + | Const_base (Const_float x) -> Obj.repr x + | Const_base (Const_int32 x) -> Obj.repr x + | Const_base (Const_int64 x) -> Obj.repr x + | Const_base (Const_string x) -> Obj.repr x + | Const_base (Const_nativeint x) -> Obj.repr x + + | Const_block (tag, cs) -> + let blk = Obj.new_block tag @$ List.length cs in + + List.iteri (fun i c -> Obj.set_field blk i @$ eval_const c) cs; + blk + + | Const_float_array fs -> + Obj.repr @$ Array.of_list @$ List.map float_of_string fs + + | Const_immstring x -> Obj.repr x + | Const_pointer x -> Obj.repr x + +and eval_for env ks index low high dir body = + let low = cast TyInt @$ eval env ks low in + let high = cast TyInt @$ eval env ks high in + + match dir with + | Asttypes.Upto -> + for x = low to high do + ignore @$ eval (bind_lexical env index @$ Obj.repr x) ks body + done; + + nil + + | Asttypes.Downto -> + for x = low downto high do + ignore @$ eval (bind_lexical env index @$ Obj.repr x) ks body + done; + + nil + +and eval_fun env ks kind ids body = + Obj.repr @$ + match ids with + | [] -> assert false + | [id] -> fun x -> eval (bind_lexical env id x) ks body + | id :: ids -> fun x -> eval_fun (bind_lexical env id x) ks kind ids body + +and eval_if env ks pred succ fail = + let next = + match cast TyInt @$ eval env ks pred with + | 0 -> fail + | _ -> succ + in + + eval env ks next + +and eval_let_rec env ks defs body = + let nils = List.map (fun (id, _) -> id, nil) defs in + let env = bind_lexical_all env nils in + let f (id, body) = assign_lexical env id @$ eval env ks body in + + List.iter f defs; + eval env ks body + +and eval_prim env kind vs = + match kind with + | Pbittest -> lift2 (str --> int --> int) bittest vs + + | Pbigarraydim n -> lift (any --> int) (fun a -> Genarray.nth_dim a n) vs + + | Pbbswap Pint32 -> lift (int32 --> int32 ) bbswap32 vs + | Pbbswap Pint64 -> lift (int64 --> int64 ) bbswap64 vs + | Pbbswap Pnativeint -> lift (natint --> natint) bbswapnative vs + | Pbswap16 -> lift (int --> int ) bswap16 vs + + | Pnegint -> lift (int --> int) ( ~- ) vs + | Paddint -> lift2 (int --> int --> int) ( + ) vs + | Psubint -> lift2 (int --> int --> int) ( - ) vs + | Pmulint -> lift2 (int --> int --> int) ( * ) vs + | Pdivint -> lift2 (int --> int --> int) ( / ) vs + | Pmodint -> lift2 (int --> int --> int) ( mod ) vs + | Pandint -> lift2 (int --> int --> int) ( land ) vs + | Porint -> lift2 (int --> int --> int) ( lor ) vs + | Pxorint -> lift2 (int --> int --> int) ( lxor ) vs + | Plslint -> lift2 (int --> int --> int) ( lsl ) vs + | Plsrint -> lift2 (int --> int --> int) ( lsr ) vs + | Pasrint -> lift2 (int --> int --> int) ( asr ) vs + | Psequand -> lift2 (bool --> bool --> bool) ( && ) vs + | Psequor -> lift2 (bool --> bool --> bool) ( || ) vs + + | Pintcomp Ceq -> lift2 (int --> int --> bool) ( = ) vs + | Pintcomp Cneq -> lift2 (int --> int --> bool) ( <> ) vs + | Pintcomp Clt -> lift2 (int --> int --> bool) ( < ) vs + | Pintcomp Cgt -> lift2 (int --> int --> bool) ( > ) vs + | Pintcomp Cle -> lift2 (int --> int --> bool) ( <= ) vs + | Pintcomp Cge -> lift2 (int --> int --> bool) ( >= ) vs + | Pfloatcomp Ceq -> lift2 (float --> float --> bool) ( = ) vs + | Pfloatcomp Cneq -> lift2 (float --> float --> bool) ( <> ) vs + | Pfloatcomp Clt -> lift2 (float --> float --> bool) ( < ) vs + | Pfloatcomp Cgt -> lift2 (float --> float --> bool) ( > ) vs + | Pfloatcomp Cle -> lift2 (float --> float --> bool) ( <= ) vs + | Pfloatcomp Cge -> lift2 (float --> float --> bool) ( >= ) vs + | Pintoffloat -> lift (float --> int ) int_of_float vs + | Pfloatofint -> lift (int --> float) float_of_int vs + | Pnegfloat -> lift (float --> float) ( ~-. ) vs + | Pabsfloat -> lift (float --> float) abs_float vs + | Paddfloat -> lift2 (float --> float --> float) ( +. ) vs + | Psubfloat -> lift2 (float --> float --> float) ( -. ) vs + | Pmulfloat -> lift2 (float --> float --> float) ( *. ) vs + | Pdivfloat -> lift2 (float --> float --> float) ( /. ) vs + + | Pstringlength -> lift (str --> int) String.length vs + | Pstringrefu -> lift2 (str --> int --> char) String.unsafe_get vs + | Pstringrefs -> lift2 (str --> int --> char) String.get vs + | Pstringsetu -> lift3 (str --> int --> char --> unit) String.unsafe_set vs + | Pstringsets -> lift3 (str --> int --> char --> unit) String.set vs + + | Pfield i -> + lift (any --> any) (fun blk -> Obj.field blk i) vs + + | Psetfield (i, _) -> + lift2 (any --> any --> unit) (fun blk v -> Obj.set_field blk i v) vs + + | Plazyforce -> lift (lazy' --> any) Lazy.force vs + + | Pmakearray _ -> Obj.repr @$ Array.of_list @$ List.map Obj.repr vs + + | Pmakeblock (tag, _) -> + let blk = Obj.new_block tag @$ List.length vs in + + List.iteri (fun i v -> Obj.set_field blk i v) vs; + blk + + | Parraylength _ -> lift (array --> int) Array.length vs + | Parrayrefu _ -> lift2 (array --> int --> any) Array.unsafe_get vs + | Parrayrefs _ -> lift2 (array --> int --> any) (fun a i -> a.(i)) vs + | Parraysetu _ -> lift3 (array --> int --> any --> unit) Array.unsafe_set vs + | Parraysets _ -> lift3 (array --> int --> any --> unit) (fun a i e -> a.(i) <- e) vs + + | Pisint -> lift (any --> bool) Obj.is_int vs + + | Pbintofint Pint32 -> lift (int --> int32 ) Int32.of_int vs + | Pbintofint Pint64 -> lift (int --> int64 ) Int64.of_int vs + | Pbintofint Pnativeint -> lift (int --> natint) Nativeint.of_int vs + | Pintofbint Pint32 -> lift (int32 --> int) Int32.to_int vs + | Pintofbint Pint64 -> lift (int64 --> int) Int64.to_int vs + | Pintofbint Pnativeint -> lift (natint --> int) Nativeint.to_int vs + + | Pcvtbint (Pint64, Pint32 ) -> lift (int64 --> int32 ) Int64.to_int32 vs + | Pcvtbint (Pint32, Pint64 ) -> lift (int32 --> int64 ) Int64.of_int32 vs + | Pcvtbint (Pnativeint, Pint32) -> lift (natint --> int32 ) Nativeint.to_int32 vs + | Pcvtbint (Pnativeint, Pint64) -> lift (natint --> int64 ) Int64.of_nativeint vs + | Pcvtbint (Pint32, Pnativeint) -> lift (int32 --> natint) Nativeint.of_int32 vs + | Pcvtbint (Pint64, Pnativeint) -> lift (int64 --> natint) Int64.to_nativeint vs + | Pcvtbint _ -> assert false + + | Pnegbint Pint32 -> lift (int32 --> int32 ) Int32.neg vs + | Pnegbint Pint64 -> lift (int64 --> int64 ) Int64.neg vs + | Pnegbint Pnativeint -> lift (natint --> natint) Nativeint.neg vs + + | Paddbint Pint32 -> lift2 (int32 --> int32 --> int32 ) Int32.add vs + | Paddbint Pint64 -> lift2 (int64 --> int64 --> int64 ) Int64.add vs + | Paddbint Pnativeint -> lift2 (natint --> natint --> natint) Nativeint.add vs + + | Psubbint Pint32 -> lift2 (int32 --> int32 --> int32 ) Int32.sub vs + | Psubbint Pint64 -> lift2 (int64 --> int64 --> int64 ) Int64.sub vs + | Psubbint Pnativeint -> lift2 (natint --> natint --> natint) Nativeint.sub vs + + | Pmulbint Pint32 -> lift2 (int32 --> int32 --> int32 ) Int32.mul vs + | Pmulbint Pint64 -> lift2 (int64 --> int64 --> int64 ) Int64.mul vs + | Pmulbint Pnativeint -> lift2 (natint --> natint --> natint) Nativeint.mul vs + + | Pdivbint Pint32 -> lift2 (int32 --> int32 --> int32 ) Int32.div vs + | Pdivbint Pint64 -> lift2 (int64 --> int64 --> int64 ) Int64.div vs + | Pdivbint Pnativeint -> lift2 (natint --> natint --> natint) Nativeint.div vs + + | Pmodbint Pint32 -> lift2 (int32 --> int32 --> int32 ) Int32.rem vs + | Pmodbint Pint64 -> lift2 (int64 --> int64 --> int64 ) Int64.rem vs + | Pmodbint Pnativeint -> lift2 (natint --> natint --> natint) Nativeint.rem vs + + | Pandbint Pint32 -> lift2 (int32 --> int32 --> int32 ) Int32.logand vs + | Pandbint Pint64 -> lift2 (int64 --> int64 --> int64 ) Int64.logand vs + | Pandbint Pnativeint -> lift2 (natint --> natint --> natint) Nativeint.logand vs + + | Porbint Pint32 -> lift2 (int32 --> int32 --> int32 ) Int32.logor vs + | Porbint Pint64 -> lift2 (int64 --> int64 --> int64 ) Int64.logor vs + | Porbint Pnativeint -> lift2 (natint --> natint --> natint) Nativeint.logor vs + + | Pxorbint Pint32 -> lift2 (int32 --> int32 --> int32 ) Int32.logxor vs + | Pxorbint Pint64 -> lift2 (int64 --> int64 --> int64 ) Int64.logxor vs + | Pxorbint Pnativeint -> lift2 (natint --> natint --> natint) Nativeint.logxor vs + + | Plslbint Pint32 -> lift2 (int32 --> int --> int32 ) Int32.shift_left vs + | Plslbint Pint64 -> lift2 (int64 --> int --> int64 ) Int64.shift_left vs + | Plslbint Pnativeint -> lift2 (natint --> int --> natint) Nativeint.shift_left vs + + | Plsrbint Pint32 -> lift2 (int32 --> int --> int32 ) Int32.shift_right_logical vs + | Plsrbint Pint64 -> lift2 (int64 --> int --> int64 ) Int64.shift_right_logical vs + | Plsrbint Pnativeint -> lift2 (natint --> int --> natint) Nativeint.shift_right_logical vs + + | Pasrbint Pint32 -> lift2 (int32 --> int --> int32 ) Int32.shift_right vs + | Pasrbint Pint64 -> lift2 (int64 --> int --> int64 ) Int64.shift_right vs + | Pasrbint Pnativeint -> lift2 (natint --> int --> natint) Nativeint.shift_right vs + + | Pnot -> lift (bool --> bool) not vs + + | Pbintcomp (kind, cmp) -> + let cmp_op f x y = match cmp with + | Ceq -> f x y = 0 + | Cneq -> f x y <> 0 + | Clt -> f x y < 0 + | Cgt -> f x y > 0 + | Cle -> f x y <= 0 + | Cge -> f x y >= 0 + in + let lift = + match kind with + | Pint32 -> lift2 (int32 --> int32 --> bool) (cmp_op Int32.compare ) + | Pint64 -> lift2 (int64 --> int64 --> bool) (cmp_op Int64.compare ) + | Pnativeint -> lift2 (natint --> natint --> bool) (cmp_op Nativeint.compare) + in + + lift vs + + | Pstring_load_16 unsafe -> + lift2 (str --> int --> char) (str_get_16 unsafe) vs + + | Pstring_load_32 unsafe -> + lift2 (str --> int --> char) (str_get_32 unsafe) vs + + | Pstring_load_64 unsafe -> + lift2 (str --> int --> char) (str_get_64 unsafe) vs + + | Pstring_set_16 unsafe -> + lift3 (str --> int --> char --> unit) (str_set_16 unsafe) vs + + | Pstring_set_32 unsafe -> + lift3 (str --> int --> char --> unit) (str_set_32 unsafe) vs + + | Pstring_set_64 unsafe -> + lift3 (str --> int --> char --> unit) (str_set_64 unsafe) vs + + | Pbigstring_load_16 unsafe -> + lift2 (bigstr --> int --> char) (bigstr_get_16 unsafe) vs + + | Pbigstring_load_32 unsafe -> + lift2 (bigstr --> int --> char) (bigstr_get_32 unsafe) vs + + | Pbigstring_load_64 unsafe -> + lift2 (bigstr --> int --> char) (bigstr_get_64 unsafe) vs + + | Pbigstring_set_16 unsafe -> + lift3 (bigstr --> int --> char --> unit) (bigstr_set_16 unsafe) vs + + | Pbigstring_set_32 unsafe -> + lift3 (bigstr --> int --> char --> unit) (bigstr_set_32 unsafe) vs + + | Pbigstring_set_64 unsafe -> + lift3 (bigstr --> int --> char --> unit) (bigstr_set_64 unsafe) vs + + | Pctconst Big_endian -> Obj.repr @$ Sys.big_endian + | Pctconst Word_size -> Obj.repr @$ Sys.word_size + | Pctconst Ostype_unix -> Obj.repr @$ Sys.unix + | Pctconst Ostype_win32 -> Obj.repr @$ Sys.win32 + | Pctconst Ostype_cygwin -> Obj.repr @$ Sys.cygwin + + | Pccall call -> + let name = call.Primitive.prim_name in + + Obj.repr @$ + begin + match call.Primitive.prim_arity with + | 0 -> assert false + | 1 -> lift (any --> any) (tamasheq_call_1 name) vs + | 2 -> lift2 (any --> any --> any) (tamasheq_call_2 name) vs + | 3 -> lift3 (any --> any --> any --> any) (tamasheq_call_3 name) vs + + | 4 -> + begin + match vs with + | [x1; x2; x3; x4] -> tamasheq_call_4 name x1 x2 x3 x4 + | xs -> unsupported_arity 4 @$ List.length xs + end + + | 5 -> + begin + match vs with + | [x1; x2; x3; x4; x5] -> tamasheq_call_5 name x1 x2 x3 x4 x5 + | xs -> unsupported_arity 5 @$ List.length xs + end + + | n -> + failwith @$ sprintf "unhandled arity %d" n + end + + | Pduprecord _ -> lift (any --> any) dup vs + | Pgetglobal id -> lookup_global env id + | Pidentity -> lift (any --> any) (fun x -> x) vs + | Pignore -> nil + | Pisout -> lift2 (int --> int --> bool) ( < ) vs + | Poffsetint i -> lift (int --> int ) (fun j -> i + j ) vs + | Poffsetref i -> lift (any --> unit) (fun r -> r := !r + 1) vs + | Praise -> lift (exn --> any) raise vs + | Psetglobal id -> lift (any --> unit) (bind_global env id) vs + +and eval_raise ks tag args = + try apply_fun (List.assoc tag ks) args + with Not_found -> failwith "unknown continuation tag" + +and eval_switch env ks body switch = + let body = eval env ks body in + + try + if Obj.is_block body then + eval env ks @$ List.assoc (Obj.tag body) switch.sw_blocks + else + eval env ks @$ List.assoc (cast TyInt body) switch.sw_consts + with exn -> + match switch.sw_failaction with + | None -> raise exn + | Some action -> eval env ks action + +and eval_try_with env ks body id hdl = + try eval env ks body + with exn -> eval (bind_lexical env id @$ Obj.repr exn) ks hdl + +and eval_while env ks pred body = + while cast TyBool @$ eval env ks pred do + ignore @$ eval env ks body + done; + nil diff --git a/Tamasheq.ml b/Tamasheq.ml new file mode 100644 index 0000000..ebd8d7c --- /dev/null +++ b/Tamasheq.ml @@ -0,0 +1,148 @@ +(* +Copyright (c) 2014, Grégoire Duchêne <gduchene@awhk.org> + +Permission to use, copy, modify, and/or distribute this software for +any purpose with or without fee is hereby granted, provided that the +above copyright notice and this permission notice appear in all +copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL +WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE +AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL +DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR +PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. +*) + +open Arg +open Common +open Interpreter + +let argsk = Queue.create () +let denv = ref false +let dlam = ref false +let files = Queue.create () +let hooks = Queue.create () +let intfs = Queue.create () +let outdir = ref "." + +let load_mli filename outdir = + let open Pparse in + let open Typedtree in + + Location.input_name := filename; + Compmisc.init_path false; + Clflags.debug := true; + + let input = preprocess filename in + let mname = module_name filename in + + Env.set_unit_name mname; + + let env = Compmisc.initial_env () in + + try + let tsg = + Typemod.transl_signature env @$ + file pp input Parse.interface Config.ast_intf_magic_number + in + + Typecore.force_delayed_checks (); + + let output = outdir ^ "/" ^ mname in + let sg = Env.save_signature tsg.sig_type mname (output ^ ".cmi") in + + ignore @$ Typemod.save_signature mname tsg output filename env sg + with + | Env.Error msg -> + Env.report_error pp msg; + failwith "fatal error" + + | Typetexp.Error (_, _, msg) -> + Typetexp.report_error env pp msg; + failwith "fatal error" + +let load_ml filename outdir = + let open Config in + let open Pparse in + + Location.input_name := filename; + Compmisc.init_path false; + Clflags.debug := true; + + let input = preprocess filename in + let mname = module_name filename in + + Env.set_unit_name mname; + Typecore.reset_delayed_checks (); + + let env = Compmisc.initial_env () in + + try + let filename = (Filename.chop_extension filename) ^ ".ml" in + + file pp input Parse.implementation ast_intf_magic_number + |> Typemod.type_implementation filename (outdir ^ "/" ^ mname) mname env + |> Translmod.transl_implementation mname + |> Simplif.simplify_lambda + with + | Env.Error msg -> + Env.report_error pp msg; + failwith "fatal error" + + | Typetexp.Error (_, _, msg) -> + Typetexp.report_error env pp msg; + failwith "fatal error" + +let load_mlis filenames outdir = + Queue.iter (fun filename -> load_mli filename outdir) filenames + +let load_mls filenames outdir = + List.rev @$ Queue.fold (fun acc s -> load_ml s outdir :: acc) [] filenames + +let () = + let args = [ + "-denv", Unit (fun () -> denv := not (!denv)), " Print the environment"; + "-dlam", Unit (fun () -> denv := not (!dlam)), " Print the Lambda AST"; + "-h" , String (fun s -> Queue.add s hooks) , "<hook> Run <hook>"; + "-o" , String (fun s -> outdir := s) , "<dir> Output files in <dir>"; + "--" , Rest (fun s -> Queue.add s argsk) , " (undocumented)"; + ] + in + let anon_arg s = + if Filename.check_suffix s "cma" || Filename.check_suffix s "cmo" then + try ignore (Topdirs.load_file Format.err_formatter s) + with Lexer.Error (msg, _) -> Lexer.report_error pp msg + else + let mli = (Filename.chop_extension s) ^ ".mli" in + + if Sys.file_exists mli then + Queue.add mli intfs + ; + + Queue.add s files + in + + parse (align args) anon_arg "Usage:"; + Clflags.include_dirs := !outdir :: !Clflags.include_dirs; + + if Queue.is_empty files then + begin + prerr_endline "you must specify at last one .ml file"; + usage (align args) "Usage:" + end + else + begin + load_mlis intfs !outdir; + + let env = Environment.fresh () in + let lambda = load_mls files !outdir in + + if !dlam then + List.iter (Printlambda.lambda pp >> Format.print_newline) lambda + ; + + List.iter (fun l -> ignore @$ eval env [] l) lambda + end diff --git a/helpers.c b/helpers.c new file mode 100644 index 0000000..27e9430 --- /dev/null +++ b/helpers.c @@ -0,0 +1,108 @@ +/* +Copyright (c) 2014, Grégoire Duchêne <gduchene@awhk.org> + +Permission to use, copy, modify, and/or distribute this software for +any purpose with or without fee is hereby granted, provided that the +above copyright notice and this permission notice appear in all +copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL +WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE +AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL +DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR +PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. +*/ + +#include <caml/fail.h> +#include <caml/mlvalues.h> +#include <dlfcn.h> +#include <string.h> + +typedef value (*caml_1)(value); +typedef value (*caml_2)(value, value); +typedef value (*caml_3)(value, value, value); +typedef value (*caml_4)(value, value, value, value); +typedef value (*caml_5)(value, value, value, value, value); + +extern void caml_sys_init(char *, char **); + +CAMLprim value +tamasheq_call_1(value fname, value arg) +{ + caml_1 f; + + if ((f = dlsym(RTLD_DEFAULT, String_val(fname))) == NULL) + caml_failwith(dlerror()); + + return f(arg); +} + +CAMLprim value +tamasheq_call_2(value fname, value arg1, value arg2) +{ + caml_2 f; + + if ((f = dlsym(RTLD_DEFAULT, String_val(fname))) == NULL) + caml_failwith(dlerror()); + + return f(arg1, arg2); +} + +CAMLprim value +tamasheq_call_3(value fname, value arg1, value arg2, value arg3) +{ + caml_3 f; + + if ((f = dlsym(RTLD_DEFAULT, String_val(fname))) == NULL) + caml_failwith(dlerror()); + + return f(arg1, arg2, arg3); +} + +CAMLprim value +tamasheq_call_4(value fname, value arg1, value arg2, value arg3, value arg4) +{ + caml_4 f; + + if ((f = dlsym(RTLD_DEFAULT, String_val(fname))) == NULL) + caml_failwith(dlerror()); + + return f(arg1, arg2, arg3, arg4); +} + +CAMLprim value +tamasheq_call_5(value *args, int argc) +{ + caml_5 f; + + if (argc != 6) + caml_failwith("unhandled arity"); + + if ((f = dlsym(RTLD_DEFAULT, String_val(args[0]))) == NULL) + caml_failwith(dlerror()); + + return f(args[1], args[2], args[3], args[4], args[5]); +} + +CAMLprim value +tamasheq_sys_init(value exe_name, value argv, value sz) +{ + static char *tamasheq_exe_name; + static char **tamasheq_argv; + + size_t i, rsz = Int_val(sz); + + if ((tamasheq_argv = calloc(rsz + 1, sizeof(*tamasheq_argv))) == NULL) + caml_failwith("not enough memory"); + + tamasheq_exe_name = strdup(String_val(exe_name)); + + for (i = 0; i < rsz; ++i) + tamasheq_argv[i] = strdup(String_val(Field(argv, i))); + + caml_sys_init(tamasheq_exe_name, tamasheq_argv); + return Val_unit; +} |