5.54. Monomorphisation

This requires the instantiator to have been run.
Start ocaml section to src/flx_mono.mli[1 /1 ]
     1: # 5 "./lpsrc/flx_mono.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_call
     7: 
     8: val monomorphise:
     9:   sym_state_t ->
    10:   fully_bound_symbol_table_t ->
    11:   unit
    12: 
    13: 
End ocaml section to src/flx_mono.mli[1]
Start ocaml section to src/flx_mono.ml[1 /1 ]
     1: # 19 "./lpsrc/flx_mono.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_reparent
    20: open Flx_spexes
    21: open Flx_beta
    22: open Flx_prop
    23: 
    24: let cal_parent syms bbdfns i' ts' =
    25:   let id,parent,sr,_ = Hashtbl.find bbdfns i' in
    26:   match parent with
    27:   | None -> None
    28:   | Some i ->
    29:     let vsc = get_vs bbdfns i' in
    30:     assert (length vsc = length ts');
    31:     if not (Hashtbl.mem bbdfns i) then None else
    32:     let vsp = get_vs bbdfns i in
    33:     let n = length vsp in
    34:     assert (n <= length vsc);
    35:     let ts = list_prefix ts' n in
    36:     let k =
    37:        try (Hashtbl.find syms.instances (i,ts))
    38:        with Not_found ->
    39:         print_endline ("Wah? Not found parent of " ^
    40:           id ^ "<" ^ si i' ^ ">" ^
    41:           "[" ^ catmap "," (sbt syms.dfns) ts ^ "]\n" ^
    42:           "Which should be " ^ si i ^
    43:           "[" ^ catmap "," (sbt syms.dfns) ts ^ "]"
    44:         )
    45:         ;
    46:         assert false
    47:     in
    48:       if ts = [] then assert (i=k);
    49:       (*
    50:       print_endline ("Parent of " ^ si i' ^ " was " ^ si i ^ " is now " ^ si k);
    51:       *)
    52:       Some k
    53: 
    54: let fixup_type' syms bbdfns fi t =
    55:   match t with
    56:   | `BTYP_inst (i,ts) ->
    57:     let i,ts = fi i ts in
    58:     `BTYP_inst (i,ts)
    59:   | x -> x
    60: 
    61: let rec fixup_type syms bbdfns fi t =
    62:   let ft t = fixup_type syms bbdfns fi t in
    63:   let ft' t = fixup_type' syms bbdfns fi t in
    64:   let t = map_btype ft t in
    65:   ft' t
    66: 
    67: let fixup_expr' syms bbdfns fi mt (e:bexpr_t) =
    68:   (*
    69:   print_endline ("FIXUP EXPR(up) " ^ sbe syms.dfns (e,`BTYP_void));
    70:   *)
    71:   let x = match e with
    72:   | `BEXPR_apply_prim (i',ts,a) ->
    73:     let i,ts = fi i' ts in
    74:     if i = i' then
    75:       `BEXPR_apply_prim (i,ts,a)
    76:     else
    77:       `BEXPR_apply_direct (i,ts,a)
    78: 
    79:   | `BEXPR_apply_direct (i,ts,a) ->
    80:     let i,ts = fi i ts in
    81:     `BEXPR_apply_direct (i,ts,a)
    82: 
    83:   | `BEXPR_apply_struct (i,ts,a) ->
    84:     let i,ts = fi i ts in
    85:     `BEXPR_apply_struct (i,ts,a)
    86: 
    87:   | `BEXPR_apply_stack (i,ts,a) ->
    88:     let i,ts = fi i ts in
    89:     `BEXPR_apply_stack (i,ts,a)
    90: 
    91:   | `BEXPR_apply_method_direct (obj,i,ts,a) ->
    92:     let i,ts = fi i ts in
    93:     `BEXPR_apply_method_direct (obj,i,ts,a)
    94: 
    95:   | `BEXPR_apply_method_stack (obj,i,ts,a) ->
    96:     let i,ts = fi i ts in
    97:     `BEXPR_apply_method_stack (obj,i,ts,a)
    98: 
    99:   | `BEXPR_ref (i,ts)  ->
   100:     let i,ts = fi i ts in
   101:     `BEXPR_ref (i,ts)
   102: 
   103:   | `BEXPR_name (i',ts') ->
   104:     let i,ts = fi i' ts' in
   105:     (*
   106:     print_endline (
   107:       "Ref to Variable " ^ si i' ^ "[" ^ catmap "," (sbt syms.dfns) ts' ^"]" ^
   108:       " mapped to " ^ si i ^ "[" ^ catmap "," (sbt syms.dfns) ts ^"]"
   109:     );
   110:     *)
   111:     `BEXPR_name (i,ts)
   112: 
   113:   | `BEXPR_closure (i,ts) ->
   114:     let i,ts = fi i ts in
   115:     `BEXPR_closure (i,ts)
   116: 
   117:   | `BEXPR_method_closure (e,i,ts) ->
   118:     let i,ts = fi i ts in
   119:     `BEXPR_method_closure (e,i,ts)
   120:   | x -> x
   121:   in
   122:   (*
   123:   print_endline ("FIXed UP EXPR " ^ sbe syms.dfns (x,`BTYP_void));
   124:   *)
   125:   x
   126: 
   127: let id x = x
   128: 
   129: let rec fixup_expr syms bbdfns fi mt e =
   130:   (*
   131:   print_endline ("FIXUP EXPR(down) " ^ sbe syms.dfns e);
   132:   *)
   133:   let fe e = fixup_expr syms bbdfns fi mt e in
   134:   let fe' (e,t) = fixup_expr' syms bbdfns fi mt e,t in
   135:   (* this is deviant case: implied ts is vs of parent!,
   136:      it has to be done FIRST before the type is remapped
   137:   *)
   138:   let e = match e with
   139:   | `BEXPR_get_named (i,(e,t)),t' ->
   140:     (*
   141:     print_endline ("REMAPPING component variable " ^ si i);
   142:     *)
   143:     let vs = get_vs bbdfns i in
   144:     (*
   145:     print_endline ("vs = " ^ catmap "," (fun (s,i) -> s ^ "<" ^ si i ^ ">") vs);
   146:     *)
   147:     begin match t with
   148:     | `BTYP_inst (j,ts)
   149:     | `BTYP_lvalue (`BTYP_inst (j,ts)) ->
   150:       (*
   151:       print_endline ("type=" ^ si j ^ ", ts = " ^ catmap "," (sbt syms.dfns) ts);
   152:       *)
   153:       let i,ts = fi i ts in
   154:       (*
   155:       print_endline ("Remapped to " ^ si i);
   156:       *)
   157:       `BEXPR_get_named (i,(e,t)),t'
   158:     | _ -> assert false
   159:     end
   160:   | x -> x
   161:   in
   162:   let e = map_tbexpr id fe mt e in
   163:   fe' e
   164: 
   165: let fixup_exe syms bbdfns fi mt exe =
   166:   (*
   167:   print_endline ("FIXUP EXE[In] =" ^ string_of_bexe syms.dfns 0 exe);
   168:   *)
   169:   let fe e = fixup_expr syms bbdfns fi mt e in
   170:   let result =
   171:   match map_bexe id fe mt id id exe with
   172:   | `BEXE_call_direct (sr, i,ts,a) -> assert false
   173:     (*
   174:     let i,ts = fi i ts in
   175:     `BEXE_call_direct (sr,i,ts,a)
   176:     *)
   177: 
   178:   | `BEXE_jump_direct (sr, i,ts,a) -> assert false
   179:     (*
   180:     let i,ts = fi i ts in
   181:     `BEXE_jump_direct (sr,i,ts,a)
   182:     *)
   183: 
   184:   | `BEXE_call_prim (sr, i',ts,a) -> assert false
   185:     (*
   186:     let i,ts = fi i' ts in
   187:     if i = i' then
   188:       `BEXE_call_prim (sr,i,ts,a)
   189:     else
   190:       `BEXE_call_direct (sr,i,ts,a)
   191:     *)
   192: 
   193:   | `BEXE_call_stack (sr, i,ts,a) -> assert false
   194:     (*
   195:     let i,ts = fi i ts in
   196:     `BEXE_call_stack (sr,i,ts,a)
   197:     *)
   198: 
   199:   | `BEXE_call_method_direct (sr,o,i,ts,a) ->
   200:     let i,ts = fi i ts in
   201:     `BEXE_call_method_direct (sr,o, i,ts,a)
   202: 
   203:   | `BEXE_call_method_stack (sr, o, i,ts,a) ->
   204:     let i,ts = fi i ts in
   205:     `BEXE_call_method_stack (sr,o, i,ts,a)
   206: 
   207:   (* this is deviant case: implied ts is vs of parent! *)
   208:   | `BEXE_init (sr,i,e) ->
   209:     (*
   210:     print_endline ("[init] Deviant case variable " ^ si i);
   211:     *)
   212:     let vs = get_vs bbdfns i in
   213:     let ts = map (fun (s,j) -> mt (`BTYP_var (j,`BTYP_type 0))) vs in
   214:     let i,ts = fi i ts in
   215:     (*
   216:     print_endline ("[init] Remapped deviant variable to " ^ si i);
   217:     *)
   218:     `BEXE_init (sr,i,e)
   219: 
   220:   | `BEXE_svc (sr,i) ->
   221:     (*
   222:     print_endline ("[svc] Deviant case variable " ^ si i);
   223:     *)
   224:     let vs = get_vs bbdfns i in
   225:     let ts = map (fun (s,j) -> mt (`BTYP_var (j,`BTYP_type 0))) vs in
   226:     let i,ts = fi i ts in
   227:     (*
   228:     print_endline ("[svc] Remapped deviant variable to " ^ si i);
   229:     *)
   230:     `BEXE_svc (sr,i)
   231: 
   232: 
   233:   | `BEXE_apply_ctor (sr,dst,cls,clsts,ctor,ctorarg) ->
   234:     (*
   235:     print_endline ("ORIGINAL: apply ctor " ^ si ctor ^ " class " ^ si cls ^ " ts = " ^ catmap "," (sbt syms.dfns) clsts);
   236:     *)
   237:     let cls,clsts = fi cls clsts and ctor,_ = fi ctor clsts in
   238:     (*
   239:     print_endline ("REMAPPED: apply ctor " ^ si ctor ^ " class " ^ si cls ^ " ts = " ^ catmap "," (sbt syms.dfns) clsts);
   240:     *)
   241:     let dstvs = get_vs bbdfns dst in
   242:     let dstts = map (fun (s,j) -> mt (`BTYP_var (j,`BTYP_type 0))) dstvs in
   243:     let dst,dstts = fi dst dstts in
   244:     `BEXE_apply_ctor (sr,dst,cls,clsts,ctor,ctorarg)
   245: 
   246:   | `BEXE_apply_ctor_stack (sr,dst,cls,clsts,ctor,ctorarg) ->
   247:     (*
   248:     print_endline ("ORIGINAL: apply ctor " ^ si ctor ^ " class " ^ si cls ^ " ts = " ^ catmap "," (sbt syms.dfns) clsts);
   249:     *)
   250:     let cls,clsts = fi cls clsts and ctor,_ = fi ctor clsts in
   251:     (*
   252:     print_endline ("REMAPPED: apply ctor " ^ si ctor ^ " class " ^ si cls ^ " ts = " ^ catmap "," (sbt syms.dfns) clsts);
   253:     *)
   254:     let dstvs = get_vs bbdfns dst in
   255:     let dstts = map (fun (s,j) -> mt (`BTYP_var (j,`BTYP_type 0))) dstvs in
   256:     let dst,dstts = fi dst dstts in
   257:     `BEXE_apply_ctor_stack (sr,dst,cls,clsts,ctor,ctorarg)
   258: 
   259: 
   260:   | x -> x
   261:   in
   262:   (*
   263:   print_endline ("FIXUP EXE[Out]=" ^ string_of_bexe syms.dfns 0 result);
   264:   *)
   265:   result
   266: 
   267: 
   268: let fixup_exes syms bbdfns fi mt exes =
   269:   map (fixup_exe syms bbdfns fi mt) exes
   270: 
   271: let mono syms (bbdfns: fully_bound_symbol_table_t) fi i ts n =
   272:   let id,parent,sr,entry = Hashtbl.find bbdfns i in
   273:   match entry with
   274: 
   275:   | `BBDCL_function (props,vs,(ps,traint),ret,exes) ->
   276:     let props = filter (fun p -> p <> `Virtual) props in
   277:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   278:     let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
   279:     let ret = mt ret in
   280:     (*
   281:     let fi i ts = fi i (map mt ts) in
   282:     *)
   283:     let ps = map (fun {pkind=pk; pid=s;pindex=i; ptyp=t} ->
   284:       {pkind=pk;pid=s;pindex=fst (fi i ts);ptyp=mt t}) ps
   285:     in
   286:     let traint = match traint with | None -> None | Some x -> Some (fixup_expr syms bbdfns fi mt x) in
   287:     let exes = fixup_exes syms bbdfns fi mt exes in
   288:     let entry = `BBDCL_function (props,[],(ps,traint),ret,exes) in
   289:     let parent = cal_parent syms bbdfns i ts in
   290:     Hashtbl.replace bbdfns n (id,parent,sr,entry)
   291: 
   292:   | `BBDCL_procedure (props,vs,(ps,traint), exes) ->
   293:     let props = filter (fun p -> p <> `Virtual) props in
   294:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   295:     let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
   296:     let ps = map (fun {pkind=pk; pid=s;pindex=i; ptyp=t} ->
   297:       let k = fst (fi i ts) in
   298:       let u = mt t in
   299:       (*
   300:       print_endline ("Remap parameter " ^ s ^"<"^ si i ^ "> (type " ^
   301:         sbt syms.dfns t ^
   302:       ")to " ^ si k ^ " type " ^ sbt syms.dfns u);
   303:       *)
   304:       {pkind=pk;pid=s;pindex=k;ptyp=u}) ps
   305:     in
   306:     let traint = match traint with | None -> None | Some x -> Some (fixup_expr syms bbdfns fi mt x) in
   307:     (*
   308:     let fi i ts = fi i (map mt ts) in
   309:     *)
   310:     let exes = fixup_exes syms bbdfns fi mt exes in
   311:     let entry = `BBDCL_procedure (props,[],(ps,traint), exes) in
   312:     let parent = cal_parent syms bbdfns i ts in
   313:     Hashtbl.replace bbdfns n (id,parent,sr,entry)
   314: 
   315:   | `BBDCL_val (vs,t) ->
   316:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   317:     let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
   318:     let t = mt t in
   319:     let entry = `BBDCL_val ([],t) in
   320:     let parent = cal_parent syms bbdfns i ts in
   321:     Hashtbl.replace bbdfns n (id,parent,sr,entry)
   322: 
   323:   | `BBDCL_var (vs,t) ->
   324:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   325:     let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
   326:     let t = mt t in
   327:     let entry = `BBDCL_var ([],t) in
   328:     let parent = cal_parent syms bbdfns i ts in
   329:     Hashtbl.replace bbdfns n (id,parent,sr,entry)
   330: 
   331:   | `BBDCL_ref (vs,t) ->
   332:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   333:     let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
   334:     let t = mt t in
   335:     let entry = `BBDCL_ref ([],t) in
   336:     let parent = cal_parent syms bbdfns i ts in
   337:     Hashtbl.replace bbdfns n (id,parent,sr,entry)
   338: 
   339:   | `BBDCL_tmp (vs,t) ->
   340:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   341:     let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
   342:     let t = mt t in
   343:     let entry = `BBDCL_tmp ([],t) in
   344:     let parent = cal_parent syms bbdfns i ts in
   345:     Hashtbl.replace bbdfns n (id,parent,sr,entry)
   346: 
   347:   | `BBDCL_class (props,vs) ->
   348:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   349:     let entry = `BBDCL_class (props,[]) in
   350:     let parent = cal_parent syms bbdfns i ts in
   351:     Hashtbl.replace bbdfns n (id,parent,sr,entry)
   352: 
   353:   (* we have tp replace types in interfaces like Vector[int]
   354:     with monomorphic versions if any .. even if we don't
   355:     monomorphise the entry itself.
   356: 
   357:     This is weak .. it's redone for each instance, relies
   358:     on mt being idempotent..
   359:   *)
   360:   | `BBDCL_fun (props,vs,argtypes,ret,ct,reqs,prec) ->
   361:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   362:     let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
   363:     let argtypes = map mt argtypes in
   364:     let ret = mt ret in
   365:     let entry = `BBDCL_fun (props,vs,argtypes,ret,ct,reqs,prec) in
   366:     Hashtbl.replace bbdfns i (id,parent, sr, entry)
   367: 
   368: 
   369:   | `BBDCL_proc (props,vs,argtypes,ct,reqs) ->
   370:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   371:     let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
   372:     let argtypes = map mt argtypes in
   373:     let entry = `BBDCL_proc (props,vs,argtypes,ct,reqs) in
   374:     Hashtbl.replace bbdfns i (id,parent, sr, entry)
   375: 
   376:   | `BBDCL_const (vs,t,`Str "#this",reqs) ->
   377:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   378:     let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
   379:     let t = mt t in
   380:     let entry = `BBDCL_const([],t,`Str "#this",reqs) in
   381:     let parent = cal_parent syms bbdfns i ts in
   382:     Hashtbl.replace bbdfns n (id,parent,sr,entry)
   383: 
   384:   | `BBDCL_regmatch (props,vs,(ps,traint),ret,(alpha,states,h,mx))  ->
   385:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   386:     let mt t = list_subst vars t in
   387:     let traint = match traint with | None -> None | Some x -> Some (fixup_expr syms bbdfns fi mt x) in
   388:     let ps = map (fun {pkind=pk; pid=s;pindex=i; ptyp=t} ->
   389:       {pkind=pk;pid=s;pindex=fst (fi i ts);ptyp=mt t}) ps
   390:     in
   391:     let ret = mt ret in
   392:     let h2 = Hashtbl.create 97 in
   393:     Hashtbl.iter (fun j e ->
   394:       let e = fixup_expr syms bbdfns fi mt e in
   395:       Hashtbl.add h2 j e
   396:     )
   397:     h
   398:     ;
   399:     let entry = `BBDCL_regmatch (props,[],(ps,traint),ret,(alpha,states,h2,mx)) in
   400:     let parent = cal_parent syms bbdfns i ts in
   401:     Hashtbl.replace bbdfns n (id,parent,sr,entry)
   402: 
   403: 
   404:   (*
   405:   | `BBDCL_glr (props,vs,ret, (p,exes)) ->
   406:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   407:     let mt t = list_subst vars t in
   408:     let ret = mt ret in
   409:     let exes = fixup_exes syms bbdfns mt exes in
   410:     `BBDCL_glr (props,[],ret,(p,exes))
   411: 
   412:   | `BBDCL_reglex (props,vs,(ps,traint),le,ret,(alpha,states,h,mx)) ->
   413:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   414:     let mt t = list_subst vars t in
   415:     let traint = match traint with | None -> None | Some x -> Some (fixup_expr syms bbdfns mt x) in
   416:     let ret = mt ret in
   417:     `BBDCL_reglex (props,[],(ps,traint),le,ret,(alpha,states,h,mx))
   418: 
   419:   | `BBDCL_union (vs,ps) ->
   420:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   421:     let mt t = list_subst vars t in
   422:     let ps = map (fun (i,j,t) -> i,j,mt t) ps in
   423:     `BBDCL_union ([],ps)
   424: 
   425:   | `BBDCL_struct (vs,ps) ->
   426:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   427:     let mt t = list_subst vars t in
   428:     let ps = map (fun (i,t) -> i,mt t) ps in
   429:     `BBDCL_struct ([],ps)
   430: 
   431:   | `BBDCL_cstruct (vs,ps) ->
   432:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   433:     let mt t = list_subst vars t in
   434:     let ps = map (fun (i,t) -> i,mt t) ps in
   435:     `BBDCL_cstruct ([],ps)
   436: 
   437:   | `BBDCL_newtype (vs,t) ->
   438:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   439:     let mt t = list_subst vars t in
   440:     let t = mt t in
   441:     `BBDCL_newtype ([],t)
   442: 
   443:   | `BBDCL_cclass (vs,ps) ->
   444:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   445:     `BBDCL_cclass ([],ps)
   446: 
   447:   | `BBDCL_const (vs,t,ct,reqs) ->
   448:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   449:     `BBDCL_const ([],t,ct,reqs)
   450: 
   451:   | `BBDCL_insert (vs,s,ikind,reqs) ->
   452:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   453:     `BBDCL_insert ([],s,ikind,reqs)
   454: 
   455: 
   456:   | `BBDCL_callback (props,vs,argtypes_cf,argtypes_c,k,ret,reqs,prec) ->
   457:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   458:     `BBDCL_callback (props,[],argtypes_cf,argtypes_c,k,ret,reqs,prec)
   459: 
   460:   | `BBDCL_abs (vs,tqual,ct,reqs) ->
   461:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   462:     `BBDCL_abs ([],tqual,ct,reqs)
   463: 
   464:   | `BBDCL_nonconst_ctor (vs,uidx,udt, ctor_idx, ctor_argt, evs, etraint) ->
   465:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   466:     `BBDCL_nonconst_ctor ([],uidx,udt, ctor_idx, ctor_argt, evs, etraint)
   467: 
   468:   | `BBDCL_typeclass (props,vs) ->  entry
   469:     (*
   470:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   471:     `BBDCL_typeclass (props,[])
   472:     *)
   473: 
   474:   | `BBDCL_instance (props,vs,con,tc,ts) ->  entry
   475:     (*
   476:     let vars = map2 (fun (s,i) t -> i,t) vs ts in
   477:     `BBDCL_instance (props,[],con,tc,ts) ->
   478:     *)
   479:   *)
   480: 
   481:   | _ -> ()
   482: 
   483: let chk_mono syms (bbdfns: fully_bound_symbol_table_t) i =
   484:   let id,parent,sr,entry = Hashtbl.find bbdfns i in
   485:   match entry with
   486:   | `BBDCL_function (props,vs,(ps,traint),ret,exes) ->  true
   487:   | `BBDCL_procedure (props,vs,(ps,traint), exes) -> true
   488:   | `BBDCL_val (vs,t) -> true
   489:   | `BBDCL_var (vs,t) -> true
   490:   | `BBDCL_ref (vs,t) -> true
   491:   | `BBDCL_tmp (vs,t) -> true
   492:   | `BBDCL_class (props,vs) -> true
   493:   | `BBDCL_const (_,_,`Str "#this",_) -> true
   494:   | `BBDCL_regmatch (props,vs,(ps,traint),ret,(alpha,states,h,mx))  -> true
   495: 
   496: 
   497:   | `BBDCL_glr (props,vs,ret, (p,exes)) -> false
   498:   | `BBDCL_reglex (props,vs,(ps,traint),le,ret,(alpha,states,h,mx)) -> false
   499:   | `BBDCL_union (vs,ps) -> false
   500:   | `BBDCL_struct (vs,ps) -> false
   501:   | `BBDCL_cstruct (vs,ps) -> false
   502:   | `BBDCL_newtype (vs,t) -> false
   503:   | `BBDCL_cclass (vs,ps) -> false
   504:   | `BBDCL_const (vs,t,ct,reqs) -> false
   505:   | `BBDCL_insert (vs,s,ikind,reqs) ->  false
   506:   | `BBDCL_fun (props,vs,argtypes,ret,ct,reqs,prec) -> false
   507:   | `BBDCL_callback (props,vs,argtypes_cf,argtypes_c,k,ret,reqs,prec) -> false
   508:   | `BBDCL_proc (props,vs,argtypes,ct,reqs) -> false
   509:   | `BBDCL_abs (vs,tqual,ct,reqs) ->  false
   510:   | `BBDCL_nonconst_ctor (vs,uidx,udt, ctor_idx, ctor_argt, evs, etraint) -> false
   511:   | `BBDCL_typeclass (props,vs) ->  false
   512:   | `BBDCL_instance (props,vs,con,tc,ts) ->  false
   513: 
   514: (* monomorphic instances are already equal to their indices ..
   515:   replace some polymorphic instances with monomorphic ones
   516: *)
   517: let monomorphise syms bbdfns =
   518:   let polyinst = Hashtbl.create 97 in
   519:   Hashtbl.iter
   520:   (fun (i,ts) n ->
   521:    if ts = [] then assert (i = n )
   522:    else
   523:      if chk_mono syms bbdfns i
   524:      then begin
   525:        (*
   526:        print_endline ("polyinst " ^ si n ^ " = " ^
   527:        si i ^ "["^catmap "," (sbt syms.dfns) ts^"]");
   528:        *)
   529:        Hashtbl.add polyinst (i,ts) n
   530:      end else begin
   531:        (*
   532:        print_endline ("*** NO polyinst " ^ si n ^ " = " ^
   533:        si i ^ "["^catmap "," (sbt syms.dfns) ts^"]");
   534:        *)
   535:      end
   536: 
   537:   )
   538:   syms.instances
   539:   ;
   540: 
   541:   let fi polyinst i ts =
   542:     let ts = map reduce_type ts in
   543:     let i,ts = Flx_typeclass.maybe_fixup_typeclass_instance syms bbdfns i ts in
   544:     try Hashtbl.find polyinst (i,ts),[]
   545:     with Not_found ->  i,ts
   546:   in
   547: 
   548:   (* make a new table where the ts are ALSO converted to monomorphised
   549:      class clones .. we still need the originals for non-type uses
   550:      of the class (eg constructor)
   551:   *)
   552:   let polyinst2 = Hashtbl.create 97 in
   553:   Hashtbl.iter
   554:   (fun (i,ts) n ->
   555:     Hashtbl.replace polyinst2 (i,ts) n;
   556:     let ts = map (fixup_type syms bbdfns (fi polyinst)) ts in
   557:     Hashtbl.replace polyinst2 (i,ts) n;
   558:   )
   559:   polyinst
   560:   ;
   561:   let fi i ts = fi polyinst2 i ts in
   562: 
   563:   Hashtbl.iter
   564:   (fun (i,ts) n ->
   565:     if syms.compiler_options.print_flag then begin
   566:       if (n <> i) then print_endline (
   567:          "[monomorphise] Adding instance " ^ si n ^ " = " ^
   568:          si i ^ "["^catmap "," (sbt syms.dfns) ts^"]"
   569:       ) else print_endline (
   570:          "[monomorphise] Process instance " ^ si n ^ " = " ^
   571:          si i ^ "["^catmap "," (sbt syms.dfns) ts^"]"
   572:       );
   573:     end;
   574: 
   575: 
   576:     mono syms bbdfns fi i ts n;
   577:   )
   578:   syms.instances
   579:   ;
   580: 
   581:   Hashtbl.iter (fun (i,ts) n ->
   582:     Hashtbl.remove syms.instances (i,ts);
   583:     Hashtbl.add syms.instances (n,[]) n;
   584:   )
   585:   polyinst
   586:   ;
   587: 
End ocaml section to src/flx_mono.ml[1]