5.48. Elide unused entries

Name binding pass 2.
Start ocaml section to src/flx_mkcls.mli[1 /1 ]
     1: # 6 "./lpsrc/flx_mkcls.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_typing
     5: open Flx_mtypes1
     6: open Flx_mtypes2
     7: 
     8: val make_closures:
     9:   sym_state_t ->
    10:   fully_bound_symbol_table_t  -> unit
    11: 
End ocaml section to src/flx_mkcls.mli[1]
Start ocaml section to src/flx_mkcls.ml[1 /1 ]
     1: # 18 "./lpsrc/flx_mkcls.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_mtypes1
     6: open Flx_mtypes2
     7: open Flx_print
     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_exceptions
    15: open Flx_use
    16: 
    17: let gen_closure syms bbdfns i =
    18:   let j = !(syms.counter) in incr syms.counter;
    19:   let id,parent,sr,entry = Hashtbl.find bbdfns i in
    20:   match entry with
    21:   | `BBDCL_proc (props,vs,ps,c,reqs) ->
    22:     let arg_t =
    23:       match ps with | [t] -> t | ps -> `BTYP_tuple ps
    24:     in
    25:     let ts = map (fun (_,i) -> `BTYP_var (i,`BTYP_type)) vs in
    26:     let ps,a =
    27:       let n = !(syms.counter) in incr syms.counter;
    28:       let name = "_a" ^ si n in
    29:       let ventry = `BBDCL_val (vs,arg_t) in
    30:       Hashtbl.add bbdfns n (name,Some j,sr,ventry);
    31:       [name,(n,arg_t)],(`BEXPR_name (n,ts),arg_t)
    32:     in
    33: 
    34:     let exes : bexe_t list =
    35:       [
    36:         `BEXE_call_prim (sr,i,ts,a);
    37:         `BEXE_proc_return sr
    38:       ]
    39:     in
    40:     let entry = `BBDCL_procedure ([],vs,(ps,None),exes) in
    41:     Hashtbl.add bbdfns j (id,parent,sr,entry);
    42:     j
    43: 
    44:   | `BBDCL_fun (props,vs,ps,ret,c,reqs,_) ->
    45:     let ts = map (fun (_,i) -> `BTYP_var (i,`BTYP_type)) vs in
    46:     let arg_t =
    47:       match ps with | [t] -> t | ps -> `BTYP_tuple ps
    48:     in
    49:     let ps,a =
    50:       let n = !(syms.counter) in incr syms.counter;
    51:       let name = "_a" ^ si n in
    52:       let ventry = `BBDCL_val (vs,arg_t) in
    53:       Hashtbl.add bbdfns n (name,Some j,sr,ventry);
    54:       [name,(n,arg_t)],(`BEXPR_name (n,ts),arg_t)
    55:     in
    56:     let e = `BEXPR_apply_prim (i,ts,a),ret in
    57:     let exes : bexe_t list = [`BEXE_fun_return (sr,e)] in
    58:     let entry = `BBDCL_function ([],vs,(ps,None),ret,exes) in
    59:     Hashtbl.add bbdfns j (id,parent,sr,entry);
    60:     j
    61: 
    62:   | _ -> assert false
    63: 
    64: 
    65: let mkcls syms bbdfns all_closures i ts =
    66:   let j =
    67:     try Hashtbl.find syms.wrappers i
    68:     with Not_found ->
    69:       let j = gen_closure syms bbdfns i in
    70:       Hashtbl.add syms.wrappers i j;
    71:       j
    72:   in
    73:     all_closures := IntSet.add j !all_closures;
    74:     `BEXPR_closure (j,ts)
    75: 
    76: let check_prim syms bbdfns all_closures i ts =
    77:   let _,_,_,entry = Hashtbl.find bbdfns i in
    78:   match entry with
    79:   | `BBDCL_proc _
    80:   | `BBDCL_fun _ ->
    81:     mkcls syms bbdfns all_closures i ts
    82:   | _ ->
    83:     all_closures := IntSet.add i !all_closures;
    84:     `BEXPR_closure (i,ts)
    85: 
    86: let idt t = t
    87: 
    88: let ident x = x
    89: 
    90: let rec adj_cls syms bbdfns all_closures e =
    91:   let adj e = adj_cls syms bbdfns all_closures e in
    92:   match Flx_maps.map_tbexpr ident adj idt e with
    93:   | `BEXPR_closure (i,ts),t ->
    94:     check_prim syms bbdfns all_closures i ts,t
    95: 
    96:   (* Direct calls to non-stacked functions require heap
    97:      but not a clone ..
    98:   *)
    99:   | `BEXPR_apply_direct (i,ts,a),t as x ->
   100:     all_closures := IntSet.add i !all_closures;
   101:     x
   102: 
   103:   (* Class method -- ASSUMED NOT A PRIMITIVE -- seem to require
   104:      heap closures: not sure why this should be. They cannot
   105:      be inlined into their parent at the moment, since it is a class,
   106:      and any 'inlined' version would be an actual C++ class method.
   107:      Which would also be a kind of stack call. In any case
   108:      we cannot optimise this yet.
   109:   *)
   110:   | `BEXPR_method_closure (_,i,_),_ as x ->
   111:     all_closures := IntSet.add i !all_closures;
   112:     x
   113: 
   114:   (* HUM .. *)
   115:   (*
   116:   | `BEXPR_parse (_,prds),_ as x ->
   117:     iter (fun i -> all_closures := IntSet.add i !all_closures) prds;
   118:     x
   119:   *)
   120: 
   121:   | x -> x
   122: 
   123: 
   124: let process_exe syms bbdfns all_closures (exe : bexe_t) : bexe_t =
   125:   let ue e = adj_cls syms bbdfns all_closures e in
   126:   match exe with
   127:   | `BEXE_axiom_check _ -> assert false
   128:   | `BEXE_call_prim (sr,i,ts,e2)  -> `BEXE_call_prim (sr,i,ts, ue e2)
   129: 
   130:   | `BEXE_call_direct (sr,i,ts,e2)  ->
   131:     all_closures := IntSet.add i !all_closures;
   132:     `BEXE_call_direct (sr,i,ts, ue e2)
   133: 
   134:   | `BEXE_call_method_direct (sr,e1,i,ts,e2)  ->
   135:     all_closures := IntSet.add i !all_closures;
   136:     `BEXE_call_method_direct (sr,ue e1,i,ts, ue e2)
   137: 
   138:   | `BEXE_call_method_stack (sr,e1,i,ts,e2)  ->
   139:     (* stack calls do use closures -- but not heap allocated ones *)
   140:     `BEXE_call_method_stack (sr,ue e1,i,ts, ue e2)
   141: 
   142: 
   143:   | `BEXE_jump_direct (sr,i,ts,e2)  ->
   144:     all_closures := IntSet.add i !all_closures;
   145:     `BEXE_jump_direct (sr,i,ts, ue e2)
   146: 
   147:   | `BEXE_call_stack (sr,i,ts,e2)  ->
   148:     (* stack calls do use closures -- but not heap allocated ones *)
   149:     `BEXE_call_stack (sr,i,ts, ue e2)
   150: 
   151:   | `BEXE_apply_ctor (sr,i1,i2,ts,i3,e2) ->
   152:     all_closures := IntSet.add i2 !all_closures;
   153:     all_closures := IntSet.add i3 !all_closures;
   154:     `BEXE_apply_ctor(sr,i1,i2,ts,i3,ue e2)
   155: 
   156:   | `BEXE_apply_ctor_stack (sr,i1,i2,ts,i3,e2) ->
   157:     all_closures := IntSet.add i2 !all_closures;
   158:     `BEXE_apply_ctor_stack(sr,i1,i2,ts,i3,ue e2)
   159: 
   160:   | `BEXE_call (sr,e1,e2)  -> `BEXE_call (sr,ue e1, ue e2)
   161:   | `BEXE_jump (sr,e1,e2)  -> `BEXE_jump (sr,ue e1, ue e2)
   162: 
   163:   | `BEXE_loop (sr,i,e) -> `BEXE_loop (sr,i, ue e)
   164:   | `BEXE_ifgoto (sr,e,l) -> `BEXE_ifgoto (sr, ue e,l)
   165:   | `BEXE_ifnotgoto (sr,e,l) -> `BEXE_ifnotgoto (sr, ue e,l)
   166:   | `BEXE_fun_return (sr,e) -> `BEXE_fun_return (sr,ue e)
   167: 
   168:   | `BEXE_init (sr,i,e) -> `BEXE_init (sr,i,ue e)
   169:   | `BEXE_assign (sr,e1,e2) -> `BEXE_assign (sr, ue e1, ue e2)
   170:   | `BEXE_assert (sr,e) -> `BEXE_assert (sr, ue e)
   171:   | `BEXE_assert2 (sr,sr2,e) -> `BEXE_assert2 (sr, sr2,ue e)
   172: 
   173:   | `BEXE_svc (sr,i) -> exe
   174: 
   175:   | `BEXE_label _
   176:   | `BEXE_halt _
   177:   | `BEXE_goto _
   178:   | `BEXE_code _
   179:   | `BEXE_nonreturn_code _
   180:   | `BEXE_comment _
   181:   | `BEXE_nop _
   182:   | `BEXE_proc_return _
   183:   | `BEXE_begin
   184:   | `BEXE_end
   185:     -> exe
   186: 
   187: let process_exes syms bbdfns all_closures exes =
   188:   map (process_exe syms bbdfns all_closures) exes
   189: 
   190: let process_entry syms bbdfns all_closures i =
   191:   let ue e = adj_cls syms bbdfns all_closures e in
   192:   let id,parent,sr,entry = Hashtbl.find bbdfns i in
   193:   match entry with
   194:   | `BBDCL_function (props,vs,ps,ret,exes) ->
   195:     let exes = process_exes syms bbdfns all_closures exes in
   196:     let entry = `BBDCL_function (props,vs,ps,ret,exes) in
   197:     Hashtbl.replace bbdfns i (id,parent,sr,entry)
   198: 
   199:   | `BBDCL_procedure (props,vs,ps,exes) ->
   200:     let exes = process_exes syms bbdfns all_closures exes in
   201:     let entry = `BBDCL_procedure (props,vs,ps,exes) in
   202:     Hashtbl.replace bbdfns i (id,parent,sr,entry)
   203: 
   204:   | `BBDCL_glr (props,vs,t,(p,exes)) ->
   205:     let exes = process_exes syms bbdfns all_closures exes in
   206:     let entry = `BBDCL_glr (props,vs,t,(p,exes)) in
   207:     Hashtbl.replace bbdfns i (id,parent,sr,entry)
   208: 
   209:   | `BBDCL_regmatch (props,vs,ps,t,(a,j,h,m)) ->
   210:     Hashtbl.iter (fun i e -> Hashtbl.replace h i (ue e)) h
   211: 
   212:   | `BBDCL_reglex (props,vs,ps,i,t,(a,j,h,m)) ->
   213:     Hashtbl.iter (fun i e -> Hashtbl.replace h i (ue e)) h
   214: 
   215:   | _ -> ()
   216: 
   217: let set_closure bbdfns p i =
   218:   let id,parent,sr,entry = Hashtbl.find bbdfns i in
   219:    match entry with
   220:   | `BBDCL_function (props,vs,ps,ret,exes) ->
   221:     let entry = `BBDCL_function (p :: props,vs,ps,ret,exes) in
   222:     Hashtbl.replace bbdfns i (id,parent,sr,entry);
   223: 
   224:   | `BBDCL_procedure (props,vs,ps,exes) ->
   225:     let entry = `BBDCL_procedure (p :: props,vs,ps,exes) in
   226:     Hashtbl.replace bbdfns i (id,parent,sr,entry)
   227: 
   228:   | `BBDCL_regmatch (props,vs,ps,t,x) ->
   229:     let entry = `BBDCL_regmatch (p :: props, vs, ps, t, x) in
   230:     Hashtbl.replace bbdfns i (id,parent,sr,entry)
   231: 
   232:   | `BBDCL_reglex (props,vs,ps,le,t,x) ->
   233:     let entry = `BBDCL_reglex (p :: props, vs, ps, le, t, x) in
   234:     Hashtbl.replace bbdfns i (id,parent,sr,entry)
   235: 
   236:   | `BBDCL_glr (props, vs, t, x) ->
   237:     let entry = `BBDCL_glr (p :: props, vs, t, x) in
   238:     Hashtbl.replace bbdfns i (id,parent,sr,entry)
   239: 
   240:   | _ -> ()
   241: 
   242: let make_closures syms bbdfns =
   243:   (*
   244:   let used = ref IntSet.empty in
   245:   let uses i = Flx_use.uses syms used bbdfns true i in
   246:   IntSet.iter uses !(syms.roots);
   247:   *)
   248: 
   249:   let all_closures = ref IntSet.empty in
   250:   let used = full_use_closure syms bbdfns in
   251:   IntSet.iter (process_entry syms bbdfns all_closures ) used;
   252:   (*
   253:   IntSet.iter (set_closure bbdfns `Heap_closure) (IntSet.union !all_closures !(syms.roots));
   254:   *)
   255: 
   256:   (* Now root proc might not need a closure .. since it can be
   257:      executed all at once
   258:   *)
   259:   IntSet.iter (set_closure bbdfns `Heap_closure) !all_closures
   260: 
   261: 
   262: 
End ocaml section to src/flx_mkcls.ml[1]