5.55. Make stack calls

Name binding pass 2.
Start ocaml section to src/flx_stack_calls.mli[1 /1 ]
     1: # 6 "./lpsrc/flx_enstack.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes2
     5: open Flx_child
     6: open Flx_label
     7: 
     8: val make_stack_calls:
     9:   sym_state_t ->
    10:   child_map_t * fully_bound_symbol_table_t ->
    11:   label_map_t -> label_usage_t ->
    12:   unit
    13: 
End ocaml section to src/flx_stack_calls.mli[1]
Start ocaml section to src/flx_stack_calls.ml[1 /1 ]
     1: # 20 "./lpsrc/flx_enstack.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: 
    18: (* first approximation: we can stack functions that have no
    19:   function or procedure children AND no variables: later
    20:   we will check the return type, for now just check
    21:   the code generator works
    22: *)
    23: 
    24: (* return true if exes contain BEXPR_parse expression *)
    25: let check_parser_calls exes : bool =
    26:   let cp = function
    27:     | `BEXPR_parse _,_ -> raise Not_found
    28:     | _ -> ()
    29:   in
    30:   let cpe e = iter_tbexpr ignore cp ignore e in
    31:   try
    32:     iter (iter_bexe ignore cpe ignore ignore ignore) exes;
    33:     false
    34:   with Not_found -> true
    35: 
    36: (* The Pure property is a bit weird. We consider a function pure
    37:   if it doesn't need a stack frame, and can make do with
    38:   individual variables. This allows the function to be modelled
    39:   with an actual C function.
    40: 
    41:   A pure function must be top level and cannot have any
    42:   child functions. This means it depends only on its parameters
    43:   and globals -- globals are allowed because we pass the thread
    44:   frame pointer in, even to C functions.
    45: 
    46:   We assume a non-toplevel function is a child of some other
    47:   function for a reason -- to access that functions environment.
    48:   Still .. we could pass the display in, just as we pass the
    49:   thread frame pointer.
    50: 
    51:   What we really cannot allow is a child function, since we
    52:   cannot pass IT our frame pointer, since we don't have one.
    53: 
    54:   Because of this weird notion, we can also mark procedures
    55:   pure under the same conditions, and implement them as
    56:   C functions as well.
    57: 
    58:   Note neither a function nor procedure can be pure unless
    59:   it is also stackable, and the C function model can't be used
    60:   for either if a heap closure is formed.
    61: *)
    62: let rec is_pure syms (child_map, bbdfns) i =
    63:   let children = try Hashtbl.find child_map i with Not_found -> [] in
    64:   let id,parent,sr,entry = Hashtbl.find bbdfns i in
    65:   (*
    66:   print_endline ("Checking purity of " ^ id ^ "<" ^ si i ^ ">");
    67:   *)
    68:   match entry with
    69:   | `BBDCL_var _
    70:   | `BBDCL_ref _
    71:   | `BBDCL_val _
    72:   | `BBDCL_tmp _
    73:   | `BBDCL_const_ctor _
    74:   | `BBDCL_nonconst_ctor _
    75:   | `BBDCL_callback _
    76:   | `BBDCL_insert _
    77:   | `BBDCL_struct _
    78:   | `BBDCL_cstruct _
    79:   | `BBDCL_union _
    80:   | `BBDCL_abs _
    81:   | `BBDCL_newtype _
    82:   | `BBDCL_const _
    83:   | `BBDCL_typeclass _
    84:   | `BBDCL_instance _
    85:     ->
    86:     (*
    87:     print_endline (id ^ " is intrinsically pure");
    88:     *)
    89:     true
    90: 
    91:   (* not sure if this is the right place for this check .. *)
    92:   | `BBDCL_fun (_,_,_,_,ct,_,_)
    93:   | `BBDCL_proc (_,_,_,ct,_) ->
    94:     ct <> `Virtual
    95: 
    96:   | `BBDCL_cclass _  (* not sure FIXME .. *)
    97:   | `BBDCL_class _  (* not sure FIXME .. *)
    98:   | `BBDCL_glr _
    99:   | `BBDCL_reglex _
   100:   | `BBDCL_regmatch _
   101:     ->
   102:     (*
   103:     print_endline (id ^ " is intrinsically Not pure");
   104:     *)
   105:     false
   106: 
   107:   | `BBDCL_procedure (_,_,_,exes)   (* ALLOWED NOW *)
   108:   | `BBDCL_function (_,_,_,_,exes) ->
   109:     match parent with
   110:     | Some _ ->
   111:       (*
   112:       print_endline (id ^ " is parented so Not pure");
   113:       *)
   114:       false
   115: 
   116:     | None ->
   117:     try
   118:       iter (fun kid ->
   119:         if not (is_pure syms (child_map, bbdfns) kid)
   120:         then begin
   121:           (*
   122:           print_endline ("Child " ^ si kid ^ " of " ^ id ^ " is not pure");
   123:           *)
   124:           raise Not_found
   125:         end
   126:         (*
   127:         else begin
   128:           print_endline ("Child " ^ si kid ^ " of " ^ id ^ " is pure");
   129:         end
   130:         *)
   131:       )
   132:       children
   133:       ;
   134:       (*
   135:       print_endline (id ^ " is checked pure, checking for parser calls ..");
   136:       *)
   137:       let pure = not (check_parser_calls exes) in
   138:       (*
   139:       if pure then
   140:         print_endline (id ^ " is Pure")
   141:       else
   142:         print_endline (id ^ " calls a parser, NOT Pure")
   143:       ;
   144:       *)
   145:       pure
   146: 
   147:     with
   148:     | Not_found ->
   149:       (*
   150:       print_endline (id ^ " is checked Not pure");
   151:       *)
   152:       false
   153: 
   154: 
   155: exception Found
   156: 
   157: (* A function is stackable provided it doesn't return
   158:   a pointer to itself. There are only two ways this
   159:   can happen: the function returns the address of
   160:   a variable, or, it returns the closure of a child.
   161: 
   162:   We will check the return type for pointer or
   163:   function types. If its a function, there
   164:   has to be at least one child to grab our this
   165:   pointer in its display. If its a pointer,
   166:   there has to be either a variable, or any
   167:   non-stackable child function, or any child
   168:   procedure -- note that the pointer might address
   169:   a variable in a child function or procedure,
   170:   however it can't 'get out' of a function except
   171:   by it being returned.
   172: 
   173:   Proposition: type variables cannot carry either
   174:   pointers to a variable or a child function closure.
   175: 
   176:   Reason: type variables are all universally quantified
   177:   and unconstrained. We would have v1 = &v2 for the pointer
   178:   case, contrary to the current lack of constraints.
   179:   Smly for functions. So we'll just ignore type variables.
   180: 
   181:   NOTE: a stacked frame is perfectly viable as a display
   182:   entry -- a heaped child can still refer to a stacked
   183:   parent frame: of course the child must not both persist
   184:   after the frame dies and also refer to that frame.
   185: 
   186:   This means the display, not just the caller, must be nulled
   187:   out of a routine when it loses control finally. Hmmm .. not
   188:   sure I'm doing that. That means only *explicit* Felix pointers
   189:   in the child refering to the parent frame can hold onto
   190:   the frame. In this case the parent must be heaped if the child
   191:   is, since the parent stacked frame is lost when control is lost.
   192: *)
   193: 
   194: let has_var bbdfns children =
   195:   try
   196:     iter
   197:     (fun i ->
   198:       let id,parent,sr,entry = Hashtbl.find bbdfns i in
   199:       match entry with
   200:       | `BBDCL_var _  -> raise Found
   201:       | _ -> ()
   202:     )
   203:     children
   204:     ;
   205:     true
   206:   with Found -> false
   207: 
   208: let has_fun bbdfns children =
   209:   try
   210:     iter
   211:     (fun i ->
   212:       let id,parent,sr,entry = Hashtbl.find bbdfns i in
   213:       match entry with
   214:       | `BBDCL_procedure _
   215:       | `BBDCL_function _ -> raise Found
   216:       | _ -> ()
   217:     )
   218:     children
   219:     ;
   220:     true
   221:   with Found -> false
   222: 
   223: 
   224: (* NOTE: this won't work for abstracted types like unions
   225:    or structs ..
   226: *)
   227: exception Unsafe
   228: 
   229: let has_ptr_fn cache syms bbdfns children e =
   230:   let rec aux e =
   231:     let check_components vs ts tlist =
   232:       let varmap = mk_varmap vs ts in
   233:       begin try
   234:         iter
   235:           (fun t ->
   236:             let t = varmap_subst varmap t in
   237:             aux t
   238:           )
   239:         tlist;
   240:         Hashtbl.replace cache e `Safe
   241:       with Unsafe ->
   242:         Hashtbl.replace cache e `Unsafe;
   243:         raise Unsafe
   244:       end
   245:     in
   246:     try match Hashtbl.find cache e with
   247:     | `Recurse -> ()
   248:     | `Unsafe -> raise Unsafe
   249:     | `Safe -> ()
   250:     with Not_found ->
   251:       Hashtbl.add cache e `Recurse;
   252:       match e with
   253:       | `BTYP_function _ ->
   254:         (* if has_fun bbdfns children then *)
   255:         Hashtbl.replace cache e `Unsafe;
   256:         raise Unsafe
   257: 
   258:       | `BTYP_pointer _ ->
   259:         (* encode the more lenient condition here!! *)
   260:         Hashtbl.replace cache e `Unsafe;
   261:         raise Unsafe
   262: 
   263:       | `BTYP_inst (i,ts) ->
   264:         let id,parent,sr,entry = Hashtbl.find bbdfns i in
   265:         begin match entry with
   266:         | `BBDCL_newtype _ -> () (* FIXME *)
   267:         | `BBDCL_abs _ -> ()
   268:         | `BBDCL_union (vs,cs)->
   269:           check_components vs ts (map (fun (_,_,t)->t) cs)
   270: 
   271:         | `BBDCL_struct (vs,cs)
   272:         | `BBDCL_cstruct (vs,cs) ->
   273:           check_components vs ts (map snd cs)
   274: 
   275:         | `BBDCL_class _ ->
   276:           Hashtbl.replace cache e `Unsafe;
   277:           raise Unsafe
   278: 
   279:         | `BBDCL_cclass (vs,cs) ->
   280:           ()
   281:           (* nope, it isn't a use *)
   282:           (*
   283:           let tlist = map (function
   284:             | `BMemberVal (_,t)
   285:             | `BMemberVar (_,t)
   286:             | `BMemberFun (_,_,t)
   287:             | `BMemberProc (_,_,t)
   288:             | `BMemberCtor (_,t) -> t
   289:             ) cs
   290:           in
   291:           check_components vs ts tlist
   292:           *)
   293: 
   294:         | _ -> assert false
   295:         end
   296:       | x ->
   297:         try
   298:           iter_btype aux x;
   299:           Hashtbl.replace cache e `Safe
   300:         with Unsafe ->
   301:           Hashtbl.replace cache e `Unsafe;
   302:           raise Unsafe
   303: 
   304:   in try aux e; false with Unsafe -> true
   305: 
   306: let can_stack_func cache syms (child_map,bbdfns) i =
   307:   let children = try Hashtbl.find child_map i with Not_found -> [] in
   308:   let id,parent,sr,entry = Hashtbl.find bbdfns i in
   309:   match entry with
   310:   | `BBDCL_function (_,_,_,ret,_) ->
   311:     not (has_ptr_fn cache syms bbdfns children ret)
   312: 
   313:   | `BBDCL_nonconst_ctor _
   314:   | `BBDCL_fun _
   315:   | `BBDCL_callback _
   316:   | `BBDCL_struct _
   317:   | `BBDCL_cstruct _
   318:   | `BBDCL_regmatch _
   319:   | `BBDCL_reglex _
   320:     -> false (* hack *)
   321:   | _ -> failwith ("Unexpected non-function " ^ id)
   322: 
   323: let rec can_stack_proc cache syms (child_map,bbdfns) label_map label_usage i recstop =
   324:   let children = try Hashtbl.find child_map i with Not_found -> [] in
   325:   let id,parent,sr,entry = Hashtbl.find bbdfns i in
   326:   (*
   327:   print_endline ("Stackability Checking procedure " ^ id);
   328:   *)
   329:   match entry with
   330:   | `BBDCL_procedure (_,_,_,exes) ->
   331:     let labels = Hashtbl.find label_map i in
   332:     begin try iter (fun exe ->
   333:     (*
   334:     print_endline (string_of_bexe syms.dfns 0 exe);
   335:     *)
   336:     match exe with
   337: 
   338:     | `BEXE_axiom_check _ -> assert false
   339:     | `BEXE_svc _ -> raise Not_found
   340:     | `BEXE_call (_,(`BEXPR_closure (j,_),_),_)
   341:     | `BEXE_call_direct (_,j,_,_)
   342:     | `BEXE_call_method_direct (_,_,j,_,_)
   343:     | `BEXE_apply_ctor (_,_,_,_,j,_)
   344: 
   345:     (* this case needed for virtuals/typeclasses .. *)
   346:     | `BEXE_call_prim (_,j,_,_)
   347:       ->
   348:       if not (check_stackable_proc cache syms (child_map,bbdfns) label_map label_usage j (i::recstop))
   349:       then begin
   350:         (*
   351:         print_endline (id ^ " calls unstackable proc " ^ si j);
   352:         *)
   353:         raise Not_found
   354:       end
   355: 
   356:     (* assignments to a local variable are safe *)
   357:     | `BEXE_init (_,j,_)
   358:     | `BEXE_assign (_,(`BEXPR_name (j,_),_),_)
   359:       when mem j children -> ()
   360: 
   361:     | `BEXE_init (sr,_,(_,t))
   362:     | `BEXE_assign (sr,(_,t),_)
   363:       when not (has_ptr_fn cache syms bbdfns children t) -> ()
   364: 
   365:     | `BEXE_init _
   366:     | `BEXE_assign _ ->
   367:       (*
   368:       print_endline (id ^ " does foreign init/assignment");
   369:       *)
   370:       raise Not_found
   371: 
   372:     | `BEXE_call _
   373:        ->
   374:        (*
   375:        print_endline (id ^ " does nasty call");
   376:        *)
   377:        raise Not_found
   378:     | `BEXE_jump _
   379:     | `BEXE_jump_direct _
   380:        ->
   381:        (*
   382:        print_endline (id ^ " does jump");
   383:        *)
   384:        raise Not_found
   385:     | `BEXE_loop _
   386:        ->
   387:        (*
   388:        print_endline (id ^ " has loop?");
   389:        *)
   390:        raise Not_found
   391: 
   392:     | `BEXE_label (_,s) ->
   393:        let  lno = Hashtbl.find labels s in
   394:        let lkind = Hashtbl.find label_usage lno in
   395:        if lkind = `Far then raise Not_found
   396: 
   397:     | `BEXE_yield _
   398:     | `BEXE_fun_return _ -> assert false
   399: 
   400:     (* Assume these are safe .. ? *)
   401:     | `BEXE_code _
   402:     | `BEXE_nonreturn_code _
   403: 
   404:     | `BEXE_apply_ctor_stack _
   405:     | `BEXE_call_stack _ (* cool *)
   406:     | `BEXE_call_method_stack _
   407:     | `BEXE_halt _
   408:     | `BEXE_comment _
   409:     | `BEXE_goto _
   410:     | `BEXE_ifgoto _
   411:     | `BEXE_ifnotgoto _
   412:     | `BEXE_assert _
   413:     | `BEXE_assert2 _
   414:     | `BEXE_begin
   415:     | `BEXE_end
   416:     | `BEXE_nop _
   417:     | `BEXE_proc_return _
   418:       -> ()
   419:     )
   420:     exes;
   421:     (*
   422:     print_endline (id ^ " is stackable");
   423:     *)
   424:     true
   425:     with Not_found ->
   426:       (*
   427:       print_endline (id ^ " cannot be stacked ..");
   428:       *)
   429:       false
   430:     end
   431: 
   432:   | _ -> assert false
   433: 
   434: and check_stackable_proc cache syms (child_map,bbdfns) label_map label_usage i recstop =
   435:   if mem i recstop then true else
   436:   let id,parent,sr,entry = Hashtbl.find bbdfns i in
   437:   match entry with
   438:   | `BBDCL_callback _ -> false (* not sure if this is right .. *)
   439:   | `BBDCL_proc (_,_,_,ct,_) -> ct <> `Virtual
   440:   | `BBDCL_procedure (props,vs,p,exes) ->
   441:     if mem `Stackable props then true
   442:     else if mem `Unstackable props then false
   443:     else if can_stack_proc cache syms (child_map,bbdfns) label_map label_usage i recstop
   444:     then begin
   445:       (*
   446:       print_endline ("MARKING PROCEDURE " ^ id ^ " stackable!");
   447:       *)
   448:       let props = `Stackable :: props in
   449:       let props =
   450:         if is_pure syms (child_map,bbdfns) i then `Pure :: props else props
   451:       in
   452:       let entry : bbdcl_t = `BBDCL_procedure (props,vs,p,exes) in
   453:       Hashtbl.replace bbdfns i (id,parent,sr,entry);
   454:       true
   455:     end
   456:     else begin
   457:       let entry : bbdcl_t = `BBDCL_procedure (`Unstackable :: props,vs,p,exes) in
   458:       Hashtbl.replace bbdfns i (id,parent,sr,entry);
   459:       false
   460:     end
   461:   | _ -> failwith ("Unexpected non-procedure " ^ id)
   462:     (*
   463:     assert false
   464:     *)
   465: 
   466: let ident x = x
   467: let tident t = t
   468: 
   469: (* this routine NORMALISES applications to one of the forms:
   470:   apply_stack  -- apply on the stack
   471:   apply_direct -- direct application
   472:   apply_prim   -- apply primitive
   473:   apply_struct -- apply struct, cstruct, or nonconst variant type constructor
   474:   apply        -- general apply
   475: *)
   476: let rec enstack_applies cache syms (child_map, bbdfns) x =
   477:   let ea e = enstack_applies cache syms (child_map, bbdfns) e in
   478:   match map_tbexpr ident ea tident x with
   479:   | (
   480:        `BEXPR_apply ((`BEXPR_closure(i,ts),_),b),t
   481:      | `BEXPR_apply_direct (i,ts,b),t
   482:     ) as x ->
   483:       begin
   484:         let _,_,_,entry = Hashtbl.find bbdfns i in
   485:         match entry with
   486:         | `BBDCL_function (props,_,_,_,_) ->
   487:           if mem `Stackable props
   488:           then `BEXPR_apply_stack (i,ts,b),t
   489:           else `BEXPR_apply_direct (i,ts,b),t
   490:         | `BBDCL_fun _
   491:         | `BBDCL_callback _ ->
   492:           `BEXPR_apply_prim(i,ts,b),t
   493: 
   494:         | `BBDCL_struct _
   495:         | `BBDCL_cstruct _
   496:         | `BBDCL_nonconst_ctor  _ ->
   497:           `BEXPR_apply_struct(i,ts,b),t
   498:         | _ -> x
   499:       end
   500:   | (
   501:       `BEXPR_apply ((`BEXPR_method_closure (obj,meth,ts),_),b),t
   502:       | `BEXPR_apply_method_direct (obj,meth,ts,b),t
   503:     ) as x ->
   504:       begin
   505:         let _,_,_,entry = Hashtbl.find bbdfns meth in
   506:         match entry with
   507:         | `BBDCL_function (props,_,_,_,_) ->
   508:           if mem `Stackable props
   509:           then `BEXPR_apply_method_stack (obj,meth,ts,b),t
   510:           else `BEXPR_apply_method_direct (obj,meth,ts,b),t
   511:         | _ -> x
   512:       end
   513:   | x -> x
   514: 
   515: let mark_stackable cache syms (child_map,bbdfns) label_map label_usage =
   516:   Hashtbl.iter
   517:   (fun i (id,parent,sr,entry) ->
   518:     match entry with
   519:     | `BBDCL_function (props,vs,p,ret,exes) ->
   520:       let props: property_t list ref = ref props in
   521:       if can_stack_func cache syms (child_map,bbdfns) i then
   522:       begin
   523:         props := `Stackable :: !props;
   524:         if is_pure syms (child_map,bbdfns) i then
   525:         begin
   526:           (*
   527:           print_endline ("Function " ^ id ^ "<" ^ si i ^ "> is PURE");
   528:           *)
   529:           props := `Pure :: !props;
   530:         end
   531:         (*
   532:         else
   533:           print_endline ("Stackable Function " ^ id ^ "<" ^ si i ^ "> is NOT PURE")
   534:         *)
   535:       end
   536:       (*
   537:       else print_endline ("Function " ^ id ^ "<" ^ si i ^ "> is NOT STACKABLE")
   538:       *)
   539:       ;
   540:       let props : property_t list = !props in
   541:       let entry : bbdcl_t = `BBDCL_function (props,vs,p,ret,exes) in
   542:       Hashtbl.replace bbdfns i (id,parent,sr,entry)
   543: 
   544:     | `BBDCL_procedure (props,vs,p,exes) ->
   545:       if mem `Stackable props or mem `Unstackable props then ()
   546:       else ignore(check_stackable_proc cache syms (child_map,bbdfns) label_map label_usage i [])
   547:     | _ -> ()
   548:   )
   549:   bbdfns
   550: 
   551: let enstack_calls cache syms (child_map,bbdfns) self exes =
   552:   let ea e = enstack_applies cache syms (child_map, bbdfns) e in
   553:   let id x = x in
   554:   let exes =
   555:     map (
   556:       fun exe -> let exe = match exe with
   557:       | `BEXE_call (sr,(`BEXPR_closure (i,ts),_),a)
   558:       | `BEXE_call_direct (sr,i,ts,a) ->
   559:         let id,parent,sr,entry = Hashtbl.find bbdfns i in
   560:         begin match entry with
   561:         | `BBDCL_procedure (props,vs,p,exes) ->
   562:           if mem `Stackable props then
   563:           begin
   564:             if not (mem `Stack_closure props) then
   565:               Hashtbl.replace bbdfns i (id,parent,sr,`BBDCL_procedure (`Stack_closure::props,vs,p,exes))
   566:             ;
   567:             `BEXE_call_stack (sr,i,ts,a)
   568:           end
   569:           else
   570:           `BEXE_call_direct (sr,i,ts,a)
   571: 
   572:         | `BBDCL_proc _ -> `BEXE_call_prim (sr,i,ts,a)
   573: 
   574:         (* seems to work at the moment *)
   575:         | `BBDCL_callback _ -> `BEXE_call_direct (sr,i,ts,a)
   576: 
   577:         | _ -> syserr sr ("Call to non-procedure " ^ id ^ "<" ^ si i ^ ">")
   578:         end
   579: 
   580:       | `BEXE_call_method_direct (sr,obj,i,ts,a) ->
   581:         let id,parent,sr,entry = Hashtbl.find bbdfns i in
   582:         begin match entry with
   583:         | `BBDCL_procedure (props,vs,p,exes) ->
   584:           if mem `Stackable props then
   585:           begin
   586:             if not (mem `Stack_closure props) then
   587:               Hashtbl.replace bbdfns i (id,parent,sr,`BBDCL_procedure (`Stack_closure::props,vs,p,exes))
   588:             ;
   589:             (*
   590:             print_endline "CALL_METHOD_STACK";
   591:             *)
   592:             `BEXE_call_method_stack (sr,obj,i,ts,a)
   593:           end
   594:           else
   595:           `BEXE_call_method_direct (sr,obj,i,ts,a)
   596: 
   597:         | _ -> assert false
   598:         end
   599: 
   600:       | `BEXE_apply_ctor (sr,v,obj,ts,meth,a) ->
   601:         let id,parent,sr,entry = Hashtbl.find bbdfns meth in
   602:         begin match entry with
   603:         | `BBDCL_procedure (props,vs,p,exes) ->
   604:           if mem `Stackable props then
   605:           begin
   606:             if not (mem `Stack_closure props) then
   607:               Hashtbl.replace bbdfns meth (id,parent,sr,`BBDCL_procedure (`Stack_closure::props,vs,p,exes))
   608:             ;
   609:             (*
   610:             print_endline "APPLY_CTOR_STACK";
   611:             *)
   612:             `BEXE_apply_ctor_stack (sr,v,obj,ts,meth,a)
   613:           end
   614:           else
   615:           `BEXE_apply_ctor (sr,v,obj,ts,meth,a)
   616: 
   617:         | _ -> assert false
   618:         end
   619: 
   620:       | x -> x
   621:       in
   622:         map_bexe id ea id id id exe
   623:     )
   624:     exes
   625:   in
   626:   exes
   627: 
   628: let make_stack_calls syms (child_map, (bbdfns: fully_bound_symbol_table_t)) label_map label_usage =
   629:   let cache = Hashtbl.create 97 in
   630:   let ea e = enstack_applies cache syms (child_map, bbdfns) e in
   631:   mark_stackable cache syms (child_map,bbdfns) label_map label_usage;
   632:   Hashtbl.iter
   633:   (fun i (id,parent,sr,entry) -> match entry with
   634:     | `BBDCL_procedure (props,vs,p,exes) ->
   635:       let exes = enstack_calls cache syms (child_map,bbdfns) i exes in
   636:       let exes = Flx_cflow.final_tailcall_opt exes in
   637:       let id,parent,sr,entry = Hashtbl.find bbdfns i in
   638:       begin match entry with
   639:       | `BBDCL_procedure (props,vs,p,_) ->
   640:         Hashtbl.replace bbdfns i (id,parent,sr,`BBDCL_procedure (props,vs,p,exes))
   641:       | _ -> assert false
   642:       end
   643: 
   644:     | `BBDCL_function (props,vs,p,ret,exes) ->
   645:       let exes = enstack_calls cache syms (child_map,bbdfns) i exes in
   646:       let id,parent,sr,entry = Hashtbl.find bbdfns i in
   647:       begin match entry with
   648:       | `BBDCL_function (props,vs,p,ret,_) ->
   649:         Hashtbl.replace bbdfns i (id,parent,sr,`BBDCL_function (props,vs,p,ret,exes))
   650:       | _ -> assert false
   651:       end
   652: 
   653:     | `BBDCL_glr (props,vs,t,(p,exes)) ->
   654:       let exes = enstack_calls cache syms (child_map,bbdfns) i exes in
   655:       let id,parent,sr,entry = Hashtbl.find bbdfns i in
   656:       begin match entry with
   657:       | `BBDCL_glr (props,vs,t,(p,_)) ->
   658:         Hashtbl.replace bbdfns i (id,parent,sr,`BBDCL_glr (props,vs,t,(p,exes)))
   659:       | _ -> assert false
   660:       end
   661: 
   662:     | `BBDCL_regmatch (_,vs,p,t,(a,i,h,m)) ->
   663:       Hashtbl.iter
   664:       (fun k e -> Hashtbl.replace h k (ea e))
   665:       h
   666: 
   667:     | `BBDCL_reglex (_,vs,p,j,t,(a,i,h,m)) ->
   668:       Hashtbl.iter
   669:       (fun k e -> Hashtbl.replace h k (ea e))
   670:       h
   671: 
   672:     | _ -> ()
   673:   )
   674:   bbdfns
   675: 
End ocaml section to src/flx_stack_calls.ml[1]