5.58. Elide unused entries

Name binding pass 2.
Start ocaml section to src/flx_inst.mli[1 /1 ]
     1: # 6 "./lpsrc/flx_inst.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_typing
     5: open Flx_mtypes2
     6: 
     7: val instantiate:
     8:   sym_state_t ->
     9:   fully_bound_symbol_table_t ->
    10:   bool -> (* instantiate parameters? *)
    11:   bid_t ->
    12:   biface_t list ->
    13:   unit
    14: 
End ocaml section to src/flx_inst.mli[1]
Start ocaml section to src/flx_inst.ml[1 /1 ]
     1: # 21 "./lpsrc/flx_inst.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_maps
    16: open Flx_prop
    17: 
    18: let null_table = Hashtbl.create 3
    19: 
    20: let add_inst syms bbdfns ref_insts1 (i,ts) =
    21:     (*
    22:     print_endline ("Attempt to register instance " ^ si i ^ "[" ^
    23:     catmap ", " (sbt syms.dfns) ts ^ "]");
    24:     *)
    25:   let i,ts = Flx_typeclass.fixup_typeclass_instance syms bbdfns i ts in
    26:     (*
    27:     print_endline ("remapped to instance " ^ si i ^ "[" ^
    28:     catmap ", " (sbt syms.dfns) ts ^ "]");
    29:     *)
    30:   let x = i, map (fun t -> reduce_type (lstrip syms.dfns t)) ts in
    31:   let has_variables =
    32:     fold_left
    33:     (fun truth t -> truth ||
    34:       try var_occurs t
    35:       with _ -> failwith ("[add_inst] metatype in var_occurs for " ^ sbt syms.dfns t)
    36:     )
    37:     false
    38:     ts
    39:   in
    40:   if has_variables then
    41:   failwith
    42:   (
    43:     "Attempt to register instance " ^ si i ^ "[" ^
    44:     catmap ", " (sbt syms.dfns) ts ^
    45:     "] with type variable in a subscript"
    46:   )
    47:   ;
    48:   if not (FunInstSet.mem x !ref_insts1)
    49:   && not (Hashtbl.mem syms.instances x)
    50:   then begin
    51:     ref_insts1 := FunInstSet.add x !ref_insts1
    52:   end
    53: 
    54: let rec process_expr syms bbdfns ref_insts1 hvarmap sr ((e,t) as be) =
    55:   (*
    56:   print_endline ("Process expr " ^ sbe syms.dfns be ^ " .. raw type " ^ sbt syms.dfns t);
    57:   print_endline (" .. instantiated type " ^ string_of_btypecode syms.dfns (varmap_subst hvarmap t));
    58:   *)
    59:   let ue e = process_expr syms bbdfns ref_insts1 hvarmap sr e in
    60:   let ui i ts = add_inst syms bbdfns ref_insts1 (i,ts) in
    61:   let ut t = register_type_r ui syms bbdfns [] sr t in
    62:   let vs t = varmap_subst hvarmap t in
    63:   let t' = vs t in
    64:   ut t'
    65:   ;
    66:   (* CONSIDER DOING THIS WITH A MAP! *)
    67:   begin match e with
    68:   | `BEXPR_parse (e,ii) ->
    69:     ue e; iter (fun i -> ui i []) ii
    70: 
    71:   | `BEXPR_deref e
    72:   | `BEXPR_get_n (_,e)
    73:   | `BEXPR_match_case (_,e)
    74:   | `BEXPR_case_arg (_,e)
    75:   | `BEXPR_case_index e
    76:     -> ue e
    77: 
    78:   | `BEXPR_get_named (i,((oe,ot) as obj)) ->
    79:     (*
    80:     print_endline "Get named: class member";
    81:     *)
    82:     ue obj;
    83:     (*
    84:     print_endline "Register object expr";
    85:     *)
    86:     (* instantiate member with binding for class type parameters *)
    87:     begin match ot with
    88:     | `BTYP_inst (j,ts)
    89:     | `BTYP_lvalue (`BTYP_inst (j,ts)) ->
    90:       (*
    91:       print_endline ("Register member " ^ si i^ ", ts=" ^ catmap "," (sbt syms.dfns) ts);
    92:       *)
    93:       let ts = map vs ts in
    94:       ui i ts
    95:     | _ -> assert false
    96:     end
    97: 
    98:   | `BEXPR_apply_prim (index,ts,a)
    99:   | `BEXPR_apply_direct (index,ts,a)
   100:   | `BEXPR_apply_struct (index,ts,a)
   101:   | `BEXPR_apply_stack (index,ts,a)
   102:   | `BEXPR_apply ((`BEXPR_closure (index,ts),_),a) ->
   103:     (*
   104:     print_endline "apply direct";
   105:     *)
   106:     let id,parent,sr2,entry =
   107:       try Hashtbl.find bbdfns index
   108:       with _ -> failwith ("[process_expr(apply instance)] Can't find index " ^ si index)
   109:     in
   110:     begin match entry with
   111:     (* function type not needed for direct call *)
   112:     | `BBDCL_fun _
   113:     | `BBDCL_callback _
   114:     | `BBDCL_function _
   115:     | `BBDCL_nonconst_ctor _
   116:       ->
   117:       let ts = map vs ts in
   118:       ui index ts; ue a
   119:     | `BBDCL_procedure _ ->
   120:       failwith "Use of mangled procedure in expression! (should have been lifted out)"
   121: 
   122:     (* the remaining cases are struct/variant type constructors,
   123:     which probably don't need types either .. fix me!
   124:     *)
   125:     (* | _ -> ue f; ue a *)
   126:     | _ ->
   127:       (*
   128:       print_endline "struct component?";
   129:       *)
   130:       ui index ts; ue a
   131:     end
   132: 
   133:   | `BEXPR_apply_method_direct (obj,meth,ts,a)
   134:   | `BEXPR_apply_method_stack (obj,meth,ts,a)
   135:   | `BEXPR_apply ((`BEXPR_method_closure (obj,meth,ts),_),a) ->
   136:     (*
   137:     print_endline "method apply";
   138:     *)
   139:     ue obj;
   140:     ui meth ts;
   141:     ue a
   142: 
   143:   | `BEXPR_apply (e1,e2) ->
   144:     (*
   145:     print_endline "Simple apply";
   146:     *)
   147:     ue e1; ue e2
   148: 
   149:   | `BEXPR_tuple es ->
   150:     iter ue es;
   151:     register_tuple syms (vs t)
   152: 
   153:   | `BEXPR_record es ->
   154:     let ss,es = split es in
   155:     iter ue es;
   156:     register_tuple syms (vs t)
   157: 
   158:   | `BEXPR_variant (s,e) ->
   159:     ue e
   160: 
   161:   | `BEXPR_case (_,t) -> ut (vs t)
   162: 
   163:   | `BEXPR_ref (i,ts)
   164:   | `BEXPR_name (i,ts)
   165:   | `BEXPR_closure (i,ts)
   166:     ->
   167:     (* substitute out display variables *)
   168:     (*
   169:     print_endline ("Raw Variable " ^ si i ^ "[" ^ catmap "," (sbt syms.dfns) ts ^ "]");
   170:     *)
   171:     let ts = map vs ts in
   172:     (*
   173:     print_endline ("Variable with mapped ts " ^ si i ^ "[" ^ catmap "," (sbt syms.dfns) ts ^ "]");
   174:     *)
   175:     ui i ts;
   176:     (*
   177:     print_endline "Instance done";
   178:     *)
   179:     iter ut ts
   180:     (*
   181:     ;
   182:     print_endline "ts done";
   183:     *)
   184: 
   185:   | `BEXPR_new e -> ue e
   186: 
   187:   | `BEXPR_method_closure (e,i,ts) ->
   188:     (*
   189:     print_endline "method closure";
   190:     *)
   191:     ue e;
   192:     let ts = map vs ts in
   193:     ui i ts; iter ut ts
   194: 
   195:   | `BEXPR_literal _ -> ()
   196:   | `BEXPR_expr (_,t) -> ut t
   197:   | `BEXPR_range_check (e1,e2,e3) -> ue e1; ue e2; ue e3
   198:   | `BEXPR_coerce (e,t) -> ue e; ut t
   199:   end
   200: 
   201: and process_exe syms bbdfns ref_insts1 ts hvarmap (exe:bexe_t) =
   202:   let ue sr e = process_expr syms bbdfns ref_insts1 hvarmap sr e in
   203:   let uis i ts = add_inst syms bbdfns ref_insts1 (i,ts) in
   204:   let ui i = uis i ts in
   205:   (*
   206:   print_endline ("processing exe " ^ string_of_bexe syms.dfns 0 exe);
   207:   print_endline ("With ts = " ^ catmap "," (sbt syms.dfns) ts);
   208:   *)
   209:   (* TODO: replace with a map *)
   210:   match exe with
   211:   | `BEXE_axiom_check _ -> assert false
   212:   | `BEXE_call_prim (sr,i,ts,e2)
   213:   | `BEXE_call_direct (sr,i,ts,e2)
   214:   | `BEXE_jump_direct (sr,i,ts,e2)
   215:   | `BEXE_call_stack (sr,i,ts,e2)
   216:     ->
   217:     let ut t = register_type_r uis syms bbdfns [] sr t in
   218:     let vs t = varmap_subst hvarmap t in
   219:     let ts = map vs ts in
   220:     iter ut ts;
   221:     uis i ts;
   222:     ue sr e2
   223: 
   224:   | `BEXE_call_method_direct (sr,obj,meth,ts,a)
   225:   | `BEXE_call_method_stack (sr,obj,meth,ts,a) ->
   226:     let ut t = register_type_r uis syms bbdfns [] sr t in
   227:     let vs t = varmap_subst hvarmap t in
   228:     let ts = map vs ts in
   229:     ue sr obj;
   230:     iter ut ts;
   231:     uis meth ts;
   232:     ue sr a
   233: 
   234:   | `BEXE_apply_ctor (sr,i1,i2,ts,i3,e2)
   235:   | `BEXE_apply_ctor_stack (sr,i1,i2,ts,i3,e2)
   236:     ->
   237:     let ut t = register_type_r uis syms bbdfns [] sr t in
   238:     let vs t = varmap_subst hvarmap t in
   239:     let ts = map vs ts in
   240:     iter ut ts;
   241:     ui i1; (* this is wrong?: initialisation is not use .. *)
   242:     uis i2 ts;
   243:     (*
   244:     print_endline ("INSTANTIATING CLASS " ^ si i2 ^ "<"^catmap "," (sbt syms.dfns) ts^">");
   245:     *)
   246:     uis i3 ts;
   247:     (*
   248:     print_endline ("INSTANTIATING CONSTRUCTOR " ^ si i3 ^ "<"^catmap "," (sbt syms.dfns) ts^">");
   249:     *)
   250:     ue sr e2
   251: 
   252:   | `BEXE_call (sr,e1,e2)
   253:   | `BEXE_jump (sr,e1,e2)
   254:     -> ue sr e1; ue sr e2
   255: 
   256:   | `BEXE_assert (sr,e)
   257:   | `BEXE_loop (sr,_,e)
   258:   | `BEXE_ifgoto (sr,e,_)
   259:   | `BEXE_ifnotgoto (sr,e,_)
   260:   | `BEXE_fun_return (sr,e)
   261:   | `BEXE_yield (sr,e)
   262:     ->
   263:       ue sr e
   264: 
   265:   | `BEXE_assert2 (sr,_,e1,e2)
   266:     ->
   267:      begin match e1 with Some e -> ue sr e | None -> () end;
   268:      ue sr e2
   269: 
   270:   | `BEXE_init (sr,i,e) ->
   271:     let vs' = get_vs bbdfns i in
   272:     let ts = map (fun (s,i) -> `BTYP_var (i,`BTYP_type 0)) vs' in
   273:     let ts = map (varmap_subst hvarmap) ts in
   274:     uis i ts; (* this is wrong?: initialisation is not use .. *)
   275:     ue sr e
   276: 
   277:   | `BEXE_assign (sr,e1,e2) -> ue sr e1; ue sr e2
   278: 
   279:   | `BEXE_svc (sr,i) ->
   280:     let vs' = get_vs bbdfns i in
   281:     let ts = map (fun (s,i) -> `BTYP_var (i,`BTYP_type 0)) vs' in
   282:     let ts = map (varmap_subst hvarmap) ts in
   283:     uis i ts
   284: 
   285:   | `BEXE_label _
   286:   | `BEXE_halt _
   287:   | `BEXE_goto _
   288:   | `BEXE_code _
   289:   | `BEXE_nonreturn_code _
   290:   | `BEXE_comment _
   291:   | `BEXE_nop _
   292:   | `BEXE_proc_return _
   293:   | `BEXE_begin
   294:   | `BEXE_end
   295:     -> ()
   296: 
   297: and process_exes syms bbdfns ref_insts1 ts hvarmap exes =
   298:   iter (process_exe syms bbdfns ref_insts1 ts hvarmap) exes
   299: 
   300: and process_function syms bbdfns hvarmap ref_insts1 index sr argtypes ret exes ts =
   301:   (*
   302:   print_endline ("Process function " ^ si index);
   303:   *)
   304:   process_exes syms bbdfns ref_insts1 ts hvarmap exes ;
   305:   (*
   306:   print_endline ("Done Process function " ^ si index);
   307:   *)
   308: 
   309: and process_production syms bbdfns ref_insts1 p ts =
   310:   let uses_symbol (_,nt) = match nt with
   311:   | `Nonterm ii -> iter (fun i -> add_inst syms bbdfns ref_insts1 (i,ts)) ii
   312:   | `Term i -> () (* HACK! This is a union constructor name  we need to 'use' the union type!! *)
   313:   in
   314:   iter uses_symbol p
   315: 
   316: and process_inst syms bbdfns instps ref_insts1 i ts inst =
   317:   let uis i ts = add_inst syms bbdfns ref_insts1 (i,ts) in
   318:   let ui i = uis i ts in
   319:   let id,parent,sr,entry =
   320:     try Hashtbl.find bbdfns i
   321:     with Not_found -> failwith ("[process_inst] Can't find index " ^ si i)
   322:   in
   323:   let do_reqs vs reqs =
   324:     iter (
   325:       fun (i,ts)->
   326:       if i = 0 then
   327:         clierr sr ("Entity " ^ id ^ " has uninstantiable requirements");
   328:       uis i( map vs ts)
   329:     )
   330:     reqs
   331:   in
   332:   let ue hvarmap e = process_expr syms bbdfns ref_insts1 hvarmap sr e in
   333:   let rtr t = register_type_r uis syms bbdfns [] sr t in
   334:   let rtnr t = register_type_nr syms (reduce_type (lstrip syms.dfns t)) in
   335:   if syms.compiler_options.print_flag then
   336:   print_endline ("//Instance "^si inst ^ "="^id^"<" ^ si i ^ ">[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]");
   337:   match entry with
   338:   | `BBDCL_glr (props,vs,ret, (p,exes)) ->
   339:     assert (length vs = length ts);
   340:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   341:     let hvarmap = hashtable_of_list vars in
   342:     process_function syms bbdfns null_table ref_insts1 i sr [] ret exes ts;
   343:     process_production syms bbdfns ref_insts1 p ts
   344: 
   345:   | `BBDCL_regmatch (props,vs,(ps,traint),ret,(_,_,h,_))  ->
   346:     let argtypes = map (fun {ptyp=t}->t) ps in
   347:     assert (length vs = length ts);
   348:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   349:     let hvarmap = hashtable_of_list vars in
   350:     Hashtbl.iter
   351:     (fun _ e -> ue hvarmap e)
   352:     h;
   353:     iter (fun {pindex=i} -> ui i) ps
   354: 
   355:    | `BBDCL_reglex (props,vs,(ps,traint),le,ret,(_,_,h,_)) ->
   356:     let argtypes = map (fun {ptyp=t}->t) ps in
   357:     assert (length vs = length ts);
   358:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   359:     let hvarmap = hashtable_of_list vars in
   360:     Hashtbl.iter
   361:     (fun _ e -> ue hvarmap e)
   362:     h;
   363:     iter (fun {pindex=i} -> ui i) ps;
   364:     ui le; (* lexeme end .. *)
   365:     ui i
   366: 
   367:   | `BBDCL_function (props,vs,(ps,traint),ret,exes) ->
   368:     let argtypes = map (fun {ptyp=t}->t) ps in
   369:     assert (length vs = length ts);
   370:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   371:     let hvarmap = hashtable_of_list vars in
   372:     if instps || mem `Cfun props then
   373:       iter (fun {pindex=i; ptyp=t} ->
   374:         ui i;
   375:         rtr (varmap_subst hvarmap t)
   376:       )
   377:       ps
   378:     ;
   379:     process_function syms bbdfns hvarmap ref_insts1 i sr argtypes ret exes ts
   380: 
   381:   | `BBDCL_procedure (props,vs,(ps,traint), exes) ->
   382:     let argtypes = map (fun {ptyp=t}->t) ps in
   383:     assert (length vs = length ts);
   384:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   385:     let hvarmap = hashtable_of_list vars in
   386:     if instps || mem `Cfun props then
   387:       iter (fun {pindex=i; ptyp=t} ->
   388:         ui i;
   389:         rtr (varmap_subst hvarmap t)
   390:       )
   391:       ps
   392:     ;
   393:     process_function syms bbdfns hvarmap ref_insts1 i sr argtypes `BTYP_void exes ts
   394: 
   395:   | `BBDCL_class (props,vs) ->
   396:     assert (length vs = length ts);
   397:     (*
   398:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   399:     let hvarmap = hashtable_of_list vars in
   400:     *)
   401: 
   402:     rtnr (`BTYP_inst (i,ts));
   403: 
   404:     (*
   405:     print_endline "Registering class object";
   406:     *)
   407:     ui i
   408: 
   409:   | `BBDCL_union (vs,ps) ->
   410:     let argtypes = map (fun (_,_,t)->t) ps in
   411:     assert (length vs = length ts);
   412:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   413:     let hvarmap = hashtable_of_list vars in
   414:     let tss = map (varmap_subst hvarmap) argtypes in
   415:     iter rtr tss;
   416:     rtnr (`BTYP_inst (i,ts))
   417: 
   418: 
   419:   | `BBDCL_struct (vs,ps)
   420:   | `BBDCL_cstruct (vs,ps)
   421:     ->
   422:     let argtypes = map snd ps in
   423:     assert (length vs = length ts);
   424:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   425:     let hvarmap = hashtable_of_list vars in
   426:     let tss = map (varmap_subst hvarmap) argtypes in
   427:     iter rtr tss;
   428:     rtnr (`BTYP_inst (i,ts))
   429: 
   430:   | `BBDCL_newtype (vs,t) ->
   431:     rtnr t;
   432:     rtnr (`BTYP_inst (i,ts))
   433: 
   434:   | `BBDCL_cclass (vs,ps)
   435:     ->
   436:     (*
   437:     let argtypes = map (function
   438:       | `BMemberVal (_,t)
   439:       | `BMemberVar (_,t)
   440:       | `BMemberFun (_,_,t)
   441:       | `BMemberProc (_,_,t)
   442:       | `BMemberCtor (_,t)  -> t
   443:     ) ps in
   444:     *)
   445:     assert (length vs = length ts);
   446:     (*
   447:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   448:     let hvarmap = hashtable_of_list vars in
   449:     let tss = map (varmap_subst hvarmap) argtypes in
   450:     iter rtr tss;
   451:     *)
   452:     rtnr (`BTYP_inst (i,ts))
   453: 
   454:   | `BBDCL_val (vs,t)
   455:   | `BBDCL_var (vs,t)
   456:   | `BBDCL_ref (vs,t)
   457:   | `BBDCL_tmp (vs,t)
   458:     ->
   459:     (*
   460:     print_endline "Registering variable";
   461:     *)
   462:     if length vs <> length ts
   463:     then syserr sr
   464:     (
   465:       "ts/vs mismatch instantiating variable " ^ id ^ "<"^si i^">, inst "^si inst^": vs = [" ^
   466:       catmap ";" (fun (s,i)-> s ^"<"^si i^">") vs ^ "], " ^
   467:       "ts = [" ^
   468:       catmap ";" (fun t->sbt syms.dfns t) ts ^ "]"
   469:     );
   470:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   471:     let hvarmap = hashtable_of_list vars in
   472:     let t = varmap_subst hvarmap t in
   473:     rtr t
   474: 
   475:   | `BBDCL_const (vs,t,_,reqs) ->
   476:     (*
   477:     print_endline "Register const";
   478:     *)
   479:     assert (length vs = length ts);
   480:     (*
   481:     if length vs <> length ts
   482:     then syserr sr
   483:     (
   484:       "ts/vs mismatch index "^si i^", inst "^si inst^": vs = [" ^
   485:       catmap ";" (fun (s,i)-> s ^"<"^si i^">") vs ^ "], " ^
   486:       "ts = [" ^
   487:       catmap ";" (fun t->sbt syms.dfns t) ts ^ "]"
   488:     );
   489:     *)
   490:     assert (length vs = length ts);
   491:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   492:     let hvarmap = hashtable_of_list vars in
   493:     let t = varmap_subst hvarmap t in
   494:     rtr t;
   495:     let vs t = varmap_subst hvarmap t in
   496:     do_reqs vs reqs
   497: 
   498:   (* shortcut -- header and body can only require other header and body *)
   499:   | `BBDCL_insert (vs,s,ikind,reqs)
   500:     ->
   501:     (*
   502:     print_endline ("Handling requirements of header/body " ^ s);
   503:     *)
   504:     assert (length vs = length ts);
   505:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   506:     let hvarmap = hashtable_of_list vars in
   507:     let vs t = varmap_subst hvarmap t in
   508:     do_reqs vs reqs
   509: 
   510: 
   511:   | `BBDCL_fun (props,vs,argtypes,ret,_,reqs,_) ->
   512:     (*
   513:     print_endline ("Handling requirements of fun " ^ id);
   514:     *)
   515:     if length vs <> length ts then
   516:       print_endline ("For fun " ^ id ^ " vs=" ^ print_bvs vs ^
   517:       ", but ts=" ^ catmap "," (sbt syms.dfns) ts)
   518:     ;
   519:     assert (length vs = length ts);
   520:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   521:     let hvarmap = hashtable_of_list vars in
   522:     let vs t = varmap_subst hvarmap t in
   523:     do_reqs vs reqs;
   524:     process_function syms bbdfns hvarmap ref_insts1 i sr argtypes ret [] ts
   525: 
   526:   | `BBDCL_callback (props,vs,argtypes_cf,argtypes_c,k,ret,reqs,_) ->
   527:     (*
   528:     print_endline ("Handling requirements of callback " ^ id);
   529:     *)
   530:     assert (length vs = length ts);
   531:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   532:     let hvarmap = hashtable_of_list vars in
   533:     let vs t = varmap_subst hvarmap t in
   534:     do_reqs vs reqs;
   535: 
   536:     let ret = varmap_subst hvarmap ret in
   537:     rtr ret;
   538: 
   539:     (* prolly not necessary .. *)
   540:     let tss = map (varmap_subst hvarmap) argtypes_cf in
   541:     iter rtr tss;
   542: 
   543:     (* just to register 'address' .. lol *)
   544:     let tss = map (varmap_subst hvarmap) argtypes_c in
   545:     iter rtr tss
   546: 
   547:   | `BBDCL_proc (props,vs,argtypes,_,reqs) ->
   548:     (*
   549:     print_endline ("[flx_inst] Handling requirements of proc " ^ id);
   550:     print_endline ("vs = " ^ catmap "," (fun (s,i) -> s ^ "<" ^ si i ^ ">") vs);
   551:     print_endline ("ts = " ^ catmap "," (sbt syms.dfns) ts);
   552:     *)
   553:     assert (length vs = length ts);
   554:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   555:     let hvarmap = hashtable_of_list vars in
   556:     let vs t = varmap_subst hvarmap t in
   557:     do_reqs vs reqs;
   558:     process_function syms bbdfns hvarmap ref_insts1 i sr argtypes `BTYP_void [] ts
   559: 
   560:   | `BBDCL_abs (vs,_,_,reqs)
   561:     ->
   562:     assert (length vs = length ts);
   563:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   564:     let hvarmap = hashtable_of_list vars in
   565:     let vs t = varmap_subst hvarmap t in
   566:     do_reqs vs reqs
   567: 
   568:   | `BBDCL_nonconst_ctor (vs,uidx,udt, ctor_idx, ctor_argt, evs, etraint) ->
   569:     assert (length vs = length ts);
   570:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   571:     let hvarmap = hashtable_of_list vars in
   572: 
   573:     (* we don't register the union .. it's a uctor anyhow *)
   574:     let ctor_argt = varmap_subst hvarmap ctor_argt in
   575:     rtr ctor_argt
   576: 
   577:    | `BBDCL_typeclass _ -> ()
   578:    | `BBDCL_instance (props,vs,con,tc,ts) -> ()
   579: 
   580: (*
   581:   This routine creates the instance tables.
   582:   There are 2 tables: instance types and function types (including procs)
   583: 
   584:   The type registry holds the types used.
   585:   The instance registry holds a pair:
   586:   (index, types)
   587:   where index is the function or procedure index,
   588:   and types is a list of types to instantiated it.
   589: 
   590:   The algorithm starts with a list of roots, being
   591:   the top level init routine and any exported functions.
   592:   These must be non-generic.
   593: 
   594:   It puts these into a set of functions to be examined.
   595:   Then it begins examining the set by chosing one function
   596:   and moving it to the 'examined' set.
   597: 
   598:   It registers the function type, and then
   599:   examines the body.
   600: 
   601:   In the process of examining the body,
   602:   every function or procedure call is examined.
   603: 
   604:   The function being called is added to the
   605:   to be examined list with the calling type arguments.
   606:   Note that these type arguments may include type variables
   607:   which have to be replaced by their instances which are
   608:   passed to the examination routine.
   609: 
   610:   The process continues until there are no unexamined
   611:   functions left. The effect is to instantiate every used
   612:   type and function.
   613: *)
   614: 
   615: let instantiate syms bbdfns instps (root:bid_t) (bifaces:biface_t list) =
   616:   Hashtbl.clear syms.instances;
   617:   Hashtbl.clear syms.registry;
   618: 
   619:   (* empty instantiation registry *)
   620:   let insts1 = ref FunInstSet.empty in
   621: 
   622:   begin
   623:     (* append routine to add an instance *)
   624:     let add_cand i ts = insts1 := FunInstSet.add (i,ts) !insts1 in
   625: 
   626:     (* add the root *)
   627:     add_cand root [];
   628: 
   629:     (* add exported functions, and register exported types *)
   630:     let ui i ts = add_inst syms bbdfns insts1 (i,ts) in
   631:     iter
   632:     (function
   633:       | `BIFACE_export_fun (_,x,_) ->
   634:         let _,_,sr,entry = Hashtbl.find bbdfns x in
   635:         begin match entry with
   636:         | `BBDCL_procedure (props,_,(ps,_),_)
   637:         | `BBDCL_function (props,_,(ps,_),_,_) ->
   638:         begin match ps with
   639:         | [] -> ()
   640:         | [{ptyp=t}] -> register_type_r ui syms bbdfns [] sr t
   641:         | _ ->
   642:           let t =
   643:             `BTYP_tuple
   644:             (
   645:               map
   646:               (fun {ptyp=t} -> t)
   647:               ps
   648:             )
   649:           in
   650:           register_type_r ui syms bbdfns [] sr t;
   651:           register_type_nr syms t;
   652:         end
   653:         | _ -> assert false
   654:         end
   655:         ;
   656:         add_cand x []
   657: 
   658:       | `BIFACE_export_type (sr,t,_) ->
   659:         register_type_r ui syms bbdfns [] sr t
   660:     )
   661:     bifaces
   662:   end
   663:   ;
   664: 
   665:   (* NEW: if a symbol is monomorphic use its index as its instance! *)
   666:   (* this is a TRICK .. saves remapping the root/exports, since they
   667:      have to be monomorphic anyhow
   668:   *)
   669:   let add_instance i ts =
   670:     let n =
   671:       match ts with
   672:       | [] -> i
   673:       | _ -> let n = !(syms.counter) in incr (syms.counter); n
   674:     in
   675:     Hashtbl.add syms.instances (i,ts) n;
   676:     n
   677:   in
   678: 
   679:   while not (FunInstSet.is_empty !insts1) do
   680:     let (index,vars) as x = FunInstSet.choose !insts1 in
   681:     insts1 := FunInstSet.remove x !insts1;
   682:     let inst = add_instance index vars in
   683:     process_inst syms bbdfns instps insts1 index vars inst
   684:   done
   685: 
   686: 
   687: (* BUG!!!!! Abstract type requirements aren't handled!! *)
   688: 
End ocaml section to src/flx_inst.ml[1]