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