5.48. Elide unused entries

Name binding pass 2.
Start ocaml section to src/flx_use.mli[1 /1 ]
     1: # 6 "./lpsrc/flx_use.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: 
     7: val find_roots:
     8:   sym_state_t ->
     9:   fully_bound_symbol_table_t ->
    10:   bid_t ->
    11:   biface_t list -> unit
    12: 
    13: (*
    14: val uses_type:
    15:   sym_state_t ->
    16:   IntSet.t ref ->
    17:   fully_bound_symbol_table_t ->
    18:   bool -> (* count inits *)
    19:   btypecode_t ->
    20:   unit
    21: 
    22: val uses_tbexpr:
    23:   sym_state_t ->
    24:   IntSet.t ref ->
    25:   fully_bound_symbol_table_t ->
    26:   bool -> (* count inits *)
    27:   tbexpr_t ->
    28:   unit
    29: 
    30: val uses:
    31:   sym_state_t ->
    32:   IntSet.t ref ->
    33:   fully_bound_symbol_table_t ->
    34:   bool -> (* true to count initialisations as uses *)
    35:   int ->
    36:   unit
    37: *)
    38: 
    39: (* counts initialisation as use *)
    40: val full_use_closure:
    41:   sym_state_t ->
    42:   fully_bound_symbol_table_t ->
    43:   IntSet.t
    44: 
    45: (* conditionally count initialisation as use *)
    46: val cal_use_closure:
    47:   sym_state_t ->
    48:   fully_bound_symbol_table_t ->
    49:   bool ->
    50:   IntSet.t
    51: 
    52: val copy_used:
    53:   sym_state_t ->
    54:   fully_bound_symbol_table_t ->
    55:   fully_bound_symbol_table_t
    56: 
End ocaml section to src/flx_use.mli[1]
Start ocaml section to src/flx_use.ml[1 /1 ]
     1: # 63 "./lpsrc/flx_use.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_print
     6: open Flx_mtypes1
     7: open Flx_mtypes2
     8: open Flx_typing
     9: open Flx_mbind
    10: open Flx_srcref
    11: open List
    12: open Flx_unify
    13: open Flx_treg
    14: open Flx_generic
    15: open Flx_maps
    16: open Flx_exceptions
    17: 
    18: 
    19: (* These routines find the absolute use closure of a symbol,
    20: in particular they include variables which are initialised
    21: but never used: these routine are intended to be used
    22: to extract all the bound symbol table entries required
    23: to process a set of roots.
    24: 
    25: Contrast with the 'Flx_call' usage routines, which
    26: find some symbols which are useful, this excludes
    27: types, and it excludes LHS vals and perhaps vars,
    28: which are not used in some expression.
    29: 
    30: It seems a pity these routines are almost identical
    31: (and the lot gets repeated yet again in the instantiator,
    32: and weakly in the 'useless call eliminator', we hope
    33: to find a better code reuse solution.. for now,
    34: remember to update all three sets of routines when
    35: changing the data structures.
    36: 
    37: *)
    38: 
    39: let nop x = ()
    40: 
    41: let rec uses_type syms used bbdfns count_inits (t:btypecode_t) =
    42:   let ut t = uses_type syms used bbdfns count_inits t in
    43:   match t with
    44:   | `BTYP_inst (i,ts)
    45:     ->
    46:       uses syms used bbdfns count_inits i; (* don't care on uses inits? *)
    47:       iter ut ts
    48: 
    49:   (*
    50:   | `BTYP_type
    51:     ->
    52:       failwith "[uses_type] Unexpected metatype"
    53:   *)
    54: 
    55:   | _ -> iter_btype ut t
    56: 
    57: and uses_exes syms used bbdfns count_inits exes =
    58:   iter (uses_exe syms used bbdfns count_inits) exes
    59: 
    60: and uses_exe syms used bbdfns count_inits (exe:bexe_t) =
    61:   (*
    62:   print_endline ("EXE=" ^ string_of_bexe syms.dfns 0 exe);
    63:   *)
    64:   let ue e = uses_tbexpr syms used bbdfns count_inits e in
    65:   let ui i = uses syms used bbdfns count_inits i in
    66:   let ut t = uses_type syms used bbdfns count_inits t in
    67:   match exe,count_inits with
    68:   | `BEXE_init (_,i,e),false -> ue e
    69:   | _ ->
    70:     iter_bexe ui ue ut nop nop exe
    71: 
    72: 
    73: and uses_tbexpr syms used bbdfns count_inits ((e,t) as x) =
    74:   let ue e = uses_tbexpr syms used bbdfns count_inits e in
    75:   let ut t = uses_type syms used bbdfns count_inits t in
    76:   let ui i = uses syms used bbdfns count_inits i in
    77: 
    78:   (* already done in the iter .. *)
    79:   (*
    80:   ut t;
    81:   *)
    82:   (* use a MAP now *)
    83:   iter_tbexpr ui ignore ut x;
    84: 
    85: and uses_production syms used bbdfns count_inits p =
    86:   let uses_symbol (_,nt) = match nt with
    87:   | `Nonterm ii -> iter (uses syms used bbdfns count_inits) ii
    88:   | `Term i -> () (* HACK! This is a union constructor name  we need to 'use' the union type!! *)
    89:   in
    90:   iter uses_symbol p
    91: 
    92: and faulty_req syms i =
    93:   match Hashtbl.find syms.dfns i with {id=id; sr=sr } ->
    94:   clierr sr (id ^ " is used but has unsatisfied requirement")
    95: 
    96: and uses syms used bbdfns count_inits i =
    97:   let ui i = uses syms used bbdfns count_inits i in
    98:   let ut t = uses_type syms used bbdfns count_inits t in
    99:   let rq reqs =
   100:     let ur (j,ts) =
   101:       if j = 0 then
   102:         faulty_req syms i
   103:       else begin ui j; iter ut ts end
   104:     in
   105:     iter ur reqs
   106:   in
   107:   let ux x = uses_exes syms used bbdfns count_inits x in
   108:   let ue e = uses_tbexpr syms used bbdfns count_inits e in
   109:   if not (IntSet.mem i !used) then
   110:   begin
   111:     match
   112:       try Some (Hashtbl.find bbdfns i)
   113:       with Not_found -> None
   114:     with
   115:     | Some (id,_,_,bbdcl) ->
   116:       used := IntSet.add i !used;
   117:       begin match bbdcl with
   118:       | `BBDCL_typeclass _ -> ()
   119: 
   120:       | `BBDCL_instance (_,_,con,i,ts) ->
   121:         ut con;
   122:         iter ut ts
   123: 
   124:       | `BBDCL_function (props,_,(ps,traint),ret,exes) ->
   125:         iter (fun {pindex=i;ptyp=t} -> ui i; ut t) ps;
   126:         ut ret;
   127:         ux exes
   128: 
   129:       | `BBDCL_procedure (props,_,(ps,traint), exes) ->
   130:         iter (fun {pindex=i;ptyp=t} -> ui i; ut t) ps;
   131:         ux exes
   132: 
   133:       | `BBDCL_glr (_,_,t,(p,e)) ->
   134:         ut t; ux e;
   135:         uses_production syms used bbdfns count_inits p
   136: 
   137:       | `BBDCL_regmatch (_,_,(ps,traint),t,(_,_,h,_)) ->
   138:         ut t; Hashtbl.iter (fun _ e -> ue e) h;
   139:         iter (fun {pindex=i;ptyp=t} -> ui i; ut t) ps;
   140: 
   141:       | `BBDCL_reglex (_,_,(ps,traint),i,t,(_,_,h,_)) ->
   142:         ut t; Hashtbl.iter (fun _ e -> ue e) h;
   143:         iter (fun {pindex=i;ptyp=t} -> ui i; ut t) ps;
   144:         ui i
   145: 
   146:       | `BBDCL_union (_,ps)
   147:         -> ()
   148: 
   149:         (* types of variant arguments are only used if constructed
   150:           .. OR ..  matched against ??
   151:         *)
   152: 
   153:       | `BBDCL_struct (_,ps)
   154:       | `BBDCL_cstruct (_,ps)
   155:         ->
   156:         iter ut (map snd ps)
   157: 
   158:       | `BBDCL_class _ -> ()
   159: 
   160:       | `BBDCL_cclass (_,mems) -> ()
   161: 
   162:       | `BBDCL_val (_,t)
   163:       | `BBDCL_var (_,t)
   164:       | `BBDCL_tmp (_,t) -> ut t
   165: 
   166:       | `BBDCL_ref (_,t) -> ut (`BTYP_pointer t)
   167: 
   168:       | `BBDCL_const (_,t,_,reqs) -> ut t; rq reqs
   169:       | `BBDCL_fun (_,_,ps, ret, _,reqs,_) -> iter ut ps; ut ret; rq reqs
   170: 
   171:       | `BBDCL_callback (_,_,ps_cf, ps_c, _, ret, reqs,_) ->
   172:         iter ut ps_cf;
   173:         iter ut ps_c;
   174:         ut ret; rq reqs
   175: 
   176:       | `BBDCL_proc (_,_,ps, _, reqs)  -> iter ut ps; rq reqs
   177: 
   178:       | `BBDCL_newtype (_,t) -> ut t
   179:       | `BBDCL_abs (_,_,_,reqs) -> rq reqs
   180:       | `BBDCL_insert (_,s,ikind,reqs)  -> rq reqs
   181:       | `BBDCL_nonconst_ctor (_,_,unt,_,ct,evs, etraint) ->
   182:         ut unt; ut ct
   183: 
   184:       end
   185:     | None ->
   186:       let id =
   187:         try match Hashtbl.find syms.dfns i with {id=id} -> id
   188:         with Not_found -> "not found in unbound symbol table"
   189:       in
   190:       failwith
   191:       (
   192:         "[Flx_use.uses] Cannot find bound defn for " ^ id ^ "<"^si i ^ ">"
   193:       )
   194:   end
   195: 
   196: let find_roots syms bbdfns
   197:   (root:bid_t)
   198:   (bifaces:biface_t list)
   199: =
   200: 
   201:   (* make a list of the root and all exported functions,
   202:   add exported types and components thereof into the used
   203:   set now too
   204:   *)
   205:   let roots = ref (IntSet.singleton root) in
   206:   iter
   207:   (function
   208:      | `BIFACE_export_fun (_,x,_) -> roots := IntSet.add x !roots
   209:      | `BIFACE_export_type (_,t,_) ->
   210:         uses_type syms roots bbdfns true t
   211:   )
   212:   bifaces
   213:   ;
   214:   syms.roots := !roots
   215: 
   216: let cal_use_closure syms bbdfns (count_inits:bool) =
   217:   let u = ref IntSet.empty in
   218:   let v : IntSet.t  = !(syms.roots) in
   219:   let v = ref v in
   220: 
   221:   let add j =
   222:     if not (IntSet.mem j !u) then
   223:     begin
   224:        (*
   225:        print_endline ("Scanning " ^ si j);
   226:        *)
   227:        u:= IntSet.add j !u;
   228:        uses syms v bbdfns count_inits j
   229:     end
   230:   in
   231:   let ut t = uses_type syms u bbdfns count_inits t in
   232:   Hashtbl.iter
   233:   ( fun i entries ->
   234:     iter (fun (vs,con,ts,j) ->
   235:     add i; add j;
   236:     ut con;
   237:     iter ut ts
   238:     )
   239:     entries
   240:   )
   241:   syms.typeclass_to_instance
   242:   ;
   243:   while not (IntSet.is_empty !v) do
   244:     let j = IntSet.choose !v in
   245:     v := IntSet.remove j !v;
   246:     add j
   247:   done
   248:   ;
   249:   !u
   250: 
   251: let full_use_closure syms bbdfns =
   252:   cal_use_closure syms bbdfns true
   253: 
   254: let copy_used syms bbdfns =
   255:   if syms.compiler_options.print_flag then
   256:     print_endline "COPY USED";
   257:   let h = Hashtbl.create 97 in
   258:   let u = full_use_closure syms bbdfns in
   259:   IntSet.iter
   260:   begin fun i ->
   261:     (*
   262:     if syms.compiler_options.print_flag then
   263:       print_endline ("Copying " ^ si i);
   264:     *)
   265:     Hashtbl.add h i (Hashtbl.find bbdfns i)
   266:   end
   267:   u;
   268:   h
   269: 
