Skip to content

GitLab

Commit 6e644519 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-09-27 22:49:09 by cvscast] alternative evaluator (--compile) 

Original author: cvscast
Date: 2003-09-27 22:49:09+00:00
parent bb3efc53
Hide whitespace changes
Inline Side-by-side
Makefile.distrib
View file @ 6e644519
......@@ -92,10 +92,11 @@ OBJECTS = \
\
typing/typed.cmo typing/typer.cmo \
\
compile/lambda.cmo compile/compile.cmo \
compile/lambda.cmo \
\
runtime/load_xml.cmo runtime/run_dispatch.cmo \
runtime/print_xml.cmo runtime/eval.cmo \
compile/compile.cmo \
compile/operators.cmo \
\
types/builtin.cmo driver/cduce.cmo
......
compile/compile.ml
View file @ 6e644519
......@@ -8,30 +8,47 @@ type env = {
let empty = { vars = Env.empty; stack_size = 0 }
let rec compile env e = compile_aux env e.Typed.exp_descr
and compile_aux env = function
| Typed.Forget (e,_) -> compile env e
| Typed.Var x -> Var (Env.find x env.vars)
| Typed.Apply (e1,e2) -> Apply (compile env e1, compile env e2)
let find x env =
try Env.find x env.vars
with Not_found ->
failwith ("Compile: cannot find " ^ (Ident.to_string x))
let rec compile env tail e = compile_aux env tail e.Typed.exp_descr
and compile_aux env tail = function
| Typed.Forget (e,_) -> compile env tail e
| Typed.Var x -> Var (find x env)
| Typed.Apply (e1,e2) -> Apply (tail, compile env false e1, compile env tail e2)
| Typed.Abstraction a -> compile_abstr env a
| Typed.Cst c -> Const c
| Typed.Pair (e1,e2) -> Pair(compile env e1, compile env e2)
| Typed.Pair (e1,e2) -> Pair(compile env false e1, compile env tail e2)
| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) ->
let env' = env in
Xml (compile env e1, compile env' e2, compile env' e3)
Xml (compile env false e1, compile env false e2, compile env tail e3)
| Typed.Xml (_,_) -> assert false
| Typed.RecordLitt r -> Record (LabelMap.map (compile env) r)
| Typed.String (i,j,s,q) -> String (i,j,s,compile env q)
| Typed.Match (e,brs) -> Match (compile env e, compile_branches env brs)
| _ -> assert false
| Typed.RecordLitt r -> Record (LabelMap.map (compile env false) r)
| Typed.String (i,j,s,q) -> String (i,j,s,compile env tail q)
| Typed.Match (e,brs) -> Match (compile env false e, compile_branches env tail brs)
| Typed.Map (e,brs) -> Map (compile env false e, compile_branches env false brs)
| Typed.Transform (e,brs) -> Transform
(compile env false e, compile_branches env false brs)
| Typed.Xtrans (e,brs) -> Xtrans (compile env false e, compile_branches env false brs)
| Typed.Validate (e,sch,t) -> Validate (compile env tail e, sch, t)
| Typed.RemoveField (e,l) -> RemoveField (compile env tail e,l)
| Typed.Dot (e,l) -> Dot (compile env tail e, l)
| Typed.Try (e,brs) -> Try (compile env false e, compile_branches env tail brs)
| Typed.UnaryOp (op,e) -> UnaryOp (op, compile env tail e)
| Typed.BinaryOp (op,e1,e2) -> BinaryOp (op, compile env false e1, compile env tail e2)
| Typed.Ref (e,t) -> Ref (compile env tail e, t)
and compile_abstr env a =
let fun_env =
match a.Typed.fun_name with
| Some x -> Env.add x (Env 0) Env.empty
| None -> Env.empty in
let (slots,nb_slots,fun_env) =
List.fold_left
(fun (slots,nb_slots,fun_env) x ->
match Env.find x env.vars with
match find x env with
| (Stack _ | Env _) as p ->
p::slots,
succ nb_slots,
......@@ -42,30 +59,56 @@ and compile_abstr env a =
Env.add x p fun_env
| Dummy -> assert false
)
([],0,Env.empty) (IdSet.get a.Typed.fun_fv) in
([Dummy],1,fun_env) (IdSet.get a.Typed.fun_fv) in
let recurs,fun_env,slots = match a.Typed.fun_name with
| Some x when IdSet.mem a.Typed.fun_fv x ->
true, Env.add x (Env 0) fun_env, Dummy::slots
| _ -> false, fun_env, slots in
let slots = Array.of_list (List.rev slots) in
let env = { vars = fun_env; stack_size = 0 } in
let body = compile_branches env a.Typed.fun_body in
Abstraction (recurs, slots, a.Typed.fun_iface, body)
let body = compile_branches env true a.Typed.fun_body in
Abstraction (slots, a.Typed.fun_iface, body)
and compile_branches env (brs : Typed.branches) =
and compile_branches env tail (brs : Typed.branches) =
{
brs = List.map (compile_branch env) brs.Typed.br_branches;
brs = List.map (compile_branch env tail) brs.Typed.br_branches;
brs_tail = tail;
brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept);
brs_input = brs.Typed.br_typ;
brs_compiled = None
}
and compile_branch env br =
and compile_branch env tail br =
let env =
List.fold_left
(fun env x ->
{ vars = Env.add x (Stack env.stack_size) env.vars;
stack_size = env.stack_size + 1 }
) env (IdSet.get (Patterns.fv br.Typed.br_pat)) in
(br.Typed.br_pat, compile env br.Typed.br_body)
(br.Typed.br_pat, compile env tail br.Typed.br_body)
let enter_global env x =
{ vars = Env.add x (Global env.stack_size) env.vars;
stack_size = env.stack_size + 1 }
let enter_globals = List.fold_left enter_global
let compile_let_decl env decl =
let pat = decl.Typed.let_pat in
let decl = { let_pat = pat; let_expr = compile env false (decl.Typed.let_body) } in
let names = IdSet.get (Patterns.fv pat) in
let env = enter_globals env names in
(names, env, decl)
let compile_rec_funs env funs =
let fun_name = function
| { Typed.exp_descr=Typed.Abstraction{Typed.fun_name = Some x}} -> x
| _ -> assert false in
let fun_a = function
| { Typed.exp_descr=Typed.Abstraction a } -> a
| _ -> assert false in
let names = List.map fun_name funs in
let env = enter_globals env names in
let exprs = List.map (compile_abstr env) (List.map fun_a funs) in
(names, env, exprs)
compile/lambda.ml
View file @ 6e644519
......@@ -9,8 +9,8 @@ type var_loc =
type expr =
| Var of var_loc
| Apply of expr * expr
| Abstraction of bool * var_loc array * (Types.t * Types.t) list * branches
| Apply of bool * expr * expr
| Abstraction of var_loc array * (Types.t * Types.t) list * branches
| Const of Types.Const.t
| Pair of expr * expr
......@@ -26,64 +26,20 @@ type expr =
| RemoveField of expr * label
| Dot of expr * label
| Try of expr * branches
| UnaryOp of unary_op * expr
| BinaryOp of binary_op * expr
| Ref of expr * Types.t
and unary_op = id
and binary_op = id
| UnaryOp of int * expr
| BinaryOp of int * expr * expr
| Ref of expr * Types.Node.t
and branches = {
brs: (Patterns.node * expr) list;
brs_tail: bool;
brs_input: Types.t;
brs_accept_chars: bool;
mutable brs_compiled:
(Patterns.Compile.dispatcher * expr Patterns.Compile.rhs array) option
}
(*
(* Evaluator *)
let call_stack = ref []
let env = ref [| |]
let stack = ref (Array.create 1024 Value.Absent)
let global = ref (Array.create 1024 Value.Absent)
let frame = ref 0
let sp = ref 0
let set a i x =
let n = Array.length !a in
if i = n then (
let b = Array.create (n*2) Value.Absent in
Array.blit !a 0 b 0 n;
a := b
);
!a.(i) <- x
let eval_var env = function
| Env i -> env.(i)
| Global i -> !global.(i)
| Stack i -> !stack.(!frame + i)
| Dummy -> Value.Absent
let rec eval env = function
| Var x -> eval_var env x
| Apply (e1,e2) -> eval_apply (eval env e1) (eval env e2)
| Abstraction (recurs,slots,iface,body) ->
if recurs then
let local_env = Array.map (eval_var env) slots in
let a = Value.Abstraction (local_env,iface,body) in
local_env.(Array.length local_env - 1) <- a;
a
else
let local_env = Array.map eval_var slots in
Value.Abstraction (local_env,iface,body)
and eval_apply f arg =
match f with
| Value.Abstraction (local_env,_,body) -> eval_branches local_env body arg
| _ -> assert false
*)
type let_decl = {
let_pat : Patterns.node;
let_expr : expr;
}
depend
View file @ 6e644519
......@@ -128,8 +128,10 @@ typing/typer.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/builtin
types/types.cmx typing/typer.cmi
compile/lambda.cmo: misc/q_symbol.cmo types/ident.cmo types/patterns.cmi types/types.cmi
compile/lambda.cmx: misc/q_symbol.cmo types/ident.cmx types/patterns.cmx types/types.cmx
compile/compile.cmo: misc/q_symbol.cmo types/patterns.cmi typing/typed.cmo
compile/compile.cmx: misc/q_symbol.cmo types/patterns.cmx typing/typed.cmx
compile/compile.cmo: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo types/patterns.cmi \
typing/typed.cmo runtime/value.cmi
compile/compile.cmx: misc/q_symbol.cmo types/ident.cmx compile/lambda.cmx types/patterns.cmx \
typing/typed.cmx runtime/value.cmx
runtime/load_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi types/ident.cmo \
parser/location.cmi misc/ns.cmi runtime/value.cmi runtime/load_xml.cmi
runtime/load_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx types/ident.cmx \
......@@ -168,22 +170,22 @@ types/builtin.cmx: misc/q_symbol.cmo types/atoms.cmx types/builtin_defs.cmx type
parser/location.cmx misc/ns.cmx compile/operators.cmx \
runtime/print_xml.cmx types/sequence.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx types/builtin.cmi
driver/cduce.cmo: misc/q_symbol.cmo parser/ast.cmo types/builtin.cmi runtime/eval.cmi \
types/ident.cmo parser/location.cmi misc/ns.cmi parser/parser.cmi \
types/patterns.cmi types/sample.cmi misc/state.cmi typing/typed.cmo \
typing/typer.cmi types/types.cmi parser/ulexer.cmi runtime/value.cmi \
driver/cduce.cmi
driver/cduce.cmx: misc/q_symbol.cmo parser/ast.cmx types/builtin.cmx runtime/eval.cmx \
types/ident.cmx parser/location.cmx misc/ns.cmx parser/parser.cmx \
types/patterns.cmx types/sample.cmx misc/state.cmx typing/typed.cmx \
typing/typer.cmx types/types.cmx parser/ulexer.cmx runtime/value.cmx \
driver/cduce.cmi
driver/cduce.cmo: misc/q_symbol.cmo parser/ast.cmo types/builtin.cmi compile/compile.cmo \
runtime/eval.cmi types/ident.cmo parser/location.cmi misc/ns.cmi \
parser/parser.cmi types/patterns.cmi types/sample.cmi misc/state.cmi \
typing/typed.cmo typing/typer.cmi types/types.cmi parser/ulexer.cmi \
runtime/value.cmi driver/cduce.cmi
driver/cduce.cmx: misc/q_symbol.cmo parser/ast.cmx types/builtin.cmx compile/compile.cmx \
runtime/eval.cmx types/ident.cmx parser/location.cmx misc/ns.cmx \
parser/parser.cmx types/patterns.cmx types/sample.cmx misc/state.cmx \
typing/typed.cmx typing/typer.cmx types/types.cmx parser/ulexer.cmx \
runtime/value.cmx driver/cduce.cmi
driver/run.cmo: misc/q_symbol.cmo driver/cduce.cmi types/ident.cmo runtime/load_xml.cmi \
parser/location.cmi types/sequence.cmi misc/serialize.cmi misc/state.cmi \
misc/stats.cmi parser/ulexer.cmi runtime/value.cmi
parser/location.cmi types/sequence.cmi misc/state.cmi misc/stats.cmi \
parser/ulexer.cmi runtime/value.cmi
driver/run.cmx: misc/q_symbol.cmo driver/cduce.cmx types/ident.cmx runtime/load_xml.cmx \
parser/location.cmx types/sequence.cmx misc/serialize.cmx misc/state.cmx \
misc/stats.cmx parser/ulexer.cmx runtime/value.cmx
parser/location.cmx types/sequence.cmx misc/state.cmx misc/stats.cmx \
parser/ulexer.cmx runtime/value.cmx
driver/webiface.cmo: misc/q_symbol.cmo driver/cduce.cmi driver/examples.cmo parser/location.cmi \
misc/state.cmi
driver/webiface.cmx: misc/q_symbol.cmo driver/cduce.cmx driver/examples.cmx parser/location.cmx \
......
driver/cduce.ml
View file @ 6e644519
......@@ -6,11 +6,25 @@ let toplevel = ref false
let typing_env = State.ref "Cduce.typing_env" Builtin.env
let eval_env = State.ref "Cduce.eval_env" Env.empty
let compile_env = State.ref "Cduce.compile_env" Compile.empty
let do_compile = ref false
let get_global_value v =
if !do_compile
then Eval.L.eval_var (Compile.find v !compile_env)
else Env.find v !eval_env
let get_global_type v =
Typer.find_value v !typing_env
let enter_global_value x v t =
eval_env := Env.add x v !eval_env;
typing_env := Typer.enter_value x t !typing_env
typing_env := Typer.enter_value x t !typing_env;
if !do_compile
then (compile_env := Compile.enter_global !compile_env x; Eval.L.push v)
else eval_env := Env.add x v !eval_env
let rec is_abstraction = function
| Ast.Abstraction _ -> true
| Ast.LocatedExpr (_,e) -> is_abstraction e
......@@ -42,7 +56,8 @@ let dump_env ppf =
Format.fprintf ppf "@[val %a : @[%a = %a@]@]@."
U.print (Id.value x) print_norm t print_value v
)
!eval_env
!eval_env;
Eval.L.dump ppf
let rec print_exn ppf = function
| Location (loc, w, exn) ->
......@@ -140,6 +155,15 @@ let insert_bindings ppf =
if not !quiet then
Format.fprintf ppf "val %a : @[@[%a@] =@ @[%a@]@]@."
U.print (Id.value x) print_norm t print_value v)
let display ppf =
List.iter
(fun x ->
let t = get_global_type x in
let v = get_global_value x in
if not !quiet then
Format.fprintf ppf "val %a : @[@[%a@] =@ @[%a@]@]@."
U.print (Id.value x) print_norm t print_value v)
let rec collect_funs ppf accu = function
| { descr = Ast.FunDecl e } :: rest ->
......@@ -148,8 +172,17 @@ let rec collect_funs ppf accu = function
| rest ->
let typs = Typer.type_rec_funs !typing_env accu in
Typer.report_unused_branches ();
let vals = Eval.eval_rec_funs !eval_env accu in
insert_bindings ppf typs vals;
if !do_compile then
let (names,env,funs) = Compile.compile_rec_funs !compile_env accu in
Eval.L.eval_rec_funs funs;
typing_env := Typer.enter_values typs !typing_env;
compile_env := env;
display ppf names
else (
let vals = Eval.eval_rec_funs !eval_env accu in
insert_bindings ppf typs vals);
rest
let rec collect_types ppf accu = function
......@@ -175,18 +208,38 @@ let rec phrases ppf phs = match phs with
let (fv,e) = Typer.expr !typing_env e in
let t = Typer.type_check !typing_env e Types.any true in
Typer.report_unused_branches ();
if not !quiet then
Location.dump_loc ppf (e.Typed.exp_loc,`Full);
let v = Eval.eval !eval_env e in
if not !quiet then
Format.fprintf ppf "- : @[@[%a@] =@ @[%a@]@]@." print_norm t print_value v;
if !do_compile then
let e = Compile.compile !compile_env false e in
let v = Eval.L.eval e in
if not !quiet then
Format.fprintf ppf "- : @[@[%a@] =@ @[%a@]@]@."
print_norm t print_value v;
else
(let v = Eval.eval !eval_env e in
if not !quiet then
Format.fprintf ppf "- : @[@[%a@] =@ @[%a@]@]@."
print_norm t print_value v );
phrases ppf rest
| { descr = Ast.LetDecl (p,e) } :: rest ->
let decl = Typer.let_decl !typing_env p e in
let typs = Typer.type_let_decl !typing_env decl in
Typer.report_unused_branches ();
let vals = Eval.eval_let_decl !eval_env decl in
insert_bindings ppf typs vals;
if !do_compile then
let (names,env,decl) = Compile.compile_let_decl !compile_env decl in
Eval.L.eval_let_decl decl;
typing_env := Typer.enter_values typs !typing_env;
compile_env := env;
display ppf names
else
(let vals = Eval.eval_let_decl !eval_env decl in
insert_bindings ppf typs vals);
phrases ppf rest
| { descr = Ast.Debug l } :: rest ->
debug ppf l;
......
driver/cduce.mli
View file @ 6e644519
val quiet: bool ref
val toplevel: bool ref
val do_compile: bool ref
val enter_global_value : Ident.id -> Value.t -> Types.descr -> unit
val script : Format.formatter -> Format.formatter -> char Stream.t -> bool
......
driver/run.ml
View file @ 6e644519
......@@ -32,6 +32,8 @@ let specs =
" specify persistency file for loading and saving";
"--quiet", Arg.Set Cduce.quiet,
" suppress normal output (typing, results)";
"--compile", Arg.Set Cduce.do_compile,
" activate compilation";
"--stdin", Arg.Unit (fun () -> src := "" :: !src),
" read CDuce script on standard input";
"--verbose", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary),
......
runtime/eval.ml
View file @ 6e644519
......@@ -245,3 +245,276 @@ and eval_map env brs = function
*)
(* Evaluator for "compiled" expressions *)
module L = struct
open Lambda
let dispatcher brs =
match brs.brs_compiled with
| Some d -> d
| None ->
let x = Patterns.Compile.make_branches brs.brs_input brs.brs in
brs.brs_compiled <- Some x;
x
let stack = ref (Array.create 1024 Value.Absent)
let frame = ref 0
let sp = ref 0
let dump ppf =
Format.fprintf ppf "sp = %i frame = %i@." !sp !frame;
for i = 0 to !sp - 1 do
if i = !frame then Format.fprintf ppf "FRAME@.";
Format.fprintf ppf "%a@." Value.print !stack.(i)
done
let ensure a i =
let n = Array.length !a in
if i = n then (
let b = Array.create (max (n*2) i) Value.Absent in
Array.blit !a 0 b 0 n;
a := b
)
let set a i x =
ensure a i;
!a.(i) <- x
let push x =
set stack !sp x;
incr sp
let calls = ref 0
let eval_var env = function
| Env i -> env.(i)
| Global i -> !stack.(i)
| Stack i -> !stack.(!frame + i)
| Dummy -> Value.Absent
let rec eval env = function
| Var x -> eval_var env x
| Apply (false,e1,e2) ->
let v1 = eval env e1 in
let v2 = eval env e2 in
eval_apply v1 v2
| Apply (true,e1,e2) ->
let v1 = eval env e1 in
let v2 = eval env e2 in
eval_apply_tail_rec v1 v2
| Abstraction (slots,iface,body) -> eval_abstraction env slots iface body
| Const c -> Value.const c
| Pair (e1,e2) ->
let v1 = eval env e1 in
let v2 = eval env e2 in
Value.Pair (v1,v2)
| Xml (e1,e2,e3) ->
let v1 = eval env e1 in
let v2 = eval env e2 in
let v3 = eval env e3 in
Value.Xml (v1,v2,v3)
| Record r -> Value.Record (LabelMap.map (eval env) r)
| String (i,j,s,q) -> Value.String_utf8 (i,j,s,eval env q)
| Match (e,brs) -> eval_branches env brs (eval env e)
| Map (arg,brs) -> eval_map env brs (eval env arg)
| Xtrans (arg,brs) -> eval_xtrans env brs (eval env arg)
| Try (arg,brs) -> eval_try env arg brs
| Transform (arg,brs) -> eval_transform env brs (eval env arg)
| Dot (e, l) -> eval_dot l (eval env e)
| RemoveField (e, l) -> eval_remove_field l (eval env e)
| UnaryOp (op,e) -> !eval_unary_op op (eval env e)
| BinaryOp (op,e1,e2) ->
let v1 = eval env e1 in
let v2 = eval env e2 in
!eval_binary_op op v1 v2
| Validate (e, schema, name) -> eval_validate env e schema name
| Ref (e,t) -> eval_ref env e t
and eval_abstraction env slots iface body =
let local_env = Array.map (eval_var env) slots in
let a = Value.Abstraction2 (local_env,iface,body) in
local_env.(0) <- a;
a
and eval_apply f arg =
(* Format.fprintf Format.std_formatter
"Apply %i@." !calls;
incr calls;*)
match f with
| Value.Abstraction2 (local_env,_,body) ->
let saved_frame = !frame and saved_sp = !sp in
frame := !sp;
let v = eval_branches local_env body arg in
frame := saved_frame;
sp := saved_sp;
v
| Value.Abstraction (_,f) -> f arg
| _ -> assert false
and eval_apply_tail_rec f arg =
(* Format.fprintf Format.std_formatter
"Apply tail %i@." !calls;
incr calls;*)
match f with
| Value.Abstraction2 (local_env,_,body) ->
sp := !frame;
eval_branches local_env body arg
| Value.Abstraction (_,f) -> f arg
| _ -> assert false
and eval_branches env brs arg =
let (disp, rhs) = dispatcher brs in
let (code, bindings) = Run_dispatch.run_dispatcher disp arg in
match rhs.(code) with
| Patterns.Compile.Match (bind,e) ->
let saved_sp = !sp in
IdMap.iter
(fun i -> push (if (i == -1) then arg else bindings.(i)))
bind;
if brs.brs_tail
then eval env e
else
let v = eval env e in
sp := saved_sp;
v
| Patterns.Compile.Fail -> Value.Absent
and eval_ref env e t=
let r = ref (eval env e) in
let get =
Value.Abstraction ([Sequence.nil_type, Types.descr t], fun _ -> !r)
and set =
Value.Abstraction
([Types.descr t, Sequence.nil_type], fun x -> r := x; nil) in
Value.Record (Builtin_defs.mk_ref ~get ~set)
and eval_validate env e schema name =
let validator = Typer.get_schema_validator (schema, name) in
Schema_validator.validate ~validator
(Schema_xml.pxp_stream_of_value (eval env e))
and eval_try env arg brs =
let saved_frame = !frame and saved_sp = !sp in
try eval env arg
with (CDuceExn v) as exn ->
frame := saved_frame;
sp := saved_sp;
match eval_branches env brs v with
| Value.Absent -> raise exn
| x -> x
and eval_map env brs v =
map (eval_map_aux env brs) v
and eval_map_aux env brs acc = function
| Value.Pair (x,y) ->
let x = eval_branches env brs x in
let acc' = Value.Pair (x, Absent) in
set_cdr acc acc';
eval_map_aux env brs acc' y
| Value.String_latin1 (_,_,_,_) | Value.String_utf8 (_,_,_,_) as v ->
eval_map_aux env brs acc (normalize v)
| _ -> acc
and eval_transform env brs v =
map (eval_transform_aux env brs) v
and eval_transform_aux env brs acc = function
| Value.Pair (x,y) ->
(match eval_branches env brs x with