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