5.51. Reductions

Start ocaml section to src/flx_reduce.mli[1 /1 ]
     1: # 5 "./lpsrc/flx_reduce.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: 
     7: val remove_useless_reductions:
     8:   sym_state_t ->
     9:   fully_bound_symbol_table_t ->
    10:   reduction_t list ->
    11:   reduction_t list
    12: 
    13: val reduce_exes:
    14:   sym_state_t ->
    15:   reduction_t list ->
    16:   bexe_t list ->
    17:   bexe_t list
    18: 
End ocaml section to src/flx_reduce.mli[1]
Start ocaml section to src/flx_reduce.ml[1 /1 ]
     1: # 24 "./lpsrc/flx_reduce.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_print
     7: open Flx_util
     8: open List
     9: open Flx_unify
    10: open Flx_maps
    11: 
    12: let id x = x
    13: 
    14: let remove_useless_reductions syms bbdfns reductions =
    15:   List.filter
    16:   (fun (id,bvs,bps,e1,_) ->
    17:     let psi = map (fun {pindex=i} -> i) bps in
    18:     let ui i =
    19:       let used = List.mem i psi or Hashtbl.mem bbdfns i in
    20:       if not used then begin
    21:         if syms.compiler_options.print_flag then
    22:         print_endline ("ELIDING USELESS REDUCTION " ^ id ^ " because " ^ si i ^ " isn't found");
    23:         raise Not_found
    24:       end
    25:     in
    26:     begin
    27:       try
    28:         Flx_maps.iter_tbexpr ui ignore ignore e1;
    29:         if syms.compiler_options.print_flag then
    30:         print_endline ("Keep " ^ id (* ^ " matching " ^ sbe syms.dfns e1 *));
    31: 
    32:         true
    33:       with
    34:       | Not_found ->
    35:         if syms.compiler_options.print_flag then
    36:         print_endline ("Discard " ^ id (* ^ " matching " ^ sbe syms.dfns e1 *));
    37:         false
    38:     end
    39:   )
    40:   reductions
    41: 
    42: let ematch syms changed (name,bvs,bps,e1,e2) tvars evars e =
    43:   (*
    44:   print_endline ("Matching " ^ sbe syms.dfns e ^ " with " ^ sbe syms.dfns e1);
    45:   *)
    46:   match Flx_unify.expr_maybe_matches syms.dfns tvars evars e1 e with
    47:   | Some (tmgu,emgu) ->
    48:     changed := true;
    49:     (*
    50:       print_endline ("REDUCTION: FOUND A MATCH, candidate " ^ sbe syms.dfns e^" with reduced LHS " ^ sbe syms.dfns e1);
    51:       print_endline ("EMGU=" ^catmap ", " (fun (i,e')-> si i ^ " --> " ^ sbe syms.dfns e') emgu);
    52:       print_endline ("TMGU=" ^catmap ", " (fun (i,t')-> si i ^ " --> " ^ sbt syms.dfns t') tmgu);
    53:     *)
    54:     let e = fold_left (fun e (i,e') -> Flx_unify.expr_term_subst e i e') e2 emgu in
    55:     let rec s e = map_tbexpr id s (list_subst tmgu) e in
    56:     let e' = s e in
    57:     (*
    58:     print_endline ("RESULT OF SUBSTITUTION into RHS: " ^ sbe syms.dfns e2 ^ " is " ^ sbe syms.dfns e);
    59:     *)
    60:     if syms.compiler_options.print_flag then
    61:       print_endline ("//Reduction " ^ sbe syms.dfns e ^ " => " ^ sbe syms.dfns e');
    62:     e'
    63: 
    64:   | None -> e
    65: 
    66: let rec reduce_exe syms reductions count exe =
    67:   if count = 0 then exe else
    68:   let changed = ref false in
    69:   let exe = fold_left
    70:     (fun exe (name,bvs,bps,e1,e2 as red,tvars,evars) ->
    71:       (*
    72:       print_endline ("Check reduction rule " ^ name ^ " on " ^ string_of_bexe syms.dfns 0 exe);
    73:       *)
    74:       let em e = ematch syms changed red tvars evars e in
    75:       (* apply reduction top down AND bottom up *)
    76:       let rec em' e = let e = em e in em (map_tbexpr id em' id e) in
    77:       map_bexe id em' id id id exe
    78:     )
    79:     exe
    80:     reductions
    81:   in
    82:   if !changed then reduce_exe syms reductions (count - 1) exe
    83:   else exe
    84: 
    85: let reduce_exes syms reductions exes =
    86:   let xreds = map
    87:   (fun ((name,bvs,bps,e1,e2) as red) ->
    88:     let tvars = map (fun (tvid, tvidx) -> tvidx) bvs in
    89:     let evars = map (fun {pindex=eidx} -> eidx) bps in
    90:     red,tvars,evars
    91:   )
    92:   reductions
    93:   in
    94: 
    95:   map (reduce_exe syms xreds 10) exes
    96: 
    97: 
End ocaml section to src/flx_reduce.ml[1]