5.45. 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:   | `BTYP_type
    50:     ->
    51:       failwith "[uses_type] Unexpected metatype"
    52: 
    53:   | _ -> iter_btype ut t
    54: 
    55: and uses_exes syms used bbdfns count_inits exes =
    56:   iter (uses_exe syms used bbdfns count_inits) exes
    57: 
    58: and uses_exe syms used bbdfns count_inits (exe:bexe_t) =
    59:   (*
    60:   print_endline ("EXE=" ^ string_of_bexe syms.dfns 0 exe);
    61:   *)
    62:   let ue e = uses_tbexpr syms used bbdfns count_inits e in
    63:   let ui i = uses syms used bbdfns count_inits i in
    64:   let ut t = uses_type syms used bbdfns count_inits t in
    65:   match exe,count_inits with
    66:   | `BEXE_init (_,i,e),false -> ue e
    67:   | _ ->
    68:     iter_bexe ui ue ut nop nop exe
    69: 
    70: 
    71: and uses_tbexpr syms used bbdfns count_inits ((e,t) as x) =
    72:   let ue e = uses_tbexpr syms used bbdfns count_inits e in
    73:   let ut t = uses_type syms used bbdfns count_inits t in
    74:   let ui i = uses syms used bbdfns count_inits i in
    75: 
    76:   (* already done in the iter .. *)
    77:   (*
    78:   ut t;
    79:   *)
    80:   (* use a MAP now *)
    81:   iter_tbexpr ui ignore ut x;
    82: 
    83: and uses_production syms used bbdfns count_inits p =
    84:   let uses_symbol (_,nt) = match nt with
    85:   | `Nonterm ii -> iter (uses syms used bbdfns count_inits) ii
    86:   | `Term i -> () (* HACK! This is a union constructor name  we need to 'use' the union type!! *)
    87:   in
    88:   iter uses_symbol p
    89: 
    90: and faulty_req syms i =
    91:   match Hashtbl.find syms.dfns i with {id=id; sr=sr } ->
    92:   clierr sr (id ^ " is used but has unsatisfied requirement")
    93: 
    94: and uses syms used bbdfns count_inits i =
    95:   let ui i = uses syms used bbdfns count_inits i in
    96:   let ut t = uses_type syms used bbdfns count_inits t in
    97:   let rq reqs =
    98:     let ur (j,ts) =
    99:       if j = 0 then
   100:         faulty_req syms i
   101:       else begin ui j; iter ut ts end
   102:     in
   103:     iter ur reqs
   104:   in
   105:   let ux x = uses_exes syms used bbdfns count_inits x in
   106:   let ue e = uses_tbexpr syms used bbdfns count_inits e in
   107:   if not (IntSet.mem i !used) then
   108:   begin
   109:     match
   110:       try Some (Hashtbl.find bbdfns i)
   111:       with Not_found -> None
   112:     with
   113:     | Some (id,_,_,bbdcl) ->
   114:       used := IntSet.add i !used;
   115:       begin match bbdcl with
   116:       | `BBDCL_function (props,_,(ps,traint),ret,exes) ->
   117:         iter (fun (_,(i,t)) -> ui i; ut t) ps;
   118:         ut ret;
   119:         ux exes
   120: 
   121:       | `BBDCL_procedure (props,_,(ps,traint), exes) ->
   122:         iter (fun (_,(i,t)) -> ui i; ut t) ps;
   123:         ux exes
   124: 
   125:       | `BBDCL_glr (_,_,t,(p,e)) ->
   126:         ut t; ux e;
   127:         uses_production syms used bbdfns count_inits p
   128: 
   129:       | `BBDCL_regmatch (_,_,(ps,traint),t,(_,_,h,_)) ->
   130:         ut t; Hashtbl.iter (fun _ e -> ue e) h;
   131:         iter (fun (_,(i,t)) -> ui i; ut t) ps;
   132: 
   133:       | `BBDCL_reglex (_,_,(ps,traint),i,t,(_,_,h,_)) ->
   134:         ut t; Hashtbl.iter (fun _ e -> ue e) h;
   135:         iter (fun (_,(i,t)) -> ui i; ut t) ps;
   136:         ui i
   137: 
   138:       | `BBDCL_union (_,ps)
   139:         -> ()
   140: 
   141:         (* types of variant arguments are only used if constructed
   142:           .. OR ..  matched against ??
   143:         *)
   144: 
   145:       | `BBDCL_struct (_,ps)
   146:       | `BBDCL_cstruct (_,ps)
   147:         ->
   148:         iter ut (map snd ps)
   149: 
   150:       | `BBDCL_class _ -> ()
   151: 
   152:       | `BBDCL_cclass (_,mems) -> ()
   153: 
   154:       | `BBDCL_val (_,t)
   155:       | `BBDCL_var (_,t)
   156:       | `BBDCL_tmp (_,t) -> ut t
   157: 
   158:       | `BBDCL_const (_,t,_,reqs) -> ut t; rq reqs
   159:       | `BBDCL_fun (_,_,ps, ret, _,reqs,_) -> iter ut ps; ut ret; rq reqs
   160: 
   161:       | `BBDCL_callback (_,_,ps_cf, ps_c, _, ret, reqs,_) ->
   162:         iter ut ps_cf;
   163:         iter ut ps_c;
   164:         ut ret; rq reqs
   165: 
   166:       | `BBDCL_proc (_,_,ps, _, reqs)  -> iter ut ps; rq reqs
   167: 
   168:       | `BBDCL_abs (_,_,_,reqs) -> rq reqs
   169:       | `BBDCL_insert (_,s,ikind,reqs)  -> rq reqs
   170:       | `BBDCL_nonconst_ctor (_,_,unt,_,ct) ->
   171:         ut unt; ut ct
   172: 
   173:       end
   174:     | None ->
   175:       let id =
   176:         try match Hashtbl.find syms.dfns i with {id=id} -> id
   177:         with Not_found -> "not found in unbound symbol table"
   178:       in
   179:       failwith
   180:       (
   181:         "[Flx_use.uses] Cannot find bound defn for " ^ id ^ "<"^si i ^ ">"
   182:       )
   183:   end
   184: 
   185: let find_roots syms bbdfns
   186:   (root:bid_t)
   187:   (bifaces:biface_t list)
   188: =
   189: 
   190:   (* make a list of the root and all exported functions,
   191:   add exported types and components thereof into the used
   192:   set now too
   193:   *)
   194:   let roots = ref (IntSet.singleton root) in
   195:   iter
   196:   (function
   197:      | `BIFACE_export_fun (_,x,_) -> roots := IntSet.add x !roots
   198:      | `BIFACE_export_type (_,t,_) ->
   199:         uses_type syms roots bbdfns true t
   200:   )
   201:   bifaces
   202:   ;
   203:   syms.roots := !roots
   204: 
   205: let cal_use_closure syms bbdfns (count_inits:bool) =
   206:   let u = ref IntSet.empty in
   207:   let v : IntSet.t  = !(syms.roots) in
   208:   let v = ref v in
   209: 
   210:   let add j =
   211:     if not (IntSet.mem j !u) then
   212:     begin
   213:        (*
   214:        print_endline ("Scanning " ^ si j);
   215:        *)
   216:        u:= IntSet.add j !u;
   217:        uses syms v bbdfns count_inits j
   218:     end
   219:   in
   220:   while not (IntSet.is_empty !v) do
   221:     let j = IntSet.choose !v in
   222:     v := IntSet.remove j !v;
   223:     add j
   224:   done;
   225:   !u
   226: 
   227: let full_use_closure syms bbdfns = cal_use_closure syms bbdfns true
   228: 
   229: let copy_used syms bbdfns =
   230:   let h = Hashtbl.create 97 in
   231:   let u = full_use_closure syms bbdfns in
   232:   IntSet.iter
   233:   begin fun i ->
   234:     (* print_endline ("Copying " ^ si i); *)
   235:     Hashtbl.add h i (Hashtbl.find bbdfns i)
   236:   end
   237:   u;
   238:   h
   239: 
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: 
End ocaml section to src/flx_child.mli[1]
Start ocaml section to src/flx_child.ml[1 /1 ]
     1: # 31 "./lpsrc/flx_child.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open List
     7: 
     8: type child_map_t =
     9:   (bid_t, bid_t list) Hashtbl.t
    10: 
    11: let find_children childmap parent =
    12:   try Hashtbl.find childmap parent with Not_found -> []
    13: 
    14: let is_child childmap parent child =
    15:   mem child (find_children childmap parent)
    16: 
    17: let add_child childmap parent child =
    18:   let kids = find_children childmap parent in
    19:   Hashtbl.replace childmap parent (child::kids)
    20: 
    21: let rec is_ancestor bbdfns child anc =
    22:   let _,parent,_,_ = Hashtbl.find bbdfns child in
    23:   match parent with
    24:   | None -> false
    25:   | Some x ->
    26:     if x = anc then true
    27:     else is_ancestor bbdfns x anc
    28: 
    29: let remove_child childmap parent child =
    30:   let kids = find_children childmap parent in
    31:   let kids = filter (fun i -> i <> child) kids in
    32:   Hashtbl.replace childmap parent kids
    33: 
    34: (* closure of index with respect to children, EXCLUDES self *)
    35: let rec descendants child_map index =
    36:   let d = ref IntSet.empty in
    37:   let children = find_children child_map index in
    38:   iter
    39:   (fun i ->
    40:     if not (IntSet.mem i !d) then
    41:     begin
    42:       d := IntSet.add i !d;
    43:       d := IntSet.union !d (descendants child_map i)
    44:     end
    45:   )
    46:   children
    47:   ;
    48:   !d
    49: 
    50: 
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:   (string * (int * btypecode_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)) vs in
    83:   let pset = fold_left (fun s (_,(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 (_,(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 (name,(i,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 (_,(ix,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
   392:     when (i,ts)=(this,ts') && Flx_cflow.tailable exes [] tail
   393:     ->
   394:     if can_loop ()
   395:     then begin
   396:       (*
   397:       print_endline ("--> Tail rec call optimised " ^ si this);
   398:       *)
   399:       jump_done := true;
   400:       let res = cal_tail_call a @ res
   401:       in aux tail res
   402:     end else begin
   403:       (*
   404:       print_endline ("--> Tail rec call NOT optimised " ^ si this);
   405:       *)
   406:       aux tail (x::res)
   407:     end
   408: 
   409:   | `BEXE_fun_return (sr,(`BEXPR_apply_direct(i,ts,a),_)) :: tail
   410:     when (i,ts)=(this,ts')
   411:     ->
   412:      (*
   413:      print_endline ("--> Tail rec apply " ^ si this);
   414:      *)
   415:      jump_done := true;
   416:      let res = cal_tail_call a @ res
   417:      in aux tail res
   418: 
   419:   | (`BEXE_call_direct (sr,i,ts,a)) as x :: tail  ->
   420:     (*
   421:     print_endline ("Untailed call " ^ si i ^ "["^catmap "," (sbt syms.dfns) ts^"]");
   422:     print_endline ("This = " ^ si this);
   423:     print_endline ("ts'=" ^"["^catmap "," (sbt syms.dfns) ts'^"]");
   424:     print_endline "TAIL=";
   425:     iter (fun x -> print_endline (string_of_bexe syms.dfns 0 x)) tail;
   426:     print_endline "-- end of tail --";
   427:     *)
   428:     aux tail (x::res)
   429: 
   430:   | [] -> rev res (* forward order *)
   431:   | h :: t  -> aux t (h::res)
   432:   in
   433:     let exes = aux exes [] in
   434: 
   435:     (* instantiate any parameter temporaries *)
   436:     iter
   437:       (fun (paramtype, parameter) ->
   438:         let entry = `BBDCL_tmp (vs,paramtype) in
   439:         let kids =
   440:           try Hashtbl.find child_map this
   441:           with Not_found -> []
   442:         in
   443:         Hashtbl.replace child_map this (parameter::kids);
   444:         let id = "_trp_" ^ si  parameter in
   445:         Hashtbl.add bbdfns parameter (id,Some this,sr,entry);
   446:       )
   447:     !parameters
   448:     ;
   449:     (* return with posssible label at start *)
   450:     let exes =
   451:       if !jump_done
   452:       then `BEXE_label (sr,start_label) :: exes
   453:       else exes
   454:     in
   455:       (*
   456:       print_endline ("Tailed exes = ");
   457:       iter (fun exe -> print_endline (string_of_bexe syms.dfns 0 exe)) exes;
   458:       *)
   459:       exes
   460: 
End ocaml section to src/flx_tailit.ml[1]