From 5f754e3f883b468953a73afd8a12b279a3a5c2b8 Mon Sep 17 00:00:00 2001 From: Grégoire Duchêne Date: Sat, 27 Sep 2014 15:33:20 +0200 Subject: Moved the code into src/ --- .gitignore | 2 +- Common.ml | 200 ----------------------- Environment.ml | 52 ------ GNUmakefile | 3 +- Interpreter.ml | 464 ----------------------------------------------------- Tamasheq.ml | 148 ----------------- helpers.c | 108 ------------- src/Common.ml | 200 +++++++++++++++++++++++ src/Environment.ml | 52 ++++++ src/Interpreter.ml | 464 +++++++++++++++++++++++++++++++++++++++++++++++++++++ src/Tamasheq.ml | 148 +++++++++++++++++ src/helpers.c | 108 +++++++++++++ 12 files changed, 975 insertions(+), 974 deletions(-) delete mode 100644 Common.ml delete mode 100644 Environment.ml delete mode 100644 Interpreter.ml delete mode 100644 Tamasheq.ml delete mode 100644 helpers.c create mode 100644 src/Common.ml create mode 100644 src/Environment.ml create mode 100644 src/Interpreter.ml create mode 100644 src/Tamasheq.ml create mode 100644 src/helpers.c diff --git a/.gitignore b/.gitignore index 059891a..3b1c938 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,5 @@ *.cmi *.cmo +*.d *.o -.Makefile.dep tamasheq diff --git a/Common.ml b/Common.ml deleted file mode 100644 index a477b58..0000000 --- a/Common.ml +++ /dev/null @@ -1,200 +0,0 @@ -(* -Copyright (c) 2014, Grégoire Duchêne - -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 deleted file mode 100644 index dab9bce..0000000 --- a/Environment.ml +++ /dev/null @@ -1,52 +0,0 @@ -(* -Copyright (c) 2014, Grégoire Duchêne - -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 index 13f3608..1cabcc1 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -1,5 +1,6 @@ CFLAGS+= -Wall -Werror -D_GNU_SOURCE -std=c99 -CSRC= helpers.c +CSRC= src/helpers.c +EXCL= ostumake tests PKG= bigarray compiler-libs.bytecomp compiler-libs.common PKG+= compiler-libs.toplevel PROG= tamasheq diff --git a/Interpreter.ml b/Interpreter.ml deleted file mode 100644 index 63067d5..0000000 --- a/Interpreter.ml +++ /dev/null @@ -1,464 +0,0 @@ -(* -Copyright (c) 2014, Grégoire Duchêne - -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 deleted file mode 100644 index ebd8d7c..0000000 --- a/Tamasheq.ml +++ /dev/null @@ -1,148 +0,0 @@ -(* -Copyright (c) 2014, Grégoire Duchêne - -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) , " Run "; - "-o" , String (fun s -> outdir := s) , " Output files in "; - "--" , 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 deleted file mode 100644 index 27e9430..0000000 --- a/helpers.c +++ /dev/null @@ -1,108 +0,0 @@ -/* -Copyright (c) 2014, Grégoire Duchêne - -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 -#include -#include -#include - -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; -} diff --git a/src/Common.ml b/src/Common.ml new file mode 100644 index 0000000..a477b58 --- /dev/null +++ b/src/Common.ml @@ -0,0 +1,200 @@ +(* +Copyright (c) 2014, Grégoire Duchêne + +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/src/Environment.ml b/src/Environment.ml new file mode 100644 index 0000000..dab9bce --- /dev/null +++ b/src/Environment.ml @@ -0,0 +1,52 @@ +(* +Copyright (c) 2014, Grégoire Duchêne + +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/src/Interpreter.ml b/src/Interpreter.ml new file mode 100644 index 0000000..63067d5 --- /dev/null +++ b/src/Interpreter.ml @@ -0,0 +1,464 @@ +(* +Copyright (c) 2014, Grégoire Duchêne + +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/src/Tamasheq.ml b/src/Tamasheq.ml new file mode 100644 index 0000000..ebd8d7c --- /dev/null +++ b/src/Tamasheq.ml @@ -0,0 +1,148 @@ +(* +Copyright (c) 2014, Grégoire Duchêne + +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) , " Run "; + "-o" , String (fun s -> outdir := s) , " Output files in "; + "--" , 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/src/helpers.c b/src/helpers.c new file mode 100644 index 0000000..27e9430 --- /dev/null +++ b/src/helpers.c @@ -0,0 +1,108 @@ +/* +Copyright (c) 2014, Grégoire Duchêne + +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 +#include +#include +#include + +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; +} -- cgit v1.2.3-70-g09d2