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

[r2005-06-13 21:56:19 by afrisch] Simplifications

Original author: afrisch
Date: 2005-06-13 21:56:19+00:00
parent cd44cecf
...@@ -563,25 +563,17 @@ let rec first_label (acc,fv,d) = ...@@ -563,25 +563,17 @@ let rec first_label (acc,fv,d) =
module Normal = struct module Normal = struct
type source = type source = SCatch | SConst of Types.const
| SCatch | SConst of Types.const
| SLeft | SRight | SRecompose
type result = source id_map type result = source id_map
let compare_source s1 s2 = let compare_source s1 s2 =
if s1 == s2 then 0 if s1 == s2 then 0
else match (s1,s2) with else match (s1,s2) with
| SCatch, _ -> -1 | _, SCatch -> 1 | SCatch, _ -> -1 | _, SCatch -> 1
| SLeft, _ -> -1 | _, SLeft -> 1
| SRight, _ -> -1 | _, SRight -> 1
| SRecompose, _ -> -1 | _, SRecompose -> 1
| SConst c1, SConst c2 -> Types.Const.compare c1 c2 | SConst c1, SConst c2 -> Types.Const.compare c1 c2
let hash_source = function let hash_source = function
| SCatch -> 1 | SCatch -> 1
| SLeft -> 2
| SRight -> 3
| SRecompose -> 4
| SConst c -> Types.Const.hash c | SConst c -> Types.Const.hash c
let compare_result r1 r2 = let compare_result r1 r2 =
...@@ -730,20 +722,14 @@ module Normal = struct ...@@ -730,20 +722,14 @@ module Normal = struct
let ntimes lab acc p q xs = let ntimes lab acc p q xs =
let xsp = IdSet.cap xs p.fv and xsq = IdSet.cap xs q.fv in let xsp = IdSet.cap xs p.fv and xsq = IdSet.cap xs q.fv in
let src_p = IdMap.constant SLeft xsp
and src_q = IdMap.constant SRight xsq in
let src = IdMap.merge_elem SRecompose src_p src_q in
{ (nempty lab) with { (nempty lab) with
nprod = single_prod src (nnode p xsp) (nnode q xsq) nprod = single_prod empty_res (nnode p xsp) (nnode q xsq)
} }
let nxml lab acc p q xs = let nxml lab acc p q xs =
let xsp = IdSet.cap xs p.fv and xsq = IdSet.cap xs q.fv in let xsp = IdSet.cap xs p.fv and xsq = IdSet.cap xs q.fv in
let src_p = IdMap.constant SLeft xsp
and src_q = IdMap.constant SRight xsq in
let src = IdMap.merge_elem SRecompose src_p src_q in
{ (nempty lab) with { (nempty lab) with
nxml = single_prod src (nnode p xsp) (nnode q xsq) nxml = single_prod empty_res (nnode p xsp) (nnode q xsq)
} }
let nrecord lab acc l p xs = let nrecord lab acc l p xs =
...@@ -751,14 +737,13 @@ module Normal = struct ...@@ -751,14 +737,13 @@ module Normal = struct
| None -> assert false | None -> assert false
| Some label -> | Some label ->
assert (label <= l); assert (label <= l);
let src,lft,rgt = let lft,rgt =
if l == label if l == label
then SLeft, nnode p xs, ncany then nnode p xs, ncany
else SRight, ncany_abs, nnode (cons p.fv (record l p)) xs else ncany_abs, nnode (cons p.fv (record l p)) xs
in in
let src = IdMap.constant src xs in
{ (nempty lab) with { (nempty lab) with
nrecord = RecLabel(label, single_prod src lft rgt) } nrecord = RecLabel(label, single_prod empty_res lft rgt) }
let nconstr lab t = let nconstr lab t =
let aux l = let aux l =
...@@ -772,11 +757,10 @@ module Normal = struct ...@@ -772,11 +757,10 @@ module Normal = struct
(if y then Some empty_res else None)) (if y then Some empty_res else None))
| Some l -> | Some l ->
RecLabel (l,aux (Types.Record.split_normal t l)) in RecLabel (l,aux (Types.Record.split_normal t l)) in
{ (nempty lab) with { nbasic = single_basic empty_res (Types.cap t any_basic);
nbasic = single_basic empty_res (Types.cap t any_basic); nprod = aux (Types.Product.normal t);
nprod = aux (Types.Product.normal t); nxml = aux (Types.Product.normal ~kind:`XML t);
nxml = aux (Types.Product.normal ~kind:`XML t); nrecord = record
nrecord = record
} }
let nany lab res = let nany lab res =
...@@ -824,6 +808,7 @@ module Normal = struct ...@@ -824,6 +808,7 @@ module Normal = struct
let vs_var = facto Factorize.var t0 xs pl in let vs_var = facto Factorize.var t0 xs pl in
let xs = IdSet.diff xs vs_var in let xs = IdSet.diff xs vs_var in
let vs_nil = facto Factorize.nil t0 xs pl in let vs_nil = facto Factorize.nil t0 xs pl in
let xs = IdSet.diff xs vs_nil in
(vs_var,vs_nil,(pl,t,xs)) (vs_var,vs_nil,(pl,t,xs))
let normal l t pl xs = let normal l t pl xs =
...@@ -1080,40 +1065,48 @@ struct ...@@ -1080,40 +1065,48 @@ struct
| _ -> dump_disp disp; assert false in | _ -> dump_disp disp; assert false in
let final = Array.map aux pl in let final = Array.map aux pl in
(find_code disp final, create_result final, ar) (find_code disp final, create_result final, ar)
let conv_source_basic s = match s with let conv_source = function
| Normal.SCatch -> Catch | Normal.SCatch -> Catch
| Normal.SConst c -> Const c | Normal.SConst c -> Const c
| _ -> assert false
let return_basic disp selected = let return_basic disp selected =
let aux_final res = IdMap.map_to_list conv_source_basic res in let aux_final res = IdMap.map_to_list conv_source res in
return disp selected aux_final 0 return disp selected aux_final 0
let assoc v (vars,nils,l) ofs = (* let print_idset ppf s =
try ofs - IdMap.assoc v l with Not_found -> let s = String.concat "," (List.map (fun x -> Ident.to_string x) s) in
if IdSet.mem vars v then -1 Format.fprintf ppf "{%s}" s
else if IdSet.mem nils v then -2 let print_idmap ppf s =
else assert false print_idset ppf (IdMap.domain s) *)
let conv_source_prod ofs1 ofs2 left right v s = let merge_res_prod ofs1 ofs2 (lvars,lnils,lres) (rvars,rnils,rres) extra =
match s with let lres =
| Normal.SCatch -> Catch IdMap.union_disj
| Normal.SConst c -> Const c (IdMap.map (fun i -> Stack (ofs1 + ofs2 - i)) lres)
| Normal.SLeft -> (IdMap.union_disj
(match assoc v left (ofs1 + ofs2) with (IdMap.constant Left lvars) (IdMap.constant Nil lnils)) in
| -1 -> Left let rres =
| -2 -> Nil IdMap.union_disj
| i -> Stack i) (IdMap.map (fun i -> Stack (ofs2 - i)) rres)
| Normal.SRight -> (IdMap.union_disj
(match assoc v right ofs2 with (IdMap.constant Right rvars) (IdMap.constant Nil rnils)) in
| -1 -> Right let sub =
| -2 -> Nil IdMap.merge
| i -> Stack i) (fun l r ->
| Normal.SRecompose -> match l,r with
(match (assoc v left (ofs1 + ofs2), assoc v right ofs2) with | Left,Right -> Catch
| (-1,-1) -> Catch | _ ->
| (l,r) -> Recompose (l,r)) let l =
match l with Left -> (-1) | Nil -> (-2)
| Stack i -> i | _ -> assert false in
let r =
match r with Right -> (-1) | Nil -> (-2)
| Stack i -> i | _ -> assert false in
Recompose (l,r)) lres rres in
IdMap.map_to_list (fun x -> x)
(IdMap.union_disj sub (IdMap.map conv_source extra))
module TypeList = SortedList.Make(Types) module TypeList = SortedList.Make(Types)
let dispatch_basic disp pl : (Types.t * result) list = let dispatch_basic disp pl : (Types.t * result) list =
...@@ -1224,8 +1217,7 @@ struct ...@@ -1224,8 +1217,7 @@ struct
(dispatch_prod2 disp ar1) (dispatch_prod2 disp ar1)
(fun x -> detect_right_tail_call (combine equal_result x)) (fun x -> detect_right_tail_call (combine equal_result x))
and dispatch_prod2 disp ar1 t2 ar2 pl = and dispatch_prod2 disp ar1 t2 ar2 pl =
let aux_final (ret2, (ret1, res)) = let aux_final (ret2, (ret1, res)) = merge_res_prod ar1 ar2 ret1 ret2 res in
IdMap.mapi_to_list (conv_source_prod ar1 ar2 ret1 ret2) res in
return disp pl aux_final (ar1 + ar2) return disp pl aux_final (ar1 + ar2)
...@@ -1242,7 +1234,7 @@ struct ...@@ -1242,7 +1234,7 @@ struct
| Normal.RecNolabel (Some x,_) -> [x] | Normal.RecNolabel (Some x,_) -> [x]
| Normal.RecNolabel (None,_) -> [] | Normal.RecNolabel (None,_) -> []
| _ -> assert false) pl in | _ -> assert false) pl in
Some (return disp pl (IdMap.map_to_list conv_source_basic) 0) Some (return disp pl (IdMap.map_to_list conv_source) 0)
else None else None
in in
let none = let none =
...@@ -1251,7 +1243,7 @@ struct ...@@ -1251,7 +1243,7 @@ struct
| Normal.RecNolabel (_,Some x) -> [x] | Normal.RecNolabel (_,Some x) -> [x]
| Normal.RecNolabel (_,None) -> [] | Normal.RecNolabel (_,None) -> []
| _ -> assert false) pl in | _ -> assert false) pl in
Some (return disp pl (IdMap.map_to_list conv_source_basic) 0) Some (return disp pl (IdMap.map_to_list conv_source) 0)
else None else None
in in
Some (RecNolabel (some,none)) Some (RecNolabel (some,none))
......
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