1: # 16 "./lpsrc/flx_unravel.ipk"
2: open Flx_types
3: open Flx_mtypes1
4: open Flx_mtypes2
5: open List
6: open Flx_maps
7: open Flx_util
8: open Flx_print
9:
10: let rec eassoc x l = match l with
11: | [] -> raise Not_found
12: | (a,b) ::t ->
13: if Flx_typing.cmp_tbexpr x a then b else eassoc x t
14:
15: (* Unravel an expression into 'three address code',
16: at the same time eliminating common sub-expressions.
17: Note primitive applications are regarded as unary operators.
18: *)
19: let unravel syms bbdfns e =
20: let urn = 4 in
21: let sube = ref [] in
22: let get e =
23: try eassoc e !sube
24: with Not_found ->
25: let n = !(syms.counter) in incr (syms.counter);
26: let name = "_tmp" ^ si n in
27: sube := (e,name) :: !sube;
28: name
29:
30: in
31: let refer ((_,t) as e) =
32: `BEXPR_expr (get e,t),t
33: in
34: let idt t = t in
35: let e' =
36: let rec aux n e =
37: let n = n - 1 in
38: match e with
39: | `BEXPR_apply ((`BEXPR_name _,_) as f, b),t ->
40: refer (`BEXPR_apply (f, aux urn b),t)
41:
42: (*
43: (* no unravelling of primitives *)
44: | `BEXPR_apply_prim (i,ts,b),t when n > 0 ->
45: `BEXPR_apply_prim (i, ts, aux n b),t
46: *)
47:
48: | `BEXPR_apply_direct (i,ts,b),t
49: | `BEXPR_apply ((`BEXPR_closure (i,ts),_), b),t ->
50:
51: let id,parent,sr,entry = Hashtbl.find bbdfns i in
52: begin match entry with
53: | `BBDCL_regmatch _
54: | `BBDCL_reglex _
55: | `BBDCL_struct _
56: | `BBDCL_fun _ -> `BEXPR_apply_direct (i, ts, aux n b),t
57: | `BBDCL_function _ -> refer (`BEXPR_apply_direct (i,ts, aux urn b),t)
58:
59: | _ -> assert false
60: end
61:
62: | `BEXPR_apply (f,b),t -> refer (`BEXPR_apply(aux urn f, aux urn b),t)
63: | `BEXPR_tuple ls,t -> (`BEXPR_tuple (map (aux n) ls),t)
64: | (`BEXPR_name _,t) as x -> x
65: | (`BEXPR_literal (`AST_int _ )),t as x -> x
66: | (`BEXPR_literal (`AST_float _ )),t as x -> x
67: | x -> refer x
68: in
69: aux urn e
70: in
71: let sube = rev !sube in
72: (*
73: print_endline
74: (
75: "Unravelled " ^ sbe syms.dfns e ^ "-->" ^ sbe syms.dfns e' ^
76: " where:\n" ^
77: catmap ""
78: (fun (x,s) ->
79: s ^ " = "^sbe syms.dfns x ^";\n"
80: )
81: sube
82: );
83: *)
84: sube,e'