Skip to content

GitLab

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

[r2005-03-21 13:31:43 by afrisch] Remove Compile2 

Original author: afrisch
Date: 2005-03-21 13:31:44+00:00
parent 0e13bca6
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 3 additions and 1410 deletions
compile/compile.ml
View file @ 6fd7a218
......@@ -137,7 +137,7 @@ and compile_branches env tail (brs : Typed.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; brs_compiled2 = None
brs_compiled = None;
}
and compile_branch env tail br =
......
compile/lambda.ml
View file @ 6fd7a218
......@@ -74,8 +74,6 @@ and branches = {
brs_accept_chars: bool;
mutable brs_compiled:
(Patterns.Compile.dispatcher * expr Patterns.Compile.rhs array) option;
mutable brs_compiled2:
(Patterns.Compile2.dispatcher * (int list * expr) option array) option;
}
let rec dump_expr ppf = function
......@@ -371,8 +369,7 @@ module Get = struct
let accept_chars = bool s in
{ brs = brs; brs_tail = tail; brs_input = input;
brs_accept_chars = accept_chars;
brs_compiled = None; brs_compiled2 = None
}
brs_compiled = None }
let code_item s =
match bits 2 s with
......
compile/lambda.mli
View file @ 6fd7a218
......@@ -48,8 +48,6 @@ and branches = {
brs_accept_chars: bool;
mutable brs_compiled:
(Patterns.Compile.dispatcher * expr Patterns.Compile.rhs array) option;
mutable brs_compiled2:
(Patterns.Compile2.dispatcher * (int list * expr) option array) option;
}
type code_item =
......
driver/cduce.ml
View file @ 6fd7a218
......@@ -223,21 +223,6 @@ let debug ppf tenv cenv = function
with
| Exit -> Format.fprintf ppf "Non constant@."
| Not_found -> Format.fprintf ppf "Empty@.")
| `Approx (p,t) ->
Format.fprintf ppf "[DEBUG:approx]@.";
let t = Typer.typ tenv t in
let p = Typer.pat tenv p in
Patterns.demo ppf (Patterns.descr p) (Types.descr t);
(*
let (x,c) = Patterns.approx (Patterns.descr p) (Types.descr t) in
List.iter (fun x -> Format.fprintf ppf "%a=* " U.print (Id.value x)) x;
List.iter
(fun (x,c) ->
Format.fprintf ppf "%a=%a "
U.print (Id.value x)
Types.Print.print_const c
) c; *)
Format.fprintf ppf "@."
let flush_ppf ppf = Format.fprintf ppf "@."
......
parser/ast.ml
View file @ 6fd7a218
......@@ -24,7 +24,6 @@ and debug_directive =
| `Subtype of ppat * ppat
| `Explain of ppat * ppat * pexpr
| `Single of ppat
| `Approx of ppat * ppat
]
and toplevel_directive =
[ `Quit
......
parser/parser.ml
View file @ 6fd7a218
......@@ -213,7 +213,6 @@ EXTEND
| IDENT "subtype"; t1 = pat; t2 = pat -> `Subtype (t1,t2)
| IDENT "explain"; t0 = pat; t = pat; e = expr -> `Explain (t0,t,e)
| IDENT "single"; t = pat -> `Single t
| IDENT "approx"; p = pat; t = pat -> `Approx (p,t)
]
];
......
runtime/eval.ml
View file @ 6fd7a218
......@@ -37,16 +37,6 @@ let dispatcher brs =
brs.brs_compiled <- Some x;
x
let dispatcher2 brs =
match brs.brs_compiled2 with
| Some d -> d
| None ->
(* Format.fprintf Format.std_formatter "Start compilation...@."; *)
let x = Patterns.Compile2.make_branches brs.brs_input brs.brs in
(* Format.fprintf Format.std_formatter "Done.@."; *)
brs.brs_compiled2 <- Some x;
x
let stack = ref (Array.create 1024 Value.Absent)
let frame = ref 0
let sp = ref 0
......@@ -198,9 +188,7 @@ and eval_apply_tail_rec f arg =
and eval_branches env brs arg = eval_branches_old env brs arg
and eval_branches_old env brs arg =
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
......@@ -217,24 +205,6 @@ and eval_branches_old env brs arg =
v
| Patterns.Compile.Fail -> Value.Absent
and eval_branches_new env brs arg =
let (disp, rhs) = dispatcher2 brs in
let (code, bindings) = Run_dispatch.run_dispatcher2 disp arg in
match rhs.(code) with
| Some (bind,e) ->
let saved_sp = !sp in
List.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
| None -> Value.Absent
and eval_ref env e t=
Value.mk_ref (Types.descr t) (eval env e)
......
runtime/run_dispatch.ml
View file @ 6fd7a218
......@@ -335,9 +335,6 @@ let run_dispatcher d v =
cursor := 0;
(code,!buffer)
let old_dispatcher = run_dispatcher
(*
let rec check_overwrite_aux r i =
if i < 0 then true
......@@ -352,255 +349,3 @@ let check_overwrite r2 r =
*)
(* New dispatcher *)
open Patterns.Compile2
let make_result_basic v (code,r) =
let n = Array.length r in
if n > 0 then (
ensure_room n;
let buf = !buffer in
for a = 0 to n - 1 do
buf.(!cursor) <- begin match Array.unsafe_get r a with
| SrcCapture -> v
| SrcCst c -> const c
| _ -> assert false
end;
incr cursor
done);
code
let make_result_prod v1 r1 v2 r2 v (code,r) =
let n = Array.length r in
if n > 0 then (
ensure_room n;
let buf = !buffer in
let c = !cursor in
for a = 0 to n - 1 do
buf.(c + a) <- match Array.unsafe_get r a with
| SrcCapture -> v
| SrcLeft -> v1
| SrcRight -> v2
| SrcCst c -> const c
| SrcFetchLeft i -> buf.(r1+i)
| SrcFetchRight i -> buf.(r2+i)
| SrcPair (l,r) ->
Pair (
(match l with
| SrcLeft -> v1 | SrcRight -> v2
| SrcFetchLeft i -> buf.(r1+i)
| SrcFetchRight i -> buf.(r2+i) | _ -> assert false),
(match r with
| SrcLeft -> v1 | SrcRight -> v2
| SrcFetchLeft i -> buf.(r1+i)
| SrcFetchRight i -> buf.(r2+i) | _ -> assert false))
| _ -> assert false
done;
if r1 != c then blit buf c buf r1 n;
cursor := r1 + n);
code
let make_result_record sp v (code,r) =
let n = Array.length r in
if n > 0 then (
ensure_room n;
let buf = !buffer in
let c = !cursor in
for a = 0 to n - 1 do
buf.(c + a) <- match Array.unsafe_get r a with
| SrcLocal i -> buf.(sp+i)
| _ -> assert false
done;
if sp != c then blit buf c buf sp n;
cursor := sp + n);
code
let rec run_disp_basic v f = function
| [(_,r)] -> make_result_basic v r
| (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
| _ -> assert false
let count = ref 0
let rec run_dispatcher d v =
(* Format.fprintf Format.std_formatter "Matching (%a)@." Value.print v; *)
(* Patterns.Compile.print_dispatcher Format.std_formatter d; *)
(* print_string "."; flush stdout; *)
(* incr count;
print_int !count;
print_string "X"; flush stdout;
if !count = 9685 then
Format.fprintf Format.std_formatter "Matching (%a)@\n with:@\n%a@."
Value.print v
Patterns.Compile2.print_dispatcher d;*)
let res =
match actions d with
| AResult r -> make_result_basic v r
| AKind k -> run_disp_kind k v
in
(* print_string "Y"; flush stdout;*)
res
and run_disp_kind actions v =
match v with
| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
| Xml (v1,v2,v3) | XmlNs (v1,v2,v3,_) ->
run_disp_prod v v1 (Pair (v2,v3)) actions.xml
| Record r -> run_disp_record !cursor false v (LabelMap.get r) actions.record
| String_latin1 (i,j,s,q) ->
run_disp_kind actions (Value.normalize v)
(* run_disp_string_latin1 i j s q actions *)
| String_utf8 (i,j,s,q) as v ->
run_disp_kind actions (Value.normalize v)
(* run_disp_string_utf8 i j s q actions *)
| Atom a -> make_result_basic v (Atoms.get_map a actions.atoms)
| Char c -> make_result_basic v (Chars.get_map c actions.chars)
| Integer i ->
run_disp_basic v (fun t -> Types.Int.has_int t i) actions.basic
| Abstraction (None,_) ->
run_disp_basic v (fun t -> failwith "Run-time inspection of external abstraction")
actions.basic
| Abstraction (Some iface,_)
| Abstraction2 (_,iface,_) ->
run_disp_basic v (fun t -> Types.Arrow.check_iface iface t)
actions.basic
| Abstract (abs,_) ->
run_disp_basic v (fun t -> Types.Abstract.contains abs (Types.get_abstract t))
actions.basic
| Absent ->
run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
| Concat (_,_) as v -> run_disp_kind actions (Value.normalize v)
and run_disp_prod v v1 v2 = function
| Impossible -> assert false
| LeftRight rdd -> run_disp_prod' v v1 v2 rdd
| RightLeft rdd -> run_disp_prod' v v2 v1 rdd
and run_disp_prod' v v1 v2 = function
| Dispatch (d1,b1) ->
let r1 = !cursor in
let code1 = run_dispatcher d1 v1 in
run_disp_prod2 v1 r1 v v2 b1.(code1)
| TailCall d1 -> run_dispatcher d1 v1
| Ignore d2 -> run_disp_prod2 v1 !cursor v v2 d2
and run_disp_prod2 v1 r1 v v2 = function
| Ignore r -> make_result_prod v1 r1 v2 !cursor v r
| TailCall d2 -> run_dispatcher d2 v2
| Dispatch (d2,b2) ->
let r2 = !cursor in
let code2 = run_dispatcher d2 v2 in
make_result_prod v1 r1 v2 r2 v b2.(code2)
and do_pushes v vl = function
| [] -> ()
| PushConst c :: rem -> push (const c); do_pushes v vl rem
| PushField :: rem -> push vl; do_pushes v vl rem
| PushCapture :: rem -> push v; do_pushes v vl rem
and do_record_tr sp other v vl fields tr =
let (pushes,ct) = Lazy.force tr in
(* print_string "*"; flush stdout; *)
do_pushes v vl pushes;
run_disp_record sp other v fields ct
and run_disp_record sp other v fields = function
| RecordLabel (l,d,cts) ->
let rec aux other = function
| (l1,_) :: rem when l1 < l -> aux true rem
| (l1,vl) :: rem when l1 == l ->
do_record_tr sp other v vl rem cts.(run_dispatcher d vl)
| rem ->
do_record_tr sp other v Absent rem cts.(run_dispatcher d Absent)
in
aux other fields
| RecordLabelSkip (l,pr) ->
let rec aux other = function
| (l1,_) :: rem when l1 < l -> aux true rem
| (l1,vl) :: rem when l1 == l -> do_record_tr sp other v vl rem pr
| rem -> do_record_tr sp other v Absent rem pr
in
aux other fields
| RecordResult r ->
make_result_record sp v r
| RecordMore (nomore,more) ->
let other = other || (fields != []) in
make_result_record sp v (if other then more else nomore)
| RecordImpossible -> assert false
(*
and run_disp_string_latin1 i j s q actions =
if i == j then run_disp_kind actions q
else match actions.prod with
| Impossible -> assert false
| TailCall d1 -> run_disp_string_latin1_char d1 (Chars.V.mk_char s.[i])
| Ignore d2 -> run_disp_string_latin1_2 !cursor i j s q d2
| Dispatch (d1,b1) ->
let r1 = !cursor in
let code1 = run_disp_string_latin1_char d1 (Chars.V.mk_char s.[i]) in
run_disp_string_latin1_2 r1 i j s q b1.(code1)
and run_disp_string_latin1_char d ch =
match actions d with
| AIgnore r -> make_result_char ch r
| AKind k -> make_result_char ch (Chars.get_map ch k.chars)
and run_disp_string_latin1_2 r1 i j s q = function
| Impossible -> assert false
| Ignore r ->
make_result_string_latin1 i j s q r1 0 r
| TailCall d2 -> run_disp_string_latin1_loop i j s q d2
| Dispatch (d2,b2) ->
let r2 = !cursor in
let code2 = run_disp_string_latin1_loop i j s q d2 in
make_result_string_latin1 i j s q r1 r2 b2.(code2)
and run_disp_string_latin1_loop i j s q d =
match actions d with
| AIgnore r -> make_result_basic Absent r
| AKind k -> run_disp_string_latin1 (succ i) j s q k
and run_disp_string_utf8 i j s q actions =
if Utf8.equal_index i j then run_disp_kind actions q
else match actions.prod with
| Impossible -> assert false
| TailCall d1 -> run_disp_string_utf8_char d1 (Chars.V.mk_int (Utf8.get s i))
| Ignore d2 -> run_disp_string_utf8_2 !cursor i j s q d2
| Dispatch (d1,b1) ->
let r1 = !cursor in
let code1 = run_disp_string_utf8_char d1 (Chars.V.mk_int (Utf8.get s i)) in
run_disp_string_utf8_2 r1 i j s q b1.(code1)
and run_disp_string_utf8_char d ch =
match actions d with
| AIgnore r -> make_result_char ch r
| AKind k -> make_result_char ch (Chars.get_map ch k.chars)
and run_disp_string_utf8_2 r1 i j s q = function
| Impossible -> assert false
| Ignore r ->
make_result_string_utf8 i j s q r1 0 r
| TailCall d2 -> run_disp_string_utf8_loop i j s q d2
| Dispatch (d2,b2) ->
let r2 = !cursor in
let code2 = run_disp_string_utf8_loop i j s q d2 in
make_result_string_utf8 i j s q r1 r2 b2.(code2)
and run_disp_string_utf8_loop i j s q d =
match actions d with
| AIgnore r -> make_result_basic Absent r
| AKind k -> run_disp_string_utf8 (Utf8.advance s i) j s q k
*)
let run_dispatcher2 d v =
(* print_string "+"; flush stdout; *)
let code = run_dispatcher d v in
cursor := 0;
(* print_string "-\n"; flush stdout; *)
(code,!buffer)
let run_dispatcher = old_dispatcher
runtime/run_dispatch.mli
View file @ 6fd7a218
......@@ -2,4 +2,3 @@ open Value
val run_dispatcher: Patterns.Compile.dispatcher -> t -> int * t array
val run_dispatcher2: Patterns.Compile2.dispatcher -> t -> int * t array
types/patterns.ml
View file @ 6fd7a218
This diff is collapsed.
types/patterns.mli
View file @ 6fd7a218
......@@ -85,62 +85,3 @@ module Compile: sig
val debug_compile : Format.formatter -> Types.Node.t -> node list -> unit
end
module Compile2 : sig
type dispatcher
type source =
| SrcCapture
| SrcLeft | SrcRight
| SrcCst of Types.const
| SrcPair of source * source
| SrcFetchLeft of int
| SrcFetchRight of int
| SrcLocal of int
type push = PushConst of Types.const | PushField | PushCapture
type result = int * source array
type actions =
| AResult of result
| AKind of actions_kind
and actions_kind = {
basic: (Types.t * result) list;
atoms: result Atoms.map;
chars: result Chars.map;
prod: actions_prod;
xml: actions_prod;
record: actions_record;
}
and actions_record =
| RecordLabel of label * dispatcher * record_tr array
| RecordLabelSkip of label * record_tr
| RecordResult of result
| RecordMore of result * result (* nomore, more *)
| RecordImpossible
and record_tr = (push list * actions_record) Lazy.t
and actions_prod =
| LeftRight of result dispatch dispatch
| RightLeft of result dispatch dispatch
| Impossible
and 'a dispatch =
| Dispatch of dispatcher * 'a array
| TailCall of dispatcher
| Ignore of 'a
val actions: dispatcher -> actions
val make_branches :
Types.t -> (node * 'a) list ->
dispatcher * (int list * 'a) option array
val print_dispatcher: Format.formatter -> dispatcher -> unit
end
val approx :
descr ->
Types.descr ->
id list * (id * Types.Const.t) list
val demo: Format.formatter -> descr -> Types.descr -> unit
val demo_compile: Format.formatter -> Types.descr -> descr list -> unit
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment