Skip to content

GitLab

Commit f5e6a276 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-01-14 09:35:32 by afrisch] Change access to the stack in dispatcher -- this facilitates tail 

recursion in run_dispatcher...

Original author: afrisch
Date: 2005-01-14 09:35:33+00:00
parent f05846a5
Hide whitespace changes
Inline Side-by-side
.cvsignore
View file @ f5e6a276
......@@ -5,6 +5,7 @@ dtd2cduce
webiface.opt
webiface
validate
evaluator
*.cmi
*.cmo
*.cmx
......
driver/cduce.ml
View file @ f5e6a276
......@@ -197,7 +197,9 @@ let debug ppf tenv cenv = function
Format.fprintf ppf "[DEBUG:compile]@.";
let t = Typer.typ tenv t
and pl = List.map (Typer.pat tenv) pl in
Patterns.Compile.debug_compile ppf t pl
Patterns.Compile.debug_compile ppf t pl;
Format.fprintf ppf "@.";
(*
Patterns.demo_compile ppf (Types.descr t) (List.map Patterns.descr pl)
*)
......
ocamliface/.cvsignore 0 → 100644
View file @ f5e6a276
*.cmi
*.cmo
*.cmx
*.cma
*.cmxa
cmi2ml
asttypes.ml
\ No newline at end of file
runtime/explain.ml
View file @ f5e6a276
......@@ -24,7 +24,7 @@ let expected d fail =
Array.iteri (fun i t -> if i != fail then a := Types.cup t !a) ts;
!a
let make_result pt fail (code,_) =
let make_result pt fail (code,_,_) =
if fail == code then raise (Path pt);
code
......@@ -43,9 +43,9 @@ let find_array pred a =
!res
let new_fail_res fail =
find_array (function (code,_) when code = fail -> true | _ -> false)
find_array (function (code,_,_) when code = fail -> true | _ -> false)
let new_fail_disp fail =
find_array (function Ignore (code,_) when code = fail -> true | _ -> false)
find_array (function Ignore (code,_,_) when code = fail -> true | _ -> false)
let rec run_dispatcher pt fail d v =
......
runtime/run_dispatch.ml
View file @ f5e6a276
......@@ -41,9 +41,9 @@ let push v =
(* Old dispatchers *)
let make_result_prod v1 r1 v2 r2 v (code,r) =
let make_result_prod v1 v2 v (code,r,pop) =
let n = Array.length r in
if n == 0 then code else (
if n > 0 then (
ensure_room n;
let buf = !buffer in
let c = !cursor in
......@@ -51,23 +51,25 @@ let make_result_prod v1 r1 v2 r2 v (code,r) =
let x = match Array.unsafe_get r a with
| Catch -> v
| Const c -> const c
| Left i -> (match i with (-1) -> v1 | (-2) -> nil | _ -> buf.(r1+i))
| Right j -> (match j with (-1) -> v2 | (-2) -> nil | _ -> buf.(r2+j))
| Nil -> nil
| Left -> v1
| Right -> v2
| Stack i -> buf.(c - i)
| Recompose (i,j) ->
Pair (
(match i with (-1) -> v1 | (-2) -> nil | _ -> buf.(r1+i)),
(match j with (-1) -> v2 | (-2) -> nil | _ -> buf.(r2+j))
(match i with (-1) -> v1 | (-2) -> nil | _ -> buf.(c - i)),
(match j with (-1) -> v2 | (-2) -> nil | _ -> buf.(c - j))
)
in
buf.(c + a) <- x
done;
if r1 != c then blit buf c buf r1 n;
cursor := r1 + n; (* clean space for GC ? *)
code )
if pop != 0 then blit buf c buf (c - pop) n);
cursor := !cursor - pop + n; (* clean space for GC ? *)
code
let make_result_basic v (code,r) =
let make_result_basic v (code,r,_) =
let n = Array.length r in
if n == 0 then code else (
if n > 0 then (
ensure_room n;
let buf = !buffer in
for a = 0 to n - 1 do
......@@ -78,13 +80,13 @@ let make_result_basic v (code,r) =
in
buf.(!cursor) <- x;
incr cursor
done;
code )
done);
code
let make_result_char ch (code,r) =
let make_result_char ch (code,r,_) =
let n = Array.length r in
if n == 0 then code else (
if n > 0 then (
ensure_room n;
let buf = !buffer in
for a = 0 to n - 1 do
......@@ -95,85 +97,80 @@ let make_result_char ch (code,r) =
in
buf.(!cursor + a) <- x
done;
cursor := !cursor + n;
code )
cursor := !cursor + n);
code
let tail_string_latin1 i j s q =
if i + 1 == j then q else String_latin1 (i + 1,j,s,q)
let make_result_string_latin1 i j s q r1 r2 (code,r) =
let make_result_string_latin1 i j s q (code,r,pop) =
let n = Array.length r in
if n == 0 then code else (
if n > 0 then (
ensure_room n;
let c = !cursor in
let buf = !buffer in
for a = 0 to n - 1 do
let x = match Array.unsafe_get r a with
| Catch -> String_latin1 (i,j,s,q)
| Const c -> const c
| Left n -> (match n with
| (-1) -> Char (Chars.V.mk_char s.[i])
| (-2) -> nil
| _ -> buf.(r1+n))
| Right m -> (match m with
| (-1) -> tail_string_latin1 i j s q
| (-2) -> nil
| _ -> buf.(r2+m))
| Nil -> nil
| Left -> Char (Chars.V.mk_char s.[i])
| Right -> tail_string_latin1 i j s q
| Stack n -> buf.(c - n)
| Recompose (n,m) ->
Pair (
(match n with
| (-1) -> Char (Chars.V.mk_char s.[i])
| (-2) -> nil
| _ -> buf.(r1+n)),
| _ -> buf.(c - n)),
(match m with
| (-1) -> tail_string_latin1 i j s q
| (-2) -> nil
| _ -> buf.(r2+m))
| _ -> buf.(c - m))
)
in
buf.(!cursor + a) <- x
buf.(c + a) <- x
done;
if r1 != !cursor then blit buf !cursor buf r1 n;
cursor := r1 + n;
code )
if pop != 0 then blit buf c buf (c - pop) n);
cursor := !cursor - pop + n;
code
let tail_string_utf8 i j s q =
let i = Utf8.advance s i in
if Utf8.equal_index i j then q else String_utf8 (i,j,s,q)
let make_result_string_utf8 i j s q r1 r2 (code,r) =
let make_result_string_utf8 i j s q (code,r,pop) =
let n = Array.length r in
if n == 0 then code else (
if n > 0 then (
ensure_room n;
let c = !cursor in
let buf = !buffer in
for a = 0 to n - 1 do
let x = match Array.unsafe_get r a with
| Catch -> String_utf8 (i,j,s,q)
| Const c -> const c
| Left n -> (match n with
| (-1) -> Char (Chars.V.mk_int (Utf8.get s i))
| (-2) -> nil
| _ -> buf.(r1+n))
| Right m -> (match m with
| (-1) -> tail_string_utf8 i j s q
| (-2) -> nil
| _ -> buf.(r2+m))
| Nil -> nil
| Left -> Char (Chars.V.mk_int (Utf8.get s i))
| Right -> tail_string_utf8 i j s q
| Stack n -> buf.(c - n)
| Recompose (n,m) ->
Pair (
(match n with
| (-1) -> Char (Chars.V.mk_int (Utf8.get s i))
| (-2) -> nil
| _ -> buf.(r1+n)),
| _ -> buf.(c - n)),
(match m with
| (-1) -> tail_string_utf8 i j s q
| (-2) -> nil
| _ -> buf.(r2+m))
| _ -> buf.(c - m))
)
in
buf.(!cursor + a) <- x
buf.(c + a) <- x
done;
if r1 != !cursor then blit buf !cursor buf r1 n;
cursor := r1 + n;
code )
if pop != 0 then blit buf c buf (c - pop) n;
);
cursor := !cursor - pop + n;
code
let rec run_disp_basic v f = function
| [(_,r)] -> make_result_basic v r
......@@ -183,9 +180,9 @@ let rec run_disp_basic v f = function
assert false
let rec run_dispatcher d v =
(* Format.fprintf Format.std_formatter "Matching (%a) with:@." Value.print v; *)
(* Patterns.Compile.print_dispatcher Format.std_formatter d;
*)
(* Format.fprintf Format.std_formatter "Matching (%a) with:@." Value.print v;
Patterns.Compile.print_dispatcher Format.std_formatter d; *)
match actions d with
| AIgnore r -> make_result_basic v r
| AKind k -> run_disp_kind k v
......@@ -219,20 +216,18 @@ and run_disp_kind actions v =
and run_disp_prod v v1 v2 = function
| Impossible -> assert false
| TailCall d1 -> run_dispatcher d1 v1
| Ignore d2 -> run_disp_prod2 v1 !cursor v v2 d2
| Ignore d2 -> run_disp_prod2 v1 v v2 d2
| Dispatch (d1,b1) ->
let r1 = !cursor in
let code1 = run_dispatcher d1 v1 in
run_disp_prod2 v1 r1 v v2 b1.(code1)
run_disp_prod2 v1 v v2 b1.(code1)
and run_disp_prod2 v1 r1 v v2 = function
and run_disp_prod2 v1 v v2 = function
| Impossible -> assert false
| Ignore r -> make_result_prod v1 r1 v2 !cursor v r
| Ignore r -> make_result_prod v1 v2 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)
make_result_prod v1 v2 v b2.(code2)
and run_disp_record other v fields = function
| None -> assert false
......@@ -255,20 +250,18 @@ and run_disp_record other v fields = function
and run_disp_record1 v other v1 rem = function
| Impossible -> assert false
| TailCall d1 -> run_dispatcher d1 v1
| Ignore d2 -> run_disp_record2 v other v1 !cursor rem d2
| Ignore d2 -> run_disp_record2 v other v1 rem d2
| Dispatch (d1,b1) ->
let r1 = !cursor in
let code1 = run_dispatcher d1 v1 in
run_disp_record2 v other v1 r1 rem b1.(code1)
run_disp_record2 v other v1 rem b1.(code1)
and run_disp_record2 v other v1 r1 rem = function
and run_disp_record2 v other v1 rem = function
| Impossible -> assert false
| Ignore r -> make_result_prod v1 r1 Absent 0 v r
| Ignore r -> make_result_prod v1 Absent v r
| TailCall d2 -> run_disp_record_loop v other rem d2
| Dispatch (d2,b2) ->
let r2 = !cursor in
let code2 = run_disp_record_loop v other rem d2 in
make_result_prod v1 r1 Absent r2 v b2.(code2)
make_result_prod v1 Absent v b2.(code2)
and run_disp_record_loop v other rem d =
match actions d with
......@@ -281,24 +274,22 @@ and run_disp_string_latin1 i j s q actions =
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
| Ignore d2 -> run_disp_string_latin1_2 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)
run_disp_string_latin1_2 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
and run_disp_string_latin1_2 i j s q = function
| Impossible -> assert false
| Ignore r ->
make_result_string_latin1 i j s q r1 0 r
make_result_string_latin1 i j s q 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)
make_result_string_latin1 i j s q b2.(code2)
and run_disp_string_latin1_loop i j s q d =
let i = succ i in
if i == j then run_dispatcher d q else
......@@ -312,24 +303,22 @@ and run_disp_string_utf8 i j s q actions =
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
| Ignore d2 -> run_disp_string_utf8_2 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)
run_disp_string_utf8_2 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
and run_disp_string_utf8_2 i j s q = function
| Impossible -> assert false
| Ignore r ->
make_result_string_utf8 i j s q r1 0 r
make_result_string_utf8 i j s q 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)
make_result_string_utf8 i j s q b2.(code2)
and run_disp_string_utf8_loop i j s q d =
let i = Utf8.advance s i in
if Utf8.equal_index i j then run_dispatcher d q else
......
tests/biblio.cd
View file @ f5e6a276
......@@ -33,16 +33,17 @@ let fun do_authors ([Author+] -> [Mix*])
let fun do_paper (Paper -> <li>[Mix*])
| <paper>[ x::(_* ) <title>t <_>c _* <year>y <file>f ;_ ] ->
(* Here, type inference says: x : [Author+] ... *)
raise x;
let authors = do_authors x in
<li>([ <a href=f>t ] @ authors @ "; in " @ [ <em>c ] @ "." );;
let fun do_biblio (Biblio -> Html)
<bibliography>[ <heading>h; p ] ->
let body = match p with
let body = match p with
| [] -> "Empty bibliography"
| l -> [ <h1>h <ul>(map l with x -> do_paper x) ]
in
in
<html>[ <head>[ <title>h ] <body>body ];;
let bib : Biblio =
......@@ -50,24 +51,15 @@ let bib : Biblio =
<heading>"Alain Frisch's bibliography"
<paper>[
<author>"Alain Frisch"
<author>"Giuseppe Castagna"
<author>"Vronique Benzaken"
(* <author>"Giuseppe Castagna"
<author>"Vronique Benzaken" *)
<title>"Semantic subtyping"
<conference>"LICS 02"
<year>[2002]
<file>"semsub.ps.gz"
<abstract>[ 'In this work, we present the functional language CDuce, discuss '
'some design issues, and show its adequacy for working with XML '
'documents. Peculiar features of CDuce are a powerful pattern '
'matching, first class functions, overloaded functions, a very rich '
'type system (arrows, sequences, pairs, records, intersections, '
'unions, differences), precise type inference and a natural '
'interpretation of types as sets of values. We also discuss how to '
'add constructs for programming XML queries in a declarative (and, '
'thus, optimizable) way and finally sketch a dispatch algorithm to '
'demonstrate how static type information can be used in efficient '
'compilation schemas.' ]
<abstract>[ 'In this work,...' ]
]
(*
<paper>[
<author>"Mariangiola Dezani-Ciancaglini"
<author>"Alain Frisch"
......@@ -87,12 +79,14 @@ let bib : Biblio =
<year>[2002]
<file>"planx.ps.gz"
]
*)
];;
do_biblio bib
;;
(*
[bib]/<papr>_/<author>_;;
*)
\ No newline at end of file
types/patterns.ml
View file @ f5e6a276
......@@ -978,10 +978,10 @@ struct
| Ignore of 'a
| Impossible
and result = int * source array
and result = int * source array * int
and source =
| Catch | Const of Types.const
| Left of int | Right of int | Recompose of int * int
| Stack of int | Left | Right | Nil | Recompose of int * int
and return_code =
Types.t * int * (* accepted type, arity *)
......@@ -1021,12 +1021,11 @@ struct
let equal_source s1 s2 =
(s1 == s2) || match (s1,s2) with
| Const x, Const y -> Types.Const.equal x y
| Left x, Left y -> x == y
| Right x, Right y -> x == y
| Stack x, Stack y -> x == y
| Recompose (x1,x2), Recompose (y1,y2) -> (x1 == y1) && (x2 == y2)
| _ -> false
let equal_result (r1,s1) (r2,s2) =
let equal_result (r1,s1,_) (r2,s2,_) =
(r1 == r2) && (equal_array equal_source s1 s2)
let equal_result_dispatch d1 d2 = (d1 == d2) || match (d1,d2) with
......@@ -1037,9 +1036,9 @@ struct
| _ -> false
let immediate_res basic prod xml record =
let res = ref None in
let res : result option ref = ref None in
let chk = function Catch | Const _ -> true | _ -> false in
let f ((_,ret) as r) =
let f ((_,ret,_) as r) =
match !res with
| Some r0 when equal_result r r0 -> ()
| None when array_for_all chk ret -> res := Some r
......@@ -1082,11 +1081,12 @@ struct
let detect_right_tail_call =
detect_tail_call
(fun i (code,ret) ->
(fun i (code,ret,_) ->
(i == code) &&
let ar = Array.length ret in
(array_for_all_i
(fun pos ->
function Right j when pos == j -> true | _ -> false)
function Stack j when pos + j == ar -> true | _ -> false)
ret
)
)
......@@ -1095,10 +1095,11 @@ struct
detect_tail_call
(fun i ->
function
| Ignore (code,ret) when (i == code) ->
| Ignore (code,ret,_) when (i == code) ->
let ar = Array.length ret in
array_for_all_i
(fun pos ->
function Left j when pos == j -> true | _ -> false)
function Stack j when pos + j == ar -> true | _ -> false)
ret
| _ -> false
)
......@@ -1186,10 +1187,10 @@ struct
let aux x accu = match x with Some b -> b @ accu | None -> accu in
Array.of_list (Array.fold_right aux pl [])
let return disp pl f =
let return disp pl f ar =
let aux = function [x] -> Some (f x) | [] -> None | _ -> assert false in
let final = Array.map aux pl in
(find_code disp final, create_result final)
(find_code disp final, create_result final, ar)
let conv_source_basic s = match s with
| Normal.SCatch -> Catch
......@@ -1198,21 +1199,30 @@ struct
let return_basic disp selected =
let aux_final res = IdMap.map_to_list conv_source_basic res in
return disp selected aux_final
return disp selected aux_final 0
let assoc v (vars,nils,l) =
try IdMap.assoc v l with Not_found ->
let assoc v (vars,nils,l) ofs =
try ofs - IdMap.assoc v l with Not_found ->
if IdSet.mem vars v then -1
else if IdSet.mem nils v then -2
else assert false
let conv_source_prod left right v s = match s with
let conv_source_prod ofs1 ofs2 left right v s =
match s with
| Normal.SCatch -> Catch
| Normal.SConst c -> Const c
| Normal.SLeft -> Left (assoc v left)
| Normal.SRight -> Right (assoc v right)
| Normal.SLeft ->
(match assoc v left (ofs1 + ofs2) with
| -1 -> Left
| -2 -> Nil
| i -> Stack i)
| Normal.SRight ->
(match assoc v right ofs2 with
| -1 -> Right
| -2 -> Nil
| i -> Stack i)
| Normal.SRecompose ->
(match (assoc v left, assoc v right) with
(match (assoc v left (ofs1 + ofs2), assoc v right ofs2) with
| (-1,-1) -> Catch
| (l,r) -> Recompose (l,r))
......@@ -1268,11 +1278,11 @@ struct
let disp = dispatcher t reqs lab in
(* Build continuation *)
let result (t,_,m) =
let result (t,ar,m) =
let get a ((vars,nils,req),info) =
match m.(NfMap.find req idx) with Some res -> ((vars,nils,res),info)::a | _ -> a in
let pl = Array.map (List.fold_left get []) pl in
d t pl
d t ar pl
in
let res = Array.map result disp.codes in
post (disp,res)
......@@ -1286,7 +1296,7 @@ struct
let nnf = (Normal.NodeSet.singleton p, !t0, xs) in
t0 := Types.diff !t0 (Types.descr (accept p));
[(nnf, (xs, e))] in
let res _ pl =
let res _ _ pl =
let aux r = function
| [(([],[],res), (xs,e))] -> assert (r == Fail);
let m = List.map (fun x -> (x,IdMap.assoc x res)) xs in
......@@ -1309,16 +1319,16 @@ struct
(Types.Product.pi1 t)
(dispatch_prod1 disp t)
(fun x -> detect_left_tail_call (combine equal_result_dispatch x))
and dispatch_prod1 disp t t1 pl =
and dispatch_prod1 disp t t1 ar1 pl =
get_tests true pl
(fun (ret1, (res,q)) -> q, (ret1,res) )
(Types.Product.pi2_restricted t1 t)
(dispatch_prod2 disp)
(dispatch_prod2 disp ar1)
(fun x -> detect_right_tail_call (combine equal_result x))
and dispatch_prod2 disp t2 pl =
let aux_final (ret2, (ret1, res)) =
IdMap.mapi_to_list (conv_source_prod ret1 ret2) res in
return disp pl aux_final
and dispatch_prod2 disp ar1 t2 ar2 pl =
let aux_final (ret2, (ret1, res)) =
IdMap.mapi_to_list (conv_source_prod ar1 ar2 ret1 ret2) res in
return disp pl aux_final (ar1 + ar2)
let dispatch_record disp : record option =
......@@ -1334,7 +1344,7 @@ struct
| Normal.RecNolabel (Some x,_) -> [x]
| Normal.RecNolabel (None,_) -> []
| _ -> assert false) disp.pl in
Some (return disp pl (IdMap.map_to_list conv_source_basic))
Some (return disp pl (IdMap.map_to_list conv_source_basic) 0)
else None
in
let none =
......@@ -1343,7 +1353,7 @@ struct
| Normal.RecNolabel (_,Some x) -> [x]
| Normal.RecNolabel (_,None) -> []
| _ -> assert false) disp.pl in
Some (return disp pl (IdMap.map_to_list conv_source_basic))
Some (return disp pl (IdMap.map_to_list conv_source_basic) 0)
else None
in
Some (RecNolabel (some,none))
......@@ -1379,54 +1389,61 @@ struct