Commit e3b1511d authored by Pietro Abate's avatar Pietro Abate

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