5.39. Bind executable statements

Start ocaml section to src/flx_bexe.mli[1 /1 ]
     1: # 4 "./lpsrc/flx_bexe.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes2
     5: 
     6: val bind_exes:
     7:   sym_state_t ->
     8:   env_t ->
     9:   range_srcref ->
    10:   (range_srcref * exe_t) list ->
    11:   btypecode_t ->
    12:   string ->
    13:   bid_t ->
    14:   bvs_t ->
    15:   btypecode_t * bexe_t list
    16: 
End ocaml section to src/flx_bexe.mli[1]
Start ocaml section to src/flx_bexe.ml[1 /1 ]
     1: # 21 "./lpsrc/flx_bexe.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_lookup
    10: open Flx_mbind
    11: open Flx_srcref
    12: open Flx_unify
    13: open Flx_exceptions
    14: open List
    15: 
    16: let rec check_if_parent syms child parent =
    17:   if child = parent then true
    18:   else
    19:       match Hashtbl.find syms.dfns child with
    20:       | {parent=Some parent} -> check_if_parent syms child parent
    21:       | {parent=None} -> false
    22: 
    23: let cal_call syms sr ((p,pt) as tbe1) ((_,argt) as tbe2) =
    24:   match unfold syms.dfns pt with
    25:   | `BTYP_lvalue (`BTYP_cfunction (t, `BTYP_void))
    26:   | `BTYP_cfunction (t, `BTYP_void)
    27:   | `BTYP_lvalue (`BTYP_function (t, `BTYP_void))
    28:   | `BTYP_function (t, `BTYP_void) ->
    29:     if type_match syms.dfns t argt
    30:     then
    31:       (
    32:         match p with
    33:         | `BEXPR_closure (i,ts) ->
    34:           begin match Hashtbl.find syms.dfns i with
    35:           | {symdef=`SYMDEF_fun _ }
    36:           | {symdef=`SYMDEF_callback _ }
    37:             ->
    38:             `BEXE_call_prim (sr,i,ts,tbe2)
    39: 
    40:           | {symdef=`SYMDEF_function _} ->
    41:             `BEXE_call_direct (sr,i,ts,tbe2)
    42: 
    43:           | _ -> assert false
    44:           end
    45:         | _ ->
    46:           `BEXE_call (sr,(p,lower pt), tbe2)
    47:       )
    48:     else
    49:       clierr sr
    50:       (
    51:         "[cal_call] Procedure " ^
    52:         sbe syms.dfns tbe1 ^
    53:         "\nof type " ^
    54:         sbt syms.dfns pt ^
    55:         "\napplied to argument " ^
    56:         sbe syms.dfns tbe2 ^
    57:         "\n of type " ^
    58:         sbt syms.dfns argt ^
    59:         "\nwhich doesn't agree with parameter type\n" ^
    60:         sbt syms.dfns t
    61:       )
    62: 
    63:   | _ ->
    64:     clierr sr ("[cal_call] call non procedure, "^
    65:     sbe syms.dfns (p,pt)
    66:     ^"\ntype=" ^ sbt syms.dfns pt)
    67: 
    68: let cal_loop syms sr ((p,pt) as tbe1) ((_,argt) as tbe2) this =
    69:   match unfold syms.dfns pt with
    70:   | `BTYP_function (t, `BTYP_void) ->
    71:     if t = argt
    72:     then
    73:       match p with
    74:       | `BEXPR_closure (i,ts) ->
    75:         if check_if_parent syms i this
    76:         then
    77:           `BEXE_call_direct (sr,i, ts, tbe2)
    78:         else
    79:           clierr sr
    80:           "[cal_loop] Loop target must be self or parent"
    81: 
    82:       | _ ->
    83:         clierr sr (
    84:           "[cal_loop] Expected procedure closure, got "^
    85:           string_of_bound_expression syms.dfns (p,pt)
    86:         )
    87:     else
    88:       clierr sr
    89:       (
    90:         "[cal_loop] Procedure " ^
    91:         sbe syms.dfns tbe1 ^
    92:         "\nof type " ^
    93:         sbt syms.dfns pt ^
    94:         "\napplied to argument " ^
    95:         sbe syms.dfns tbe2 ^
    96:         "\n of type " ^
    97:         sbt syms.dfns argt ^
    98:         "\nwhich doesn't agree with parameter type\n" ^
    99:         sbt syms.dfns t
   100:       )
   101: 
   102:   | _ ->
   103:     clierr sr ("[cal_loop] loop to non procedure, "^
   104:     string_of_bound_expression syms.dfns (p,pt)
   105:     ^"\ntype=" ^ string_of_btypecode syms.dfns pt)
   106: 
   107: exception Found of int
   108: 
   109: let print_vs vs =
   110:   catmap "," (fun (s,i) -> s ^ "->" ^ si i) vs
   111: 
   112: let bind_exes syms env sr exes ret_type id index parent_vs =
   113:   (*
   114:   print_endline ("bind_exes.. env depth="^ string_of_int (List.length env));
   115:   print_endline "Dumping Source Executables";
   116:   print_endline "--------------------------";
   117:   let soe e = Flx_print.string_of_expr e in
   118:   List.iter
   119:     (fun (_,x) -> print_endline (string_of_exe 1 x))
   120:     exes
   121:   ;
   122:   print_endline ""
   123:   ;
   124: 
   125:   print_endline "Binding Executables";
   126:   print_endline "-------------------";
   127:   *)
   128: 
   129:   (* a type variable in executable code just has to be of kind TYPE *)
   130:   let parent_ts = map (fun (s,i) -> `BTYP_var (i,`BTYP_type)) parent_vs in
   131:   let ret_type = ref ret_type in
   132:   let be e : tbexpr_t = bind_expression syms env e in
   133:   let lun sr n = lookup_name_in_env syms env sr n in
   134:   let luqn n = lookup_qn_in_env syms env n in
   135:   let bt sr t : btypecode_t = bind_type syms env sr t in
   136:   let return_count = ref 0 in
   137:   let reachable = ref true in
   138:   let proc_return_count = ref 0 in
   139: 
   140:   let bound_exes : bexe_t list ref = ref [] in
   141:   let tack x = bound_exes := x :: !bound_exes in
   142:   let rec bind_exe (sr,x) =
   143:     (*
   144:     print_endline ("EXE="^string_of_exe 1 x);
   145:     *)
   146:     if not !reachable then
   147:     begin
   148:       match x with
   149:       | `EXE_label _ -> ()
   150:       | `EXE_comment _ -> ()
   151:       | `EXE_nop _ -> ()
   152:       | _ -> print_endline
   153:         (
   154:           "WARNING: Unreachable code in "^id^": " ^
   155:           string_of_exe 1 x ^ " in\n" ^
   156:           short_string_of_src sr
   157:         );
   158:     end
   159:     ;
   160:     match x with
   161:     | `EXE_comment s ->       tack (`BEXE_comment (sr,s))
   162:     | `EXE_label s ->         reachable := true; tack (`BEXE_label (sr,s))
   163:     | `EXE_goto s ->          reachable := false; tack (`BEXE_goto (sr,s))
   164: 
   165:     | `EXE_ifgoto (e,s) ->
   166:       let e',t = be e in
   167:       if lstrip syms.dfns t = flx_bbool
   168:       then tack (`BEXE_ifgoto (sr,(e',t), s))
   169:       else
   170:         clierr (src_of_expr e)
   171:         (
   172:           "[bind_exes:ifgoto] Conditional requires bool argument, got " ^
   173:           string_of_btypecode syms.dfns t
   174:         )
   175: 
   176:     | `EXE_ifnotgoto (e,s) ->
   177:       let e',t = be e in
   178:       if lstrip syms.dfns t = flx_bbool
   179:       then tack (`BEXE_ifnotgoto (sr,(e',t), s))
   180:       else
   181:         clierr (src_of_expr e)
   182:         (
   183:           "[bind_exes:ifnotgoto] Conditional requires bool argument, got " ^
   184:           string_of_btypecode syms.dfns t ^ " in\n" ^
   185:           short_string_of_src sr
   186:         )
   187: 
   188:     | `EXE_loop (n,e2) ->
   189:       let be2,t2 = be e2 in
   190:       let tbe1 =
   191:          lookup_qn_with_sig
   192:          syms
   193:          sr sr
   194:          env
   195:          (`AST_name(sr,n,[]) : qualified_name_t)
   196:          [t2]
   197:       in
   198:         (* reverse order .. *)
   199:         tack (`BEXE_proc_return sr);
   200:         (* note cal_loop actually generates a call .. *)
   201:         tack (cal_loop syms sr tbe1 (be2,t2) index)
   202: 
   203:     | `EXE_jump (a,b) ->
   204:       incr proc_return_count;
   205:       bind_exe (sr,`EXE_call (a,b));
   206:       bind_exe  (sr,`EXE_proc_return)
   207: 
   208:     | `EXE_call (`AST_name (_,"axiom_check",[]), e2) ->
   209:        tack (`BEXE_axiom_check(sr,be e2))
   210: 
   211:     | `EXE_call (#suffixed_name_t as sn, e2) -> (* OVERLOADING *)
   212:       let sr = src_of_expr sn in
   213:       let be2,t2 = be e2 in
   214:       let (be1,t1) as tbe1 =
   215:          match sn with
   216:          | #qualified_name_t as qn ->
   217:            lookup_qn_with_sig
   218:            syms
   219:            sr sr
   220:            env
   221:            qn [t2]
   222:          | _ -> be sn
   223:       in
   224:         tack (cal_call syms sr tbe1 (be2,t2))
   225: 
   226:     | `EXE_apply_ctor (vname, clsname, arg) ->
   227:       let (e2,t2) as barg = be arg in
   228:       let var_idx =
   229:         let varname = `AST_name (sr,vname,[]) in
   230:         match be varname with
   231:           | `BEXPR_name (i,[]),_ -> i
   232:           | _ -> clierr sr "Expected (nonpolymorphic) variable name to store object"
   233:       in
   234:       let cls = be clsname in
   235:       begin match cls with
   236: 
   237:       | `BEXPR_name (class_idx,ts),_ ->
   238:         begin
   239:           match
   240:             try Hashtbl.find syms.dfns class_idx
   241:             with Not_found ->
   242:               syserr sr ("[bexe][EXE_apply_ctor] Weird, can't find class index " ^ si class_idx)
   243:           with
   244:           | {id=name;pubmap=pubmap;symdef=`SYMDEF_class} ->
   245:             (*
   246:             print_endline ("Found a class "^name^", look for constructor with hacked name _ctor_"^name);
   247:             *)
   248:             let entries = lookup_name_in_htab pubmap ("_ctor_" ^ name) in
   249:             begin match entries with
   250:             | None -> clierr sr "Unable to find any constructors for this class"
   251:             | Some (NonFunctionEntry _) -> syserr sr
   252:               "[EXE_apply_ctor: lookup_name_in_table_dirs_with_sig] Expected constructor to be a procedure"
   253: 
   254:             | Some (FunctionEntry fs) ->
   255:               (*
   256:               print_endline ("Ok, found "^si (length fs) ^"constructors for " ^ name);
   257:               *)
   258:               let ro =
   259:                 resolve_overload
   260:                 syms sr fs ("_ctor_" ^ name) [t2] [] (* constructors can't be polymorphic *)
   261:               in
   262:               match ro with
   263:                 | Some (ctor_idx,t,mgu,ts') ->
   264:                   (* The overload resolution is generic, but the application
   265:                     is concrete. so ts' should be a list of type variables
   266:                     corresponding to the class vs, and the mgu should
   267:                     map these to the ts used to instantiate the class..??
   268:                   *)
   269:                   if length ts' <> length ts then
   270:                     clierr sr ("[EXE_apply_ctor] Type subscript mismatch:\n" ^
   271:                     "got type subscripts " ^ catmap "," (sbt syms.dfns) ts')
   272:                   ;
   273:                   tack (`BEXE_apply_ctor (sr,var_idx,class_idx,ts,ctor_idx, barg))
   274:                 | None ->
   275:                   clierr sr
   276:                   (
   277:                     "Unable to find matching constructor for class " ^ name ^
   278:                     "<" ^ si class_idx ^ ">[" ^
   279:                     catmap "," (sbt syms.dfns) ts ^ "](" ^
   280:                     sbt syms.dfns t2 ^ ")"
   281:                   )
   282:             end
   283:           | _ -> clierr sr "Argument of new must be a class"
   284:         end
   285:       | `BEXPR_closure (i,ts),_ ->
   286:         clierr sr ("Class constructor must name class, and we got a closure (which is right but unexpected ..)")
   287: 
   288:       | _ ->
   289:         clierr sr ("Class constructor must name class, got " ^ sbe syms.dfns cls)
   290:       end
   291: 
   292:     | `EXE_call (p,e) ->
   293:       let p',pt' = be p and e',et' = be e in
   294:       tack (cal_call syms sr (p', pt') (e', et'))
   295: 
   296:     | `EXE_svc s ->
   297:       begin match lun sr s with
   298:       | NonFunctionEntry (index) ->
   299:         let {symdef=entry; id=id} = Hashtbl.find syms.dfns index in
   300:         begin match entry with
   301:         | `SYMDEF_var _ -> ()
   302:         | `SYMDEF_val _ -> clierr sr ("Can't svc into value " ^ id)
   303:         | `SYMDEF_parameter _ -> clierr sr ("Can't svc into parameter value " ^ id)
   304:         | _ -> clierr sr ("[bexe] svc requires variable, got " ^ id)
   305:         end
   306:         ;
   307:         tack (`BEXE_svc (sr,index))
   308: 
   309:       | FunctionEntry _ -> failwith "Can't svc function!"
   310:       end
   311: 
   312:     | `EXE_proc_return ->
   313:       incr proc_return_count;
   314:       reachable := false;
   315:       if do_unify syms !ret_type `BTYP_void
   316:       then
   317:         begin
   318:           ret_type := varmap_subst syms.varmap !ret_type;
   319:           tack (`BEXE_proc_return sr)
   320:         end
   321:       else
   322:         clierr sr
   323:         (
   324:           "function " ^id^" has void return type"
   325:         )
   326: 
   327:     | `EXE_fun_return e ->
   328:       reachable := false;
   329:       incr return_count;
   330:       let e',t' = be e in
   331:       let t' = minimise syms.dfns t' in
   332:       if do_unify syms !ret_type t' then begin
   333:         ret_type := varmap_subst syms.varmap !ret_type;
   334:         tack (`BEXE_fun_return (sr,(e',lower t')))
   335:       end
   336:       else
   337:         clierr sr
   338:         (
   339:           "In " ^ string_of_exe 0 x ^ "\n" ^
   340:           "Wrong return type,\nexpected : " ^
   341:           string_of_btypecode syms.dfns !ret_type ^
   342:           "\nbut we got " ^
   343:           string_of_btypecode syms.dfns t'
   344:         )
   345: 
   346:     | `EXE_nop s ->           tack (`BEXE_nop (sr,s))
   347:     | `EXE_code s ->          tack (`BEXE_code (sr,s))
   348:     | `EXE_noreturn_code s ->
   349:       reachable := false;
   350:       tack (`BEXE_nonreturn_code (sr,s))
   351: 
   352:     | `EXE_assert e ->
   353:       let (x,t) as e' = be e in
   354:       if lstrip syms.dfns t = flx_bbool
   355:       then tack (`BEXE_assert (sr,e'))
   356:       else clierr sr
   357:       (
   358:         "assert requires bool argument, got " ^
   359:         string_of_btypecode syms.dfns t
   360:       )
   361: 
   362:     | `EXE_iinit ((s,index),e) ->
   363:         let e',rhst = be e in
   364:         let lhst = typeofindex_with_ts syms sr index parent_ts in
   365:         let rhst = minimise syms.dfns rhst in
   366:         let lhst = match lhst with |`BTYP_lvalue t -> t | t -> t in
   367:         if type_match syms.dfns lhst rhst
   368:         then tack (`BEXE_init (sr,index, (e',rhst)))
   369:         else clierr sr
   370:         (
   371:           "[bind_exe] LHS["^s^"<"^si index^">]:\n"^
   372:           string_of_btypecode syms.dfns lhst^
   373:           "\n of initialisation must have same type as RHS:\n"^
   374:           string_of_btypecode syms.dfns rhst^
   375:           "\nunfolded LHS = " ^ sbt syms.dfns (unfold syms.dfns lhst) ^
   376:           "\nenvironment type variables are " ^
   377:           print_vs parent_vs
   378: 
   379:         )
   380: 
   381:     | `EXE_init (s,e) ->
   382:       begin match lun sr s with
   383:       | FunctionEntry _ -> clierr sr "Can't init function constant"
   384:       | NonFunctionEntry (index) ->
   385:         let e',rhst = be e in
   386:         let lhst = typeofindex_with_ts syms sr index parent_ts in
   387:         let rhst = minimise syms.dfns rhst in
   388:         let lhst = match lhst with |`BTYP_lvalue t -> t | t -> t in
   389:         (*
   390:         print_endline ("Checking type match " ^ sbt syms.dfns lhst ^ " ?= " ^ sbt syms.dfns rhst);
   391:         *)
   392:         if type_match syms.dfns lhst rhst
   393:         then tack (`BEXE_init (sr,index, (e',rhst)))
   394:         else clierr sr
   395:         (
   396:           "[bind_exe] LHS["^s^"<"^si index^">]:\n"^
   397:           string_of_btypecode syms.dfns lhst^
   398:           "\n of initialisation must have same type as RHS:\n"^
   399:           string_of_btypecode syms.dfns rhst^
   400:           "\nunfolded LHS = " ^ sbt syms.dfns (unfold syms.dfns lhst) ^
   401:           "\nenvironment type variables are " ^
   402:           print_vs parent_vs
   403: 
   404:         )
   405:       end
   406: 
   407:     | `EXE_assign (l,r) ->
   408:       let (_,lt) as bel = be l in
   409:       begin match lt with
   410:       |  `BTYP_lvalue _ ->
   411:          tack (`BEXE_assign (sr,bel, be r))
   412:       | _ -> clierr sr "LHS must be lvalue"
   413:       end
   414: 
   415:       (*
   416:       begin match bel with
   417:       | `BEXPR_name (index,_),_ ->
   418:         let {symdef=entry; id=id} = Hashtbl.find syms.dfns index in
   419:         begin match entry with
   420:         | `SYMDEF_var _ -> ()
   421:         | `SYMDEF_val _ -> clierr sr ("Can't assign into value " ^ id)
   422:         | `SYMDEF_parameter _ -> clierr sr ("Can't assign into parameter value " ^ id)
   423:         | _ -> clierr sr ("[bexe] assign requires variable, got " ^ id)
   424:         end
   425:       | `BEXPR_deref _,_ -> ()
   426: 
   427:       | `BEXPR_apply_prim (i,_,_),_ ->
   428:         let {symdef=entry; id=id; vs=vs} = Hashtbl.find syms.dfns i in
   429:         begin match entry with
   430:         | `SYMDEF_fun (_,t,_,_) ->
   431:           begin match t with
   432:           | `TYP_lvalue _ -> ()
   433:           | _ ->
   434:             print_endline
   435:             (
   436:               "WARNING: assign to application of primitive "^
   437:               id^
   438:               " not declared to return an lvalue"
   439:             )
   440:           end
   441:         | _ ->
   442:           failwith
   443:           (
   444:             "[bexe]Expected prim apply to apply a primitive fun, got: " ^
   445:             string_of_symdef entry id vs
   446:           )
   447:         end
   448:       | _ ->
   449:         print_endline ("Assign to non variable..(is it an lvalue?)" ^ sbe syms.dfns bel);
   450:         ()
   451:       end
   452:       ;
   453:       tack (`BEXE_assign (sr,bel, be r))
   454:       *)
   455: 
   456: 
   457:   in
   458:   List.iter bind_exe exes;
   459:   let bound_exes = List.rev !bound_exes in
   460:   (*
   461:   print_endline ""
   462:   ;
   463:   List.iter
   464:     (fun x -> print_endline (string_of_bexe syms.dfns 1 x))
   465:     bound_exes
   466:   ;
   467:   print_endline ""
   468:   ;
   469:   print_endline "BINDING COMPLETE"
   470:   ;
   471:   *)
   472: 
   473:   (* No function return statements found: it must be a procedure,
   474:      so unify void [just a comparison with void .. heh!]
   475:   *)
   476:   if !return_count = 0 then
   477:   begin
   478:     if do_unify syms !ret_type `BTYP_void
   479:     then
   480:       ret_type := varmap_subst syms.varmap !ret_type
   481:     else
   482:       clierr sr
   483:       (
   484:         "procedure " ^id^" has non-void return type"
   485:       )
   486:   end
   487:   ;
   488: 
   489:   begin match !ret_type with
   490:   | `BTYP_void ->
   491:     if
   492:       not !reachable &&
   493:       !proc_return_count = 0 &&
   494:       syms.compiler_options.print_flag
   495:     then print_endline
   496:     (
   497:       "WARNING: procedure " ^id^
   498:       " has no explicit return and doesn't drop thru end," ^
   499:       "\npossible infinite loop"
   500:     )
   501:   | _ ->
   502:     if !reachable then begin
   503:       (* this is now a hard error ..
   504:          functions must manifestly return. We have to be careful
   505:          generating code where the compiler cannot deduce
   506:          that a final branch cannot be taken .. the user,
   507:          however, is required to supply a dead code assertion
   508:          to prevent the error.
   509:       *)
   510:       clierr sr
   511:       (
   512:         "[bind_exes]: function "^id^" drops off end, missing return statement"
   513:       )
   514:       (*
   515:       ;
   516:       print_endline "[DEBUG] Instruction sequence is:";
   517:       iter (fun exe -> print_endline (string_of_bexe syms.dfns 0 exe)) bound_exes
   518:       *)
   519:     end
   520:   end
   521:   ;
   522:   !ret_type,bound_exes
   523: 
   524: 
End ocaml section to src/flx_bexe.ml[1]