End ocaml section to src/flx_use.ml[1]
Start ocaml section to src/flx_child.mli[1 /1 ]
     1: # 3 "./lpsrc/flx_child.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: 
     7: type child_map_t =
     8:   (bid_t, bid_t list) Hashtbl.t
     9: 
    10: val find_children:
    11:   child_map_t -> bid_t -> bid_t list
    12: 
    13: val is_child:
    14:   child_map_t -> bid_t -> bid_t -> bool
    15: 
    16: val add_child:
    17:   child_map_t -> bid_t -> bid_t -> unit
    18: 
    19: val remove_child:
    20:   child_map_t -> bid_t -> bid_t -> unit
    21: 
    22: val is_ancestor:
    23:   fully_bound_symbol_table_t -> bid_t -> bid_t -> bool
    24: 
    25: val descendants:
    26:   child_map_t -> bid_t -> IntSet.t
    27: 
    28: val cal_children:
    29:   sym_state_t ->
    30:   fully_bound_symbol_table_t ->
    31:   child_map_t
    32: 
End ocaml section to src/flx_child.mli[1]
Start ocaml section to src/flx_child.ml[1 /1 ]
     1: # 36 "./lpsrc/flx_child.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open List
     7: open Flx_util
     8: 
     9: type child_map_t =
    10:   (bid_t, bid_t list) Hashtbl.t
    11: 
    12: let find_children childmap parent =
    13:   try Hashtbl.find childmap parent with Not_found -> []
    14: 
    15: let is_child childmap parent child =
    16:   mem child (find_children childmap parent)
    17: 
    18: let add_child childmap parent child =
    19:   let kids = find_children childmap parent in
    20:   Hashtbl.replace childmap parent (child::kids)
    21: 
    22: let rec is_ancestor bbdfns child anc =
    23:   let _,parent,_,_ = Hashtbl.find bbdfns child in
    24:   match parent with
    25:   | None -> false
    26:   | Some x ->
    27:     if x = anc then true
    28:     else is_ancestor bbdfns x anc
    29: 
    30: let remove_child childmap parent child =
    31:   let kids = find_children childmap parent in
    32:   let kids = filter (fun i -> i <> child) kids in
    33:   Hashtbl.replace childmap parent kids
    34: 
    35: (* closure of index with respect to children, EXCLUDES self *)
    36: let rec descendants child_map index =
    37:   let d = ref IntSet.empty in
    38:   let children = find_children child_map index in
    39:   iter
    40:   (fun i ->
    41:     if not (IntSet.mem i !d) then
    42:     begin
    43:       d := IntSet.add i !d;
    44:       d := IntSet.union !d (descendants child_map i)
    45:     end
    46:   )
    47:   children
    48:   ;
    49:   !d
    50: 
    51: let cal_children syms bbdfns =
    52:   let child_map = Hashtbl.create 97 in
    53:   Hashtbl.iter
    54:   (fun i (id,parent,sr,entry) ->
    55:     match parent with
    56:     | Some parent ->
    57:       Hashtbl.replace child_map parent
    58:       (i ::
    59:         (
    60:           try Hashtbl.find child_map parent
    61:           with Not_found -> []
    62:         )
    63:       )
    64:     | None -> ()
    65:   )
    66:   bbdfns
    67:   ;
    68:   child_map
    69: 
    70: 
End ocaml section to src/flx_child.ml[1]
Start ocaml section to src/flx_tailit.mli[1 /1 ]
     1: # 3 "./lpsrc/flx_tailit.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_call
     7: open Flx_srcref
     8: open Flx_child
     9: 
    10: val tailit:
    11:   sym_state_t ->
    12:   usage_table_t * child_map_t * fully_bound_symbol_table_t ->
    13:   bid_t ->
    14:   range_srcref ->
    15:   bparameter_t list ->
    16:   bvs_t ->
    17:   bexe_t list ->
    18:   bexe_t list
    19: 
    20: val exes_get_xclosures:
    21:   sym_state_t ->
    22:   bexe_t list ->
    23:   IntSet.t
    24: 
End ocaml section to src/flx_tailit.mli[1]
Start ocaml section to src/flx_tailit.ml[1 /1 ]
     1: # 28 "./lpsrc/flx_tailit.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_print
     6: open Flx_mtypes1
     7: open Flx_mtypes2
     8: open Flx_typing
     9: open Flx_mbind
    10: open Flx_srcref
    11: open List
    12: open Flx_unify
    13: open Flx_treg
    14: open Flx_generic
    15: open Flx_maps
    16: open Flx_exceptions
    17: open Flx_use
    18: open Flx_child
    19: open Flx_call
    20: 
    21: let isvariable bbdfns i =
    22:   let id,_,_,entry = Hashtbl.find bbdfns i in match entry with
    23:   | `BBDCL_var _ | `BBDCL_val _ ->
    24:   (* print_endline ("Var/Val " ^ id ^ "<" ^ si i ^">"); *) true
    25:   | _ -> false
    26: 
    27: let isfun bbdfns i =
    28:   let id,_,_,entry = Hashtbl.find bbdfns i in match entry with
    29:   | `BBDCL_function _ | `BBDCL_procedure _ ->
    30:   (*print_endline ("Fun/proc " ^ id ^ "<" ^ si i ^">"); *) true
    31:   | _ -> false
    32: 
    33: let add_xclosure syms cls e =
    34:   (*
    35:   print_endline ("chk cls for " ^ sbe syms.dfns e);
    36:   *)
    37:   match e with
    38:   | `BEXPR_closure (i,ts),t -> cls := IntSet.add i !cls
    39:   | _ -> ()
    40: 
    41: let ident x = x
    42: 
    43: (* WARNING!! closure here has TWO meanings: a BEXPR_closure,
    44:   and ALSO the setwise closure of all such explicit closure
    45:   terms ..
    46: *)
    47: 
    48: let expr_find_xclosures syms cls e =
    49:   iter_tbexpr ignore (add_xclosure syms cls) ignore e
    50: 
    51: let exe_find_xclosure syms cls exe =
    52:   iter_bexe ignore (expr_find_xclosures syms cls) ignore ignore ignore exe
    53: 
    54: let exes_find_xclosure syms cls exes =
    55:   iter (exe_find_xclosure syms cls) exes
    56: 
    57: let exes_get_xclosures syms exes =
    58:   let cls = ref IntSet.empty in
    59:   exes_find_xclosure syms cls exes;
    60:   !cls
    61: 
    62: let function_find_xclosure syms cls bbdfns i =
    63:   let _,_,_,entry = Hashtbl.find bbdfns i in
    64:   let exes =
    65:     match entry with
    66:     | `BBDCL_procedure (_,_,_,exes)
    67:     | `BBDCL_function (_,_,_,_,exes) -> exes
    68:     | _ -> []
    69:   in
    70:   (*
    71:   print_endline ("ROUTINE " ^ si i);
    72:   iter (fun exe -> print_endline (string_of_bexe syms.dfns 0 exe)) exes;
    73:   *)
    74:   exes_find_xclosure syms cls exes
    75: 
    76: let functions_find_xclosures syms cls bbdfns ii =
    77:   IntSet.iter
    78:   (function_find_xclosure syms cls bbdfns)
    79:   ii
    80: 
    81: let tailit syms (uses,child_map,bbdfns) this sr ps vs exes : bexe_t list =
    82:   let ts' = map (fun (_,i) -> `BTYP_var (i,`BTYP_type 0)) vs in
    83:   let pset = fold_left (fun s {pindex=i} -> IntSet.add i s) IntSet.empty ps in
    84:   let parameters = ref [] in
    85:   let descend = descendants child_map this in
    86:   let children = try Hashtbl.find child_map this with Not_found -> [] in
    87:   let can_loop () =
    88:     let varlist = filter (isvariable bbdfns) children in
    89:     let funset = IntSet.filter (isfun bbdfns) descend in
    90: 
    91:     (*
    92:     print_endline ("Procedure has " ^ si (length varlist) ^ " variables");
    93:     print_endline ("Procedure has " ^ si (IntSet.cardinal funset) ^ " child funcs");
    94:     *)
    95: 
    96:     let cls = ref IntSet.empty in
    97:     functions_find_xclosures syms cls bbdfns funset;
    98:     (* THIS FUNCTION IS BEING INLINED .. WE CANNOT LOOKUP ITS EXES!! *)
    99:     exes_find_xclosure syms cls exes;
   100:     (*
   101:     print_endline ("Total xclosures " ^ si (IntSet.cardinal !cls));
   102:     *)
   103:     let kidcls = IntSet.inter !cls funset in
   104:     (*
   105:     print_endline ("Kid xclosures " ^ si (IntSet.cardinal kidcls));
   106:     *)
   107:     try
   108:       IntSet.iter
   109:       (fun i ->
   110:         let usage = Hashtbl.find uses i in
   111:         iter
   112:         (fun j ->
   113:           let usesj =   mem_assoc j usage in
   114:           (*
   115:           if usesj then
   116:             print_endline (si i ^ " uses var " ^ si j)
   117:           ;
   118:           *)
   119:           if usesj then raise Not_found;
   120:         )
   121:         varlist
   122:       )
   123:       kidcls
   124:       ;
   125:       true
   126:     with
   127:     | Not_found -> false
   128:   in
   129:   let jump_done = ref false in
   130:   let lc = !(syms.counter) in incr (syms.counter);
   131:   let start_label = "start_" ^ si lc in
   132: 
   133:   (* note reverse order *)
   134:   (* Weirdly, this works for BOTH tail calls
   135:     and tail applies
   136:   *)
   137:   let cal_tail_call e =
   138:     match length ps with
   139:     | 0 ->
   140:       [
   141:         `BEXE_goto (sr,start_label);
   142:         `BEXE_comment (sr,"tail rec call (0)")
   143:       ]
   144:     | 1 ->
   145:       let {pindex=k} = hd ps in
   146:       [
   147:         `BEXE_goto (sr,start_label);
   148:         `BEXE_init (sr,k,e);
   149:         `BEXE_comment (sr,"tail rec call (1)")
   150:       ]
   151:     | _ ->
   152:       begin match e with
   153:       | `BEXPR_tuple ls,_ ->
   154:         (*
   155:         print_endline ("TUPLE ASSGN " ^ sbe syms.dfns e);
   156:         *)
   157:         (* Parallel Assignment algorithm.
   158:            Given a set of assignments, xi = ei,
   159:            we need a sequence of assignments of xi, ei, tj,
   160:            where tj are fresh variables, xi on left, ei on
   161:            right, and tj on either side, such that no RHS
   162:            term depends on a prior LHS term.
   163: 
   164:            A pair x1 = e1, x2 = e2 which are mutually dependent
   165:            can always by resolved as
   166: 
   167:            t1 = e1; x2 = e2; x1 = t1
   168: 
   169:            Here e1 doesn't depend on a prior term, vaccuously,
   170:            e2 can't depend on t1 since it is fresh, and
   171:            t1 can't depend on anything, since it just a fresh variable
   172: 
   173:            Let's start by taking the equations, and making
   174:            two lists -- a head list and a tail list.
   175:            Head assignments are done first, tails last,
   176:            the head list is in reverse order.
   177: 
   178:            Any equations setting variables no one depends on
   179:            can be moved into the head list, they can safely
   180:            be done first.
   181: 
   182:            Any equations whose RHS depend on nothing are
   183:            moved into the tail list, its safe to do them last.
   184: 
   185:            Any dependencies on variables set by equations
   186:            moved into the tail list can now be removed
   187:            from the remaining equations, since it is determined
   188:            now that these variables will be changed after
   189:            any of the remaining assignments are one.
   190: 
   191:            Repeat until the set of remaining equations is fixed.
   192: 
   193:            We can now pick (somehow!!) an equation, and break
   194:            it into two using a fresh temporary. The temporary
   195:            assignment goes on the head list, the variable
   196:            assignment from the temporary on the tail list,
   197:            and as above, any dependencies on the variable
   198:            can now be removed from the remaining equations.
   199: 
   200:            Repeat everything until the set of remaining
   201:            equations is empty, the result is the reverse
   202:            of the heap list plus the tail list.
   203: 
   204:            This process is certain to terminate, since
   205:            each outer step removes one equation,
   206:            and it is certain to be correct (obvious).
   207: 
   208:            What is NOT clear is that the result is minimal.
   209:            And it is NOT clear how to best 'choose' which
   210:            equation to split.
   211: 
   212: 
   213:         *)
   214:         assert (length ls = length ps);
   215:         let pinits =
   216:           map2
   217:           (fun {pid=name; pindex=i; ptyp=t} e ->
   218:             i,(name,t,e,expr_uses syms descend uses pset e)
   219:           )
   220:           ps ls
   221:         in
   222:         (* strip trivial assignments like x = x *)
   223:         let pinits =
   224:           filter
   225:           (fun (i,(name,t,e,u)) ->
   226:             match e with
   227:             | `BEXPR_name (j,_),_ when i = j -> false
   228:             | _ -> true
   229:           )
   230:           pinits
   231:         in
   232:         let fixdeps pinits =
   233:           let vars = fold_left (fun s (i,_) -> IntSet.add i s) IntSet.empty pinits in
   234:           map
   235:           (fun (i,(name,t,e,u)) ->
   236:             let u = IntSet.remove i (IntSet.inter u vars) in
   237:             i,(name,t,e,u)
   238:           )
   239:           pinits
   240:         in
   241:         (*
   242:         iter
   243:         (fun (i,(name,t,e,u)) ->
   244:           print_endline ("ASG " ^ name ^ "<"^si i ^ "> = " ^ sbe syms.dfns e);
   245:           print_string "  Depends: ";
   246:             IntSet.iter (fun i -> print_string (si i ^ ", ")) u;
   247:           print_endline "";
   248:         )
   249:         pinits;
   250:         *)
   251:         (* this function measures if the expression assigning i
   252:         depends on the old value of j
   253:         *)
   254:         let depend pinits i j =
   255:            let u = match assoc i pinits with _,_,_,u -> u in
   256:            IntSet.mem j u
   257:         in
   258:         (* return true if an assignment in inits depends on j *)
   259:         let used j inits =
   260:           fold_left (fun r (i,_)-> r or depend inits i j) false inits
   261:         in
   262:         let rec aux ((head, middle, tail) as arg) = function
   263:           | [] -> arg
   264:           | (i,(name,ty,e,u)) as h :: ta ->
   265:             if IntSet.cardinal u = 0 then
   266:               aux (head,middle,h::tail) ta
   267:             else if not (used i (middle @ ta)) then
   268:               aux (h::head, middle, tail) ta
   269:             else
   270:               aux (head,h::middle,tail) ta
   271:         in
   272: 
   273:         let printem (h,m,t) =
   274:           print_endline "HEAD:";
   275:           iter
   276:           (fun (i,(name,t,e,u)) ->
   277:             print_endline ("ASG " ^ name ^ "<"^si i ^ "> = " ^ sbe syms.dfns e)
   278:           )
   279:           h;
   280: 
   281:           print_endline "MIDDLE:";
   282:           iter
   283:           (fun (i,(name,t,e,u)) ->
   284:             print_endline ("ASG " ^ name ^ "<"^si i ^ "> = " ^ sbe syms.dfns e)
   285:           )
   286:           m;
   287: 
   288:           print_endline "TAIL:";
   289:           iter
   290:           (fun (i,(name,t,e,u)) ->
   291:             print_endline ("ASG " ^ name ^ "<"^si i ^ "> = " ^ sbe syms.dfns e)
   292:           )
   293:           t
   294:         in
   295: 
   296:         let rec aux2 (hh,mm,tt) =
   297:           let h,m,t = aux ([],[],[]) (fixdeps mm) in
   298:           (* printem (h,m,t); *)
   299:           (* reached a fixpoint? *)
   300:           if length h = 0 && length t = 0 then hh,m,tt (* m = mm *)
   301:           else begin
   302:             (*
   303:             print_endline "Recursing on MIDDLE";
   304:             *)
   305:             aux2 (h @ hh, m, t @ tt)
   306:           end
   307:         in
   308:         let tmplist = ref [] in
   309:         let rec aux3 (hh,mm,tt) =
   310:           let h,m,t = aux2 (hh,mm,tt) in
   311:           (*
   312:           print_endline "SPLIT STEP result:";
   313:           printem(h,m,t);
   314:           *)
   315:           match m with
   316:           | [] -> rev h @ t
   317:           | [_] -> assert false
   318:           | (i,(name,ty,e,u)) :: ta ->
   319:             let k = !(syms.counter) in incr syms.counter;
   320:             let name2 = "_tmp_" ^ name in
   321:             parameters := (ty,k) :: !parameters;
   322:             tmplist := k :: !tmplist;
   323:             let h' = k,(name2,ty,e,IntSet.empty) in
   324:             let e' = `BEXPR_name (k,ts'),ty in
   325:             let t' = i,(name,ty,e',IntSet.empty) in
   326:             aux3 (h' :: h, ta, t' :: t)
   327:         in
   328:         let m = aux3 ([],pinits,[]) in
   329:         (*
   330:         print_endline "FINAL SPLIT UP:";
   331:         iter
   332:         (fun (i,(name,t,e,u)) ->
   333:           print_endline ("ASG " ^ name ^ "<"^si i ^ "> = " ^ sbe syms.dfns e)
   334:         )
   335:         m;
   336:         *)
   337:         let result = ref [] in
   338:         result :=  `BEXE_comment (sr,"tail rec call (3)") :: !result;
   339:         iter
   340:         (fun (i,(name,ty,e,_)) ->
   341:           if mem i !tmplist then
   342:             result := `BEXE_begin :: !result;
   343:           result := `BEXE_init (sr,i,e) :: !result;
   344:         )
   345:         m;
   346:         while length !tmplist > 0 do
   347:           result := `BEXE_end :: !result;
   348:           tmplist := tl !tmplist
   349:         done;
   350:         result :=  `BEXE_goto (sr,start_label) :: !result;
   351:         (*
   352:           print_endline "Tail opt code is:";
   353:           iter (fun x -> print_endline (string_of_bexe syms.dfns 0 x) ) (rev !result);
   354:         *)
   355:         !result
   356: 
   357:       | _ ->
   358:         print_endline "NON TUPLE TAIL CALL";
   359:         let t = snd e in
   360:         let pix =
   361:           try assoc t !parameters
   362:           with Not_found ->
   363:             let pix = !(syms.counter) in incr syms.counter;
   364:             parameters := (t,pix) :: !parameters;
   365:             pix
   366:         in
   367:         let p = `BEXPR_name (pix,ts'),t in
   368:         let n = ref 0 in
   369:         let param_decode =
   370:           map
   371:           (fun {pindex=ix; ptyp=prjt} ->
   372:             let prj = reduce_tbexpr bbdfns (`BEXPR_get_n (!n,p),prjt) in
   373:             incr n;
   374:             `BEXE_init (sr,ix,prj)
   375:           )
   376:           ps
   377:         in
   378:         [
   379:           `BEXE_goto (sr,start_label);
   380:         ]
   381:         @
   382:         param_decode
   383:         @
   384:         [
   385:           `BEXE_init (sr,pix,e);
   386:           `BEXE_comment (sr,"tail rec call (2)")
   387:         ]
   388:       end
   389:   in
   390:   let rec aux tail res = match tail with
   391:   | (`BEXE_call_direct (sr,i,ts,a)) as x :: tail  -> assert false
   392: 
   393:   | (`BEXE_call (sr,(`BEXPR_closure(i,ts),_),a)) as x :: tail
   394:     when (i,ts)=(this,ts') && Flx_cflow.tailable exes [] tail
   395:     ->
   396:     if can_loop ()
   397:     then begin
   398:       (*
   399:       print_endline ("--> Tail rec call optimised " ^ si this);
   400:       *)
   401:       jump_done := true;
   402:       let res = cal_tail_call a @ res
   403:       in aux tail res
   404:     end else begin
   405:       (*
   406:       print_endline ("--> Tail rec call NOT optimised " ^ si this);
   407:       *)
   408:       aux tail (x::res)
   409:     end
   410: 
   411:   | `BEXE_fun_return (sr,(`BEXPR_apply_direct(i,ts,a),_)) :: tail -> assert false
   412: 
   413:   | `BEXE_fun_return (sr,(`BEXPR_apply((`BEXPR_closure (i,ts),_),a),_)) :: tail
   414:     when (i,ts)=(this,ts')
   415:     ->
   416:      (*
   417:      print_endline ("--> Tail rec apply " ^ si this);
   418:      *)
   419:      jump_done := true;
   420:      let res = cal_tail_call a @ res
   421:      in aux tail res
   422: 
   423:   | (`BEXE_call(sr,(`BEXPR_closure (i,ts),_),a)) as x :: tail  ->
   424:     (*
   425:     print_endline ("Untailed call " ^ si i ^ "["^catmap "," (sbt syms.dfns) ts^"]");
   426:     print_endline ("This = " ^ si this);
   427:     print_endline ("ts'=" ^"["^catmap "," (sbt syms.dfns) ts'^"]");
   428:     print_endline "TAIL=";
   429:     iter (fun x -> print_endline (string_of_bexe syms.dfns 0 x)) tail;
   430:     print_endline "-- end of tail --";
   431:     *)
   432:     aux tail (x::res)
   433: 
   434:   | [] -> rev res (* forward order *)
   435:   | h :: t  -> aux t (h::res)
   436:   in
   437:     let exes = aux exes [] in
   438: 
   439:     (* instantiate any parameter temporaries *)
   440:     iter
   441:       (fun (paramtype, parameter) ->
   442:         let entry = `BBDCL_tmp (vs,paramtype) in
   443:         let kids =
   444:           try Hashtbl.find child_map this
   445:           with Not_found -> []
   446:         in
   447:         Hashtbl.replace child_map this (parameter::kids);
   448:         let id = "_trp_" ^ si  parameter in
   449:         Hashtbl.add bbdfns parameter (id,Some this,sr,entry);
   450:       )
   451:     !parameters
   452:     ;
   453:     (* return with posssible label at start *)
   454:     let exes =
   455:       if !jump_done
   456:       then `BEXE_label (sr,start_label) :: exes
   457:       else exes
   458:     in
   459:       (*
   460:       print_endline ("Tailed exes = ");
   461:       iter (fun exe -> print_endline (string_of_bexe syms.dfns 0 exe)) exes;
   462:       *)
   463:       exes
   464: 
End ocaml section to src/flx_tailit.ml[1]