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:
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: