qmlCpsRewriter.ml

(*
    Copyright © 2011 MLstate

    This file is part of OPA.

    OPA is free software: you can redistribute it and/or modify it under the
    terms of the GNU Affero General Public License, version 3, as published by
    the Free Software Foundation.

    OPA is distributed in the hope that it will be useful, but WITHOUT ANY
    WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
    FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
    more details.

    You should have received a copy of the GNU Affero General Public License
    along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* THIS FILE HAS A DOCUMENTED MLI *)

(*

  TODO:
    -exploit the LetIn rewriting for implementing all multi-expression skipping (like apply case)
    -remove annots were useless fields and add them where usefull match, dot, record construction
*)

(* depends in Base *)
module List = Base.List

(* refactoring in progress *)

(* depends, alias *)
module Factorize = QmlCpsIL.Factorize
module IL = QmlCpsIL.IL
module Q = QmlAst

(* deprecated error managment *)
type error = string
exception Exception of error
external error_message : error -> string = "%identity"

(*
  debug levels : keep it synchro with DebugVariables.mli
*)

module DebugLevel =
struct
  let blocking_wait = 1

  let make_barrier = 2
  let release_barrier = make_barrier

  let cont_tracer = 10

  let il_opt_timer = 1

  let full_backtrace = 100
end

let debug fmt =
  OManager.printf ("@[<2>@{<cyan>[Cps]@}@ "^^fmt^^"@]@.")

(* facilities to generate qmlAst *)
(* TODO: use the statefull constructor, keep annotation, position and types *)
module QC = QmlAstCons.UntypedExpr

(* Bypass helpers *)
let cps_id = "cps"

(* FIXME: use opacapi *)

let bycps_call call = BslKey.normalize (Printf.sprintf "bslcps.%s" call)
let il_bycps_call call = IL.Bypass (bycps_call call, Some cps_id)
let il_other_call call = IL.Bypass (BslKey.normalize call, None)
let qml_bycps_call call = QC.restricted_bypass ~pass:cps_id (bycps_call call)
let qml_other_call call = QC.bypass (bycps_call call)
let qml_byobj_magic () = QC.bypass Opacapi.Opabsl.BslPervasives.Magic.id

let il_bypass key = IL.Bypass (key, None)

let qml_group_app expr =
  let fresh = Ident.next "_" in
  QC.letin [fresh, expr] (QC.ident fresh)

(* TODO: replace errors by call to 1) internal or 2) public errors modules *)
let myself = "QmlCpsRewriter"
let error fmt =
  let k s = raise (Exception s) in
  Printf.ksprintf k fmt

type options =
    {
      no_assert : bool ;
      no_server : bool;
      qml_closure : bool ;
      toplevel_concurrency : bool ;
      warn_x_field : unit ;
      server_side : bool ;
    }

(* please, keep default values synchro with the documentation *)
let default_options =
  {
    no_assert = false ;
    no_server = true;
    qml_closure = false ;
    toplevel_concurrency = false ;
    warn_x_field = () ;
    server_side = true ;
  }

type env =
    {
      options : options ;
      bsl_bypass_tags : BslKey.t -> BslTags.t ;
      bsl_bypass_cps : BslKey.t -> BslKey.t option ;
      bsl_bypass_typer : BslKey.t -> BslTypes.t ;
      typing : QmlTyper.env ;
    }

let env_initial ~options ~bsl_bypass_typer ~bsl_bypass_tags ~bsl_bypass_cps ~typing () =
  {
    options = options ;
    bsl_bypass_typer = bsl_bypass_typer ;
    bsl_bypass_tags = bsl_bypass_tags ;
    bsl_bypass_cps = bsl_bypass_cps ;
    typing = typing ;
  }

(* In order to do the transformation, there is a need for type t used to collect
    toplevel barrier introduction.  *)
type private_env =
    {
      (* skipped functions : (arity * fskip_id * fcps_id) Map *)
      skipped_functions : (int * Ident.t * Ident.t) IdentMap.t;
      toplevel_barrier : Ident.t IdentMap.t ;
      warn_x_field : unit ;
      bindings : (Ident.t * QmlAst.expr) list
    }

let private_env_initial : unit -> private_env = fun () ->
  let bindings = [] in
  {
    skipped_functions = IdentMap.empty;
    toplevel_barrier = IdentMap.empty ;
    warn_x_field = () ;
    bindings = bindings
  }

let print_private_env private_env =
  Printf.printf "SKIPPED\n%!";
  IdentMap.iter( fun k (i,i1,i2) ->
    let n i = Ident.stident i in
    Printf.printf "%s %d => %s , %s\n" (n k) i (n i1) (n i2);
  ) private_env.skipped_functions

let private_binding (private_env:private_env) =
  private_env.bindings

let private_env_get_skipped_fun id private_env =
  IdentMap.find_opt id private_env.skipped_functions


module S =
struct
  type t = private_env
  let pass = "qmlCpsRewriter"
  let pp f _ = Format.pp_print_string f "<dummy>"
end

module Package = struct
  include ObjectFiles.MakeClientServer(S)

  let debug = false

  let load_dependencies ~side =
    let merge _pack a b =
      if debug then Printf.printf "LOADING %s\n%!\n" (fst _pack);
      { skipped_functions = IdentMap.safe_merge a.skipped_functions b.skipped_functions
      ; toplevel_barrier  = IdentMap.safe_merge a.toplevel_barrier  b.toplevel_barrier
      ; warn_x_field = ()
      ; bindings = [] }
    in
    fold_with_name ~side merge (private_env_initial ())

  let save_current ~side ~private_env_initial ~private_env =
    let (-) ab a =
       { skipped_functions = IdentMap.diff ab.skipped_functions a.skipped_functions
       ; toplevel_barrier  = IdentMap.diff ab.toplevel_barrier  a.toplevel_barrier
       ; warn_x_field = ()
       ; bindings = [] }
    in
    let private_env_increment = private_env - private_env_initial in
    if debug then (
      Printf.printf "SAVING\n%!\n";
      print_private_env private_env_initial;
      print_private_env private_env;
      print_private_env private_env_increment;
    );
    save ~side private_env_increment
end



(* production of embeded location error messages in the server *)
let string_of_pos = FilePos.to_string

(*
   Fetch the definition and the type of a bypass, for use in CPS.

   For the moment, we have no CPS-specific BSL language. Therefore,
   we take the OCaml implementation of the bypass and we transform
   it into a CPS function.

   Note that this form of embedding would fail if a function appears in
   negative position of the type of your bypass (i.e. as argument to a
   function).

   That's why the CTrans has provided a reverse transformation mechanism,
   a way of transforming an OCaml ['a -> 'b continuation -> unit] function
   into a OCaml ['a -> 'b] function using the [uncps-n] primitives.

   In the future, we could also think about having special cps
   types in the bsl, in order to see if we need to do the conversion
   or not.
*)

(* The cps transform makes no assumption about the bypass it receives
 * It will eta expand if needed, but only when necessary (when bypasses
 * are not applied) *)
let expand_bypass (env:env) (expr:QmlAst.expr) =
  let key =
    match expr with
    | Q.Directive (_, `restricted_bypass _, [Q.Bypass (_, key)], _)
    | Q.Bypass (_, key) -> key
    | _ -> assert false in
  let typ = env.bsl_bypass_typer key in
  (* forming the type list corresponding to this type *)
  let inputs, _output = match typ with
    | BslTypes.Fun (_, inputs, output) -> Some inputs, output
    | _ -> None, typ
  in
  match inputs with
  | None ->
      (* it is not a function, do nothing *)
      None
  | Some l ->
      let n = List.length l in
      let args = List.init n (fun i -> Ident.nextf "bypass_arg_%d" i) in
      let apply = QC.apply expr (List.map QC.ident args) in
      Some (QC.lambda args apply)


(* private context to be sure to control what goes out *)
module Context :
sig
  type t
  val make :
    transaction:(IL.vident -> IL.term) option ->
    kappa:(IL.vident -> IL.term) ->
    cont:(IL.cident) option ->
    parent:(IL.cident) option ->
    t
  val start : parent:IL.cident option -> t
  val apply : t -> IL.vident -> IL.term
  val cont : t -> IL.cident -> t
  val kappa : t -> (IL.vident -> IL.term) -> t
  val insertLetCont : t -> (IL.cident -> IL.term) -> IL.term
  val current_cont : t -> IL.cident option
end =
struct
  type t =
      {
        (*The continuation to use in case of transaction failure*)
        transaction: (IL.vident -> IL.term) option;
        kappa: IL.vident -> IL.term ;
        cont : IL.cident option;
        parent : IL.cident option;
      }

  let make ~transaction ~kappa ~cont ~parent =
    {
      transaction = transaction ;
      kappa = kappa ;
      cont = cont;
      parent = parent;

    }

  let start ~parent =
    make
      ~transaction:None
      ~kappa:(fun x -> IL.Done (x, "Top-level expression terminated"))
      ~cont:None
      ~parent

  (* until we manage to remove totally kappa (context.kappa)
      we switch to an hybrid approach with an option of cident *)
  let apply context =
    match context.cont with
    | Some k -> (fun z -> IL.ApplyCont(k, z))
    | None -> context.kappa

  let cont context cont = { context with cont = Some cont }
  let kappa context kappa = { context with cont = None ; kappa = kappa }

  (* dont produce re-binding continuation *)
  (* insertLetCont is never called with a of_cont introducing a ApplyCont,
     so it does not introduced direct applied cont *)
  let insertLetCont context of_cont =
    match context.cont with
    | Some k -> of_cont k
    | None ->
        begin
          let v = IL.fresh_v () in
          let returned = context.kappa v in
          match v, returned with
          | IL.Value v, IL.ApplyCont (cont, IL.Value v')
              when Ident.equal v v' -> of_cont cont
          | _ ->
              let c = IL.fresh_c () in
              IL.LetCont ((c, v, returned, of_cont c), context.parent)
        end

  let current_cont context =
    match context.cont with
    | None -> context.parent
    | c -> c

end

(** skiping utils module *)
module Skip = struct

  (* skipping can be desactivated here *)
  let can = #<If:CPS_NOSKIP> false #<Else> true #<End>

  (* insert a skipped term properly when a context should be used *)
  let remove ilexpr (context:Context.t) =
    match ilexpr with
    | IL.Skip e ->
        begin match e with
        | Q.Ident (_, i) -> Context.apply context (IL.Value i)
        | Q.Const (_, c) -> let v = IL.fresh_v () in IL.LetVal (v, IL.Constant c, Context.apply context v)
        | _ -> let v = IL.fresh_v () in IL.LetVal (v, IL.ValueSkip e, Context.apply context v)
        end
    | _  -> ilexpr

  let remove2 c (a,e) = a, remove e c

  let is1 = function IL.Skip _ -> true | _ -> false
  let is2 = function _, IL.Skip _ -> true | _ -> false
  let is4 = function _, _, _, IL.Skip _ -> true | _ -> false

  let get = function IL.Skip qml -> qml | _ -> assert false

end

(** utily module, essentially to simplify the apply case *)
module U = struct
  (**
     check if an ident need to be changed to something else
     (e.g. wait barrier or another ident)
     note that an ident cannot be a barrier ident and
     at the same time a function with non skipped version
  *)
  let is_stable_ident env = function
    | Q.Ident (_, id)
        when not((IdentMap.mem id env.toplevel_barrier)
        || (IdentMap.mem id env.skipped_functions) )
          -> true
    | _ -> false

  let is_not_barrier_ident_or_internal_bypass penv e = match e with
    | Q.Bypass _ | Q.Directive (_, `restricted_bypass _, _, _) | Q.Directive (_, `may_cps, _, _) -> true
    | Q.Ident (_, id) -> not(IdentMap.mem id penv.toplevel_barrier)
    | _ -> false

  let get_value_il_of_ident = function
      (* cannnot be extended for constant *)
    | Q.Ident (_, id) -> IL.Value id
    | _ -> assert false

  let rec bp_get_key_and_passid bp = match bp with
    | Q.Directive (_, `may_cps, [bypass], _) -> bp_get_key_and_passid bypass
    | Q.Directive (_, `restricted_bypass pass_id, [Q.Bypass (_, key)], _) ->
        key, Some pass_id
    | Q.Bypass (_, key) -> key, None
    | _ ->
        let context = QmlError.Context.expr bp in
        QmlError.i_error None context
          "Unexpected form of bypass"

  let bp_get_key bp = fst (bp_get_key_and_passid bp)

  let bp_cps bp_cps bp =
    let rec aux bp =
      match bp with
      | Q.Directive (label, `restricted_bypass pass_id, [bp] , x) ->
          Q.Directive (label, `restricted_bypass pass_id, [aux bp] , x)
      | Q.Directive (_, `may_cps, [Q.Bypass (label, key) as bp] , _) ->
          (match bp_cps key with
           | Some key -> Q.Bypass (label, key)
           | None -> bp)
      | Q.Bypass _ -> bp
      | _ -> assert false
    in aux bp

  let is_second_order_bypass bsltags =
    bsltags.BslTags.second_order && BslTags.do_projection bsltags "cps"

  (** check if a bypass implementation (projection included) is waiting a continuation as last argument *)
  let is_cps_bp bp_tags bp =
    let bsltags = bp_tags (bp_get_key bp) in
    (is_second_order_bypass bsltags)
    || (bsltags.BslTags.cps_bypass)
    || (bsltags.BslTags.raise_)



  (** cps_apply fcps_id f_args context :
      create the IL application of the CPS function fskip_id with IL TERM arguments under the given context *)
  let cps_apply ?stack_info fcps_id f_args context =
    let args = List.map get_value_il_of_ident f_args in
    Context.insertLetCont context (fun k -> IL.ApplyNary (IL.CpsVident (IL.Value fcps_id), args, k, stack_info))

  (** bp_apply ~cont_as_arg bypass (f_args:QmlAst.expr list)
      create the IL application of the bypass with QML arguments,
      WARNING : cps=true  =>
                  bypass take a continuation as last argument
                cps=false =>
                  bypass is applied to standard arguments,
                  then the contination is used on the result of application *)
  let bp_apply ~cps bypass bp_args context =
    let key, pass_id = bp_get_key_and_passid bypass in
    let args = List.map get_value_il_of_ident bp_args in
    Context.insertLetCont context (fun k ->
        if cps
        then IL.ApplyNary(IL.CpsBypass (IL.Bypass (key, pass_id)), args, k, None)
        else IL.ApplyBypass(            IL.Bypass (key, pass_id) , args, k)
    )

  let label () = Annot.nolabel "Cps.nolabel"

  (** skipped_apply fskip_id f_args :
      create the IL application of the SKIPPED function fskip_id with QML IDENT arguments *)
  let skipped_apply ?(partial=false) fskip_id f_args =
    let e = QmlAstUtils.App.from_list (Q.Ident (label (), fskip_id) ::  f_args ) in
    let e = if partial then Q.Directive (label (), `partial_apply None, [e], []) else e in
    IL.Skip e

  (** same for bypass *)
  let skipped_bp_apply bypass bp_args = IL.Skip (QmlAstCons.UntypedExpr.apply bypass bp_args)

  (** bad_apply_property  f f_args : check that all args are idents that don't need rewriting
                                     and that f is either an non barrier ident or a bypass *)
  let good_apply_property penv f f_args =
     List.for_all (is_stable_ident penv) f_args
    && is_not_barrier_ident_or_internal_bypass penv f

  (** transform the expression so that the apply has the good property
      gives name to all element in need for cps rewriting *)
  let normalize_apply_property ?stack_info ?(partial=false) penv f f_args =
    let f_and_args = f::f_args in
    let rec fold ?(head_is_f=false) f_and_args (bindings, ids) =
      let s_fold e l= fold l (bindings, (e :: ids)) in
      match f_and_args with
      (* keep already named *)
      (* 1 eventually the function *)
      | (Q.Bypass _ | Q.Directive (_, `restricted_bypass _, _, _) as e) :: l
          when head_is_f        -> s_fold e l
      (* 2 function and args *)
      | (Q.Ident _ as e) :: l
          when is_stable_ident penv e
          || (head_is_f && is_not_barrier_ident_or_internal_bypass penv f)
          -> s_fold e l
      (* name all others *)
      | e :: l ->
          let id = Ident.next "arg" in
          fold l (((id, e) :: bindings), Q.Ident (label (), id) :: ids)
      (* create the letin if needed *)
      | [] when bindings = [] -> assert false
      | [] ->
          let app = QmlAstUtils.App.from_list (List.rev ids) in
          let app =
            match stack_info with
            | None -> app
            | Some info -> Q.Directive (label (), `cps_stack_apply info, [app], []) in
          let app =
            if partial then Q.Directive (label (), `partial_apply None, [app], [])
            else app in
          Q.LetIn (label (), bindings, app)
    in fold ~head_is_f:true f_and_args ([],[])

  let rewrite_apply_partial context f_id f_args =
    let e = IL.Skip (QC.apply (QC.ident f_id) f_args) in
    if Skip.can then e
    else Skip.remove e context

  let rewrite_apply ?stack_info ?(partial=false) ~private_env ~expr ~context f_id f_args =
    match private_env_get_skipped_fun f_id private_env with
    | Some(real_arity, fskip_id, fcps_id) ->
        if partial then
          (* skipped version exists but incomplete call *)
          skipped_apply ~partial fcps_id f_args
        else (
          (* skipped version exists, complete call *)
          if List.length f_args <> real_arity then (
            Format.printf "Partial apply (expected %d args, get %d) in CpsRewriter :@\n%a@."
              real_arity (List.length f_args) QmlPrint.pp#expr expr;
            assert false
          );
          skipped_apply ~partial fskip_id f_args
        )
    | None ->
        (* skipped version don t exist *)
        if partial then
          skipped_apply ~partial f_id f_args
        else
          cps_apply ?stack_info f_id f_args context

  let is_const e =
    match e with
    | Q.Const _ -> true
    | _ -> false

  let good_llarray_property_elt penv arg =
    is_stable_ident penv arg
    || is_const arg

  let good_llarray_property penv args =
    List.for_all (good_llarray_property_elt penv) args

  let normalize_llarray_property penv args =
    let foldmap bindings expr =
      if good_llarray_property_elt penv expr
      then
        bindings, expr
      else
        (* name all others *)
        let id = Ident.next "arg" in
        let binding = id, expr in
        let bindings = binding :: bindings in
        let expr = Q.Ident (label (), id) in
        bindings, expr
    in
    let bindings, args = List.fold_left_map foldmap [] args in
    let llarray = Q.Directive (label (), `llarray, args, []) in
    assert (bindings <> []) ;
    Q.LetIn (label (), bindings, llarray)
end


(** The code_elt is there only for Error context *)
(* Convert a QML expression to a CPS term.*)
let il_of_qml ?(can_skip_toplvl=false) (env:env) (private_env:private_env) (expr:QmlAst.expr)  =
  (* Records
     <!> beware, this function is partial, it is defined only on complex records, and lazy records.
     the skip option specify if we accept to use and propagate skip nodes and provide the
     constructor for its content *)
  let rec aux_record ?skip fields (context:Context.t) create_record =
    let il_fields, build_fields =
      let fold (il_fields, build) (f, expr) =
        let c = IL.fresh_c () in
        let v = IL.fresh_v () in
        ((IL.Field f, v, (Q.QAnnot.expr expr))::il_fields),
        ((f, c, v, (aux_can_skip expr (Context.cont context c)))::build) in
      List.fold_left fold ([], []) fields in

    (* do you accept Skip to return node ? *)
    let can_skip = Skip.can && skip <> None in

    (* do we accept to propagate skip nodes from fields ? *)
    let all_skip =
      can_skip
      && List.for_all Skip.is4 build_fields
    in

    if all_skip then (* Skipping *) (Option.get skip) fields build_fields
    else
      let il_record =
        let v = IL.fresh_v () in
        IL.LetVal (v, create_record (List.rev il_fields),
                   Context.apply context v)
      in
      let parent = Context.current_cont context in
      let fold il_term (_, c, v, field_term) =
        let field_term = Skip.remove field_term (Context.cont context c) in
        IL.LetCont ((c, v, il_term, field_term), parent)
          in
      List.fold_left fold il_record build_fields

  and aux_lambda ?(can_skip_lambda=false) context label args e =
    let k = IL.fresh_c () in
    let args = List.map (fun id -> IL.Value id) args in
    let cont_e =  (Context.cont context k) in
    let e = aux_can_skip e cont_e in
    (match e with
     | IL.Skip e when can_skip_lambda ->
         (* skip transformations must not be lost -> do not return IL.Skip expr *)
         `skip (QmlAstCons.UntypedExprWithLabel.lambda ~label (List.map (function IL.Value x -> x) args) e)
     | (* include Skipped and non Skipped *)_ ->
         begin
           `letfun (args, k, Skip.remove e cont_e)
         end)


  (* this version of 'aux' is allowed to return 'Skip' node,
     you should only call it if you know how to handle them properly.
     Currently, only const, ident and record case can give 'Skip' node
     Only record case is recursively calling 'aux_can_skip'.
     All other calls are on the standard 'aux' (see after)
  *)
  and aux_can_skip ?(can_skip_lambda=false) expr (context:Context.t) =
    match expr with

    | Q.Const _ when Skip.can -> IL.Skip expr

    | Q.Const (_, c) ->
        let x = IL.fresh_v () in
        IL.LetVal (x, IL.Constant c, Context.apply context x)

    | Q.Ident (label, x) ->
        begin
          match IdentMap.find_opt x private_env.toplevel_barrier with
          | Some barrier ->
            (* if option --cps-toplevel-concurrency is set,
               this ident may be unbound, and we have just a barrier instead *)
              let func k = IL.ApplyNary (IL.CpsBypass (il_bycps_call "wait"), [IL.Value barrier], k, None) in
              Context.insertLetCont context func
          | None when not(Skip.can) ->  Context.apply context (IL.Value x)
          | None ->
              match IdentMap.find_opt x private_env.skipped_functions with
              | Some (_, _, fcps_id) -> IL.Skip (Q.Ident (label, fcps_id))
              | None                 -> IL.Skip expr
        end

    | Q.LetIn (label, l, e) ->
        begin
          let item name value sub_expr =
            let value_il =
              match value with
              | Q.Lambda (label,params,body) -> (
                  match aux_lambda context label params body with
                  | `skip _ -> assert false
                  | `letfun _ as e -> e
                )
              | _ ->
                  let c = IL.fresh_c () in
                  let context_for_value = Context.cont context c in
                  let value_il = aux_can_skip value context_for_value in
                  `letcont (c,context_for_value,value_il) in
            let sub_expr_il  = aux_can_skip sub_expr context  in
            match value_il with
            | `letcont (_, _, value_il) when Skip.is1 sub_expr_il && Skip.is1 value_il ->
              begin
                (* old skip changes (fun_skipped ...) must not be removed *)
                let value = Skip.get value_il in
                let sub_expr =  Skip.get sub_expr_il in
                IL.Skip (QmlAstCons.UntypedExprWithLabel.letin ~label [(name, value)] sub_expr)
              end
            | `letcont (c, context_for_value, value_il) ->
                let parent = Context.current_cont context in
                IL.LetCont ((c, (IL.Value name), Skip.remove sub_expr_il context,
                             Skip.remove value_il context_for_value), parent)
            | `letfun (args,k,body) ->
                IL.LetFun ([IL.Value name,args,k,body], Skip.remove sub_expr_il context)
          in
          match l with
          | [] -> aux_can_skip e context
          | [(name, value)] -> item name value e
          | (name, value)::t -> item name value (Q.LetIn (label, t, e))
        end

    | Q.LetRecIn (_, defs, e) ->
        let items = List.map
          (fun (name, def) ->
             match def with
             | Q.Lambda (_, params, body) ->
                 let params = List.map (fun id -> IL.Value id) params in
                 let k = IL.fresh_c () in
                 (IL.Value name, params, k, aux body (Context.cont context k))
             | _ -> error "Recursive definition of a non-function"
          ) defs
        in
        IL.LetRecFun (items, aux e context)

    | Q.Lambda (label, args, e) -> (
        match aux_lambda ~can_skip_lambda context label args e with
        | `skip e -> IL.Skip e
        | `letfun (args,k,body) ->
            let anonymous = IL.fresh_fun () in
            IL.LetFun([anonymous, args, k, body], Context.apply context anonymous)
      )

    (* Special case for stack traces *)
    | Q.Directive (_, `cps_stack_lambda cont_opt_ref, e_opt,_) ->
        (* this directive does not modifying the rewriting of the expression in any way
         * it just records the current continuation in the reference *)
        (cont_opt_ref : Obj.t option ref) := Obj.magic (Context.current_cont context : IL.cident option);
        let e = List.get_only_element e_opt in
        aux_can_skip e context

    (* Special case of Apply node for stack traces *)
    | Q.Directive (_, `cps_stack_apply ((cont_opt_ref_opt,name,position) as stack_info), [Q.Apply (_, f, f_args)], _) -> (
        if not (U.good_apply_property private_env f f_args) then
          aux_can_skip (U.normalize_apply_property ~stack_info private_env f f_args) context
        else
          (* the only difference with the usual apply case is that the case
           * bypass never occurs here (because `cps_stack_apply is never put
           * on a bypass) *)
          let cont : IL.cident option =
            match cont_opt_ref_opt with
            | None -> None
            | Some x -> Some (Obj.obj (Option.get !x)) in
          match f with
          | Q.Ident (_, f_id) ->
              let stack_info =
                {IL.caller_cont = cont;
                 IL.callee_name = name;
                 IL.position = position} in
              U.rewrite_apply ~stack_info ~private_env ~expr ~context f_id f_args
          | _ ->
              OManager.printf "unexpected expr for cps trace@\n" ;
              OManager.printf "expr: %a@." QmlPrint.pp#expr expr ;
              assert false
      )

    (* BEGIN OF APPLY NODE *)
    (* normalisation of apply node
       to guaranty property : f is a non barrier ident or a bypass, f_args are stable identifiers *)
    | Q.Apply (_, f, f_args) when not(U.good_apply_property private_env f f_args) ->
        aux_can_skip (U.normalize_apply_property private_env f f_args) context
    | Q.Directive (_, `partial_apply _, [Q.Apply (_, f, f_args)], _) when not(U.good_apply_property private_env f f_args) ->
        aux_can_skip (U.normalize_apply_property private_env ~partial:true f f_args) context

    (* guaranteed property : f is a non barrier ident, f_args are stable identifiers *)
    | Q.Apply (_, Q.Ident (_, f_id), f_args) ->
        U.rewrite_apply ~private_env ~expr ~context f_id f_args
    | Q.Directive (_, `partial_apply _, [Q.Apply (_, Q.Ident (_, f_id), f_args)], _) ->
        U.rewrite_apply ~partial:true ~private_env ~expr ~context f_id f_args

    (* guaranteed property : f is a bypass, f_args are stable identifiers *)
    | Q.Apply (_, bypass, bp_args) ->
        let bypass = U.bp_cps env.bsl_bypass_cps bypass in
        let cps = U.is_cps_bp env.bsl_bypass_tags bypass in
        if cps || not(Skip.can)
        then U.bp_apply ~cps bypass bp_args context
        else U.skipped_bp_apply bypass bp_args

    (* END OF APPLY NODE *)

    | Q.Match (label, e, cases) ->
        let cases =
          let map (pat, epat) = (pat, aux_can_skip epat context) in
          List.map map cases in
        let all_cases_are_skipped = List.for_all Skip.is2 cases in
        let c = IL.fresh_c () in
        let context_for_e = Context.cont context c in
        begin match aux_can_skip e context_for_e with
        | IL.Skip e when all_cases_are_skipped && Skip.can ->
            let map (pat, epat) = (pat, Skip.get epat) in
            IL.Skip (QmlAstCons.UntypedExprWithLabel.match_ ~label e (List.map map cases))
        | e ->
            let cases = List.map (Skip.remove2 context) cases in
            let e = Skip.remove e context_for_e in
            let v = IL.fresh_v () in
            let parent = Context.current_cont context in
            IL.LetCont((c,v,
                        IL.Match (v, cases),
                        e ), parent)
        end

    | Q.Record (label, fields) ->
        let skip _ builded =
          let map (f, _, _, term) = (f, Skip.get term) in
          IL.Skip (QmlAstCons.UntypedExprWithLabel.record ~label (List.map map builded))
        in
        aux_record ~skip:skip fields context (fun fields -> IL.Record fields)

    | Q.Directive (_, `create_lazy_record, exprs, _) -> (
        let expr, info = QmlDirectives.create_lazy_record_arguments exprs in
        (* <!> beware there : the info has type 'a in QmlFlatServerLib *)
        match expr with
        | Q.Record (_, fields) -> (
            match info with
            | Some info ->
                let v = IL.fresh_v () and c = IL.fresh_c () in
                let parent = Context.current_cont context in
                IL.LetCont((c, v,
                            (let create_record fields = IL.LazyRecord (fields, Some v) in
                             aux_record fields context create_record),
                            aux info (Context.cont context c)
                           ), parent)
            | None ->
                let create_record fields = IL.LazyRecord (fields, None) in
                aux_record fields context create_record
          )
        | _ -> assert false
      )

    | Q.Dot (label, e, s) ->
        let c = IL.fresh_c () in
        let context_for_e = Context.cont context c in
        begin match aux_can_skip e context_for_e with
          | IL.Skip e when Skip.can ->
              IL.Skip (QmlAstCons.UntypedExprWithLabel.dot ~label e s)
          | e ->
              let e = Skip.remove e context_for_e in
              let v = IL.fresh_v () in
              let p = IL.fresh_v () in
              let parent = Context.current_cont context in
              IL.LetCont((c, v,
                          IL.LetProj (p, (v, IL.Field s), Context.apply context p),
                          e), parent)
        end

    | Q.ExtendRecord _ ->

        let il_fields, build_fields, rest =
          let rec fold ((il_fields, build, seen) as acc) expr =
            match expr with
            | Q.Coerce (_, e, _) -> fold acc e
            | Q.ExtendRecord (_, f, expr, e) ->
                let acc =
                  if StringSet.mem f seen
                  then
                    (* This field has been added once already.
                       Drop the second extension or it would break [extend_with_array] *)
                    acc
                  else
                    let c = IL.fresh_c () in
                    let v = IL.fresh_v () in
                    (
                      ((IL.Field f, v)::il_fields),
                      ((c, v, (aux expr (Context.cont context c)))::build),
                      (StringSet.add f seen)
                    )
                in
                fold acc e
            | _ -> il_fields, build, expr
          in fold ([], [], StringSet.empty) expr
        in

        let record = IL.fresh_v () in
        let il_extend_record =
          let v = IL.fresh_v () in
          IL.LetVal (v, IL.ExtendRecord ((List.rev il_fields), record), Context.apply context v) in

        let parent = Context.current_cont context in

        let il_term =
          let c = IL.fresh_c () in
          IL.LetCont((c, record, il_extend_record, aux rest (Context.cont context c)), parent) in

        let fold il_term (c, v, term) = IL.LetCont((c, v, il_term, term), parent) in
        List.fold_left fold il_term build_fields

    | Q.Bypass _
    | Q.Directive (_, `restricted_bypass _, [Q.Bypass _], _) -> (
        (* if we end up here, it means QmlBypassHoisting wasn't called, or that someone
         * introduced other bypasses in the meantime
         * In any case, we eta expand them ourselves
         *)
        match expand_bypass env expr with
        | None -> (
            match expr with
            | Q.Directive (_, `restricted_bypass pass, [Q.Bypass (_, key)], _) ->
                (* value bypass *)
                let v = IL.fresh_v () in
                IL.LetVal (v, IL.BasicBypass (IL.Bypass(key, Some pass)), Context.apply context v)
            | Q.Bypass (_, key) ->
                (* value bypass *)
                let v = IL.fresh_v () in
                IL.LetVal (v, IL.BasicBypass (IL.Bypass(key, None)), Context.apply context v)
            | _ -> assert false (* not matched by the outer pattern *)
          )
        | Some e ->
            aux_can_skip ~can_skip_lambda e context
      )

    | Q.Coerce (_, e, _) -> aux_can_skip ~can_skip_lambda e context

    | Q.Path (_, _, _) ->
        failwith "Internal error: At this stage, all first-class paths should have been compiled."

    (* Concurrency-specific directive, and cps specific *)

    | Q.Directive (_, `spawn, expr, _) ->
        begin
          match expr with
          | [expr] ->
              (* TODO there : restriction for Record only *)
              let name = IL.fresh_v () in
              let v = IL.fresh_v () in (* v is of type unit, ignored by the function *)
              let k = IL.fresh_c () in
              let expr = aux expr (Context.cont context k) in
              let defs = [(name, [v], k, expr)] in
              let func c =
                let term = IL.ApplyBypass (il_bycps_call "spawn", [name], c) in
                IL.LetFun (defs, term)
              in
              Context.insertLetCont context func
          | _ -> assert false (* cannot be parsed *)
        end

    (* TODO: when the basic version passes the [fact_spawn*.qml] tests,
       remove [@wait] and instead process concurrency as we do
       with lazy records: perform @wait implicitely at dot access. *)
    | Q.Directive (_, `wait, expr, _) ->
        begin
          match expr with
          | [expr] ->
              (*We use the result of [future] and [context]
                to build the task which will be set up to*)
              let c1 = IL.fresh_c () in
              let future = IL.fresh_v () in
              let parent = Context.current_cont context in
              IL.LetCont((c1 , future,
                          (let func k = IL.ApplyNary (IL.CpsBypass (il_bycps_call "wait"), [future], k, None) in
                           Context.insertLetCont context func),
                          aux expr (Context.cont context c1)), parent)

          | _ -> assert false (* cannot be parsed *)
        end

    | Q.Directive (_, `atomic, exprs, tys) ->
        let expr = List.get_only_element exprs in
        let expr = aux expr context in
        IL.Directive (`atomic, [expr], tys)

    | Q.Directive (_, `callcc, [expr], _) ->
        let c = IL.fresh_c () and f_callcc = IL.fresh_v () in
        let parent = Context.current_cont context in
        IL.LetCont ((c, f_callcc,
                     (let func k = IL.ApplyNary (IL.CpsBypass (il_bycps_call "callcc_directive"), [f_callcc], k, None) in
                      Context.insertLetCont context func),
                     aux expr (Context.cont context c)
                    ), parent)

    | Q.Directive (_, `immovable, _, _) ->
        failwith "Internal error: CPS Directive @immovable is not yet implemented"
          (* in particular : see if this directive should be removed by this pass,
             or preserved (or transformed?) for a specific back-end directive *)

    | Q.Directive (_, `assert_, [e], _) ->
        if env.options.no_assert
        then aux (QC.unit ()) context
        else
          let bool_result = IL.fresh_v () in
          let assertion =
            let message_value =
              let message = string_of_pos (Q.Pos.expr expr) in
              IL.Constant (Q.String message) in
            let message = IL.fresh_v () in
            let bypass =
              (* FIXME: use opacapi *)
              "bslpervasives.assertion"
            in
            let term c =
              IL.LetVal (message, message_value,
                         IL.ApplyBypass (il_other_call bypass, [bool_result; message], c)) in
            Context.insertLetCont context term
          in
          let c = IL.fresh_c () in
          let parent = Context.current_cont context in
          IL.LetCont((c, bool_result, assertion, aux e (Context.cont context c)), parent)

    | Q.Directive (_, `fail, args, _) -> (
        (*
          FIXME: skip in case of no message, or if the message is a static string
        *)
        let fail_cps = Opacapi.Opabsl.BslPervasives.fail_cps in
        let position_value =
          let pos = string_of_pos (Q.Pos.expr expr) in
          IL.Constant (Q.String pos)
        in
        let position = IL.fresh_v () in
        let message = IL.fresh_v () in
        let body =
          let term k =
            IL.LetVal (position, position_value,
                       IL.ApplyNary (IL.CpsBypass (il_bypass fail_cps), [message ; position], k, None))
          in
          Context.insertLetCont context term
        in
        match args with
        | [] ->
            let message_value =
              let mes = "" in
              IL.Constant (Q.String mes)
            in
            IL.LetVal (message, message_value, body)
        | e :: _ -> (
            match e with
            | Q.Const (_, ((Q.String _) as literal)) ->
                IL.LetVal (message, IL.Constant literal, body)
            | _ ->
                let c = IL.fresh_c () in
                let parent = Context.current_cont context in
                IL.LetCont((c, message, body, aux e (Context.cont context c)), parent)
          )
      )

    | Q.Directive (_, `module_, [expr], _) -> aux_can_skip ~can_skip_lambda expr context

    | Q.Directive (_, `thread_context, _, _) ->
        let term ((IL.Continuation id) as c) =
          IL.ApplyBypass (il_bycps_call "thread_context", [ IL.Value id ], c)
        in
        Context.insertLetCont context term

    | Q.Directive (_, `with_thread_context, arguments, _) ->
        let thread_context, alpha =
          match arguments with
          | [ fst ; snd ] -> fst, snd
          | _ -> failwith "Internal error: @with_thread_context is not used 2 arguments"
        in
        let c1 = IL.fresh_c () and c2 = IL.fresh_c () and thread_context_id = IL.fresh_v () in
        let (IL.Continuation thread_context_continuation) as c3 = IL.fresh_c () in
        let v3 = IL.Value thread_context_continuation in
        let term ((IL.Continuation ctop) as parent) =
          let parent = Some parent in
          IL.LetCont((c1, thread_context_id,
                      IL.LetCont((c2, v3, aux alpha (Context.cont context c3),
                                  IL.ApplyBypass ((il_bycps_call "with_thread_context"), [ thread_context_id ; IL.Value ctop ], c2)
                                 ), parent),
                      (aux thread_context (Context.cont context c1))
                     ), parent)
        in
        Context.insertLetCont context term

    | Q.Directive (_, `throw, [exc], _) ->
        let c = IL.fresh_c () and v_exc = IL.fresh_v () in
        let c2 = IL.fresh_c () and v_handler = IL.fresh_v () in
        let cont_of_val (IL.Value id) = IL.Continuation id in
        Context.insertLetCont context
          (fun ((IL.Continuation ctop) as parent) ->
             IL.LetCont
               ((c, v_exc,
                 IL.LetCont
                   ((c2, v_handler, IL.ApplyCont(cont_of_val v_handler, v_exc),
                     IL.ApplyBypass (il_bycps_call "handler_cont", [ IL.Value ctop ], c2)),
                    Some parent),
                 aux exc (Context.cont context c)),
               Some parent))

    | Q.Directive (_, `catch, [handler ; expr], _) -> ( (* similar to with_thread_context *)
        let (IL.Continuation c1_name) as c1 = IL.fresh_c () in
        let c2 = IL.fresh_c () in
        let (IL.Continuation handler_continuation) as c3 = IL.fresh_c () in
        let v3 = IL.Value handler_continuation in
        let handler = aux handler (Context.cont context c1) in
        let catch_bypass =
          let catch =
            if env.options.server_side && env.options.qml_closure
            then "catch" else "catch_native" in
          il_bycps_call catch
        in
        let catch ((IL.Continuation ctop) as parent) handler_id =
          IL.LetCont
            ((c2, v3, aux expr (Context.cont context c3),
              IL.ApplyBypass (catch_bypass, [ handler_id ; IL.Value ctop ], c2)
             ), Some parent)
        in
        (* code simplification for common cases, handler beeing a lambda *)
        match handler with
        | IL.LetFun ([(IL.Value handler_name) as handler_id, _, _, _] as list,
                     IL.ApplyCont (IL.Continuation if_c1_name, IL.Value if_handler_name))
            when Ident.equal c1_name if_c1_name && Ident.equal handler_name if_handler_name
              ->
            let term parent =
              IL.LetFun (list, catch parent handler_id)
            in
            Context.insertLetCont context term
        | _ ->
            let handler_id = IL.fresh_v () in
            let term parent =
              IL.LetCont((c1, handler_id,
                          catch parent handler_id,
                          handler
                         ), Some parent)
            in
            Context.insertLetCont context term
      )

    | Q.Directive (_, `llarray, args, _) when not (U.good_llarray_property private_env args) ->
        aux_can_skip (U.normalize_llarray_property private_env args) context

    | Q.Directive (_, `llarray, _, _) -> IL.Skip expr

    | Q.Directive (_, `throw, _, _) ->
        failwith "Internal error: directive @throw should have 1 argument"
    | Q.Directive (_, `catch, _, _) ->
        failwith "Internal error: directive @catch should have 2 arguments"

    | Q.Directive (_, `asynchronous_toplevel, _, _) ->
        failwith "Internal error: presence of @asynchronous directive in an expression"

    | Q.Directive (_, `partial_apply _, _, _) -> assert false

    (* other directive : no specific tratement done in the cps *)
    | Q.Directive (_, directive, exprs, tys) ->
        let terms = List.map (fun expr -> aux expr context) exprs in
        IL.Directive (directive, terms, tys)
  (**
     This version of aux is not allowed to return Skip node,
     it is the standard function you should call unless you 100% certain
     of doing mixed cps/noncps code (e.g. Skip nodes)
  *)
  and aux expr (context:Context.t) = Skip.remove (aux_can_skip expr context) context
  in
  let term =
    if can_skip_toplvl then
      aux_can_skip ~can_skip_lambda:true expr (Context.start ~parent:None)
    else
      aux expr (Context.start ~parent:None) in
  private_env, term

let chrono_factorize_letcont = Chrono.make ()

(* OPTIMISATION IN IL *)
let il_simplification (env:env) (private_env:private_env) (term:IL.term) =
  let _ = env in
  let _ = #<If:CPS_VERBOSE $minlevel DebugLevel.il_opt_timer> Chrono.start chrono_factorize_letcont #<End> in
  let term = #<If:CPS_KEEP_LETCONT> term #<Else> Factorize.letcont term #<End> in
  let _ = #<If:CPS_VERBOSE $minlevel DebugLevel.il_opt_timer> Chrono.stop chrono_factorize_letcont #<End> in
  private_env, term

(* Convert an IL value to a qml expression.*)
let qml_of_il_value = function
  | IL.Constant e -> QC.const e

  | IL.Record fields ->
      let fields = List.map (fun (IL.Field s, IL.Value v, _) -> s, (QC.ident v)) fields in
      QC.record fields

  | IL.ExtendRecord (fields, IL.Value v) ->
      let fold (IL.Field s, IL.Value v) acc = QC.extendrecord s (QC.ident v) acc in
      List.fold_right fold fields (QC.ident v)

  | IL.LazyRecord (fields, info) ->
      let info = Option.map (fun (IL.Value info) -> QC.ident info) info in
      let fields = List.map (fun (IL.Field s, IL.Value v, _) -> s, (QC.ident v)) fields in
      let record = QC.record fields in
      let exprs = QmlDirectives.create_lazy_record_exprs record info in
      QC.directive `create_lazy_record exprs []

  | IL.BasicBypass (IL.Bypass (key, restriction)) -> (
      match restriction with
      | None -> QC.bypass key
      | Some pass -> QC.restricted_bypass ~pass key
    )

  | IL.ValueSkip e -> e

(* Convert an IL term to a qml expression.*)

(* TODO in IL :
   + add there a few directives to distinghish from normal QmlAst constructions
   + static type everything possible, dont loose annots (optimal branching with qmlflat...)
*)

let runtime_bt_collection bt_pos _f_string _larg expr =
  let bt_info =
    #<If:CPS_DEBUG $minlevel DebugLevel.full_backtrace>
      let fun_args2string = qml_other_call "fun_args2string" in
      let _larg = List.map (fun arg ->
        QC.apply (qml_byobj_magic ()) [QC.ident arg]) _larg
      in
      let _larg = List.hd _larg in (* TODO: tmp hack; libbsl does not translate lists *)
      QC.apply fun_args2string [QC.string _f_string; (*QC.list*) _larg]
        #<Else>
        QC.string bt_pos
        #<End>
  in
  let bt_add = qml_other_call "bt_add" in
  QC.letin [Ident.next "_", (QC.apply bt_add [bt_info])]
    expr

let runtime_debug minlevel message expr =
  let pr = qml_other_call "debug" in
  QC.letin [ Ident.next "_", (QC.apply pr [ QC.int minlevel ; QC.string message ]) ]
    expr

let apply_cont_tracer =
  let r = ref 0 in
  (fun k expr ->
    incr r;
    let k_string = Ident.stident k in
    let message = Printf.sprintf "+ ap cont %s : #%d#" k_string (!r) in
    runtime_debug DebugLevel.cont_tracer message expr
  )

let apply_fun_tracer f larg expr =
  let f_string = Ident.stident f in
  let backtrace_pos = f_string(*TODO: replace by position*) in
  runtime_bt_collection backtrace_pos f_string larg expr

let qml_bypass_of_il_bypass = function
  | IL.Bypass (key, None) -> QC.bypass key
  | IL.Bypass (key, Some pass) -> QC.restricted_bypass ~pass key

let qml_function_of_cps_function = function
  | IL.CpsVident (IL.Value a) -> QC.ident a
  | IL.CpsBypass il_bypass -> qml_bypass_of_il_bypass il_bypass

let qml_of_il ~toplevel_cont (env:_) (private_env:private_env) (term:IL.term) =
  let atomic = ref false in
  let toplevel_done = ref false in
  let rec aux = function
    | IL.LetVal (IL.Value x, v, term) ->
        let value = qml_of_il_value v in
        QC.letin [x, value] (aux term)

    | IL.LetProj (IL.Value x, (IL.Value record, IL.Field field), term) ->
       QC.letin [x, QC.dot (QC.ident record) field] (aux term)

    | IL.LetCont ((IL.Continuation k, IL.Value id, t, u), parent) ->
        let body =
          let fun_body = aux t in
          let fun_body =
            #<If:CPS_DEBUG>
              apply_cont_tracer k fun_body
            #<Else>
              fun_body
            #<End>
          in
          let lambda = QC.lambda [id] fun_body in
          match parent with
          | None ->
             let make_continuation =
               qml_bycps_call
                 (if env.options.server_side && env.options.qml_closure
                  then "cont" else "cont_native") in
              QC.apply make_continuation [lambda]
          | Some (IL.Continuation parent) ->
              let make_continuation =
                qml_bycps_call
                  (if env.options.server_side && env.options.qml_closure
                   then "ccont" else "ccont_native") in
              QC.apply make_continuation [ QC.ident parent ; lambda ]
        in
        QC.letin [k, body] (aux u)

    | IL.LetRecFun (defs, e) ->
        let defs =
          let map (IL.Value id, args, IL.Continuation k, body) =
            let body = aux body in
            let args = List.rev_map (fun (IL.Value v) -> v) args in
            let args = List.rev (k::args) in
            id, QC.lambda args body in
          List.map map defs in
        QC.letrecin defs (aux e)

    | IL.LetFun (defs, e) ->
        let defs =
          let map (IL.Value id, args, IL.Continuation k, body) =
            let body = aux body in
            let args = List.rev_map (fun (IL.Value v) -> v) args in
            let args = List.rev (k::args) in
            id, QC.lambda args body in
          List.map map defs in
        QC.letin defs (aux e)

    | IL.ApplyCont (IL.Continuation k, IL.Value v) ->
        let cpsreturn = qml_bycps_call "return" in
        QC.apply cpsreturn [ QC.ident k ; QC.ident v ]

    | IL.ApplyExpr (cps_function, IL.Value b, IL.Continuation k) ->
        let cps_function =
          match cps_function with
          | IL.CpsVident (IL.Value a) ->
              let magic_a = QC.ident a in
              let magic_a =
                  if env.options.server_side && (not (env.options.qml_closure))
                  then qml_group_app (QC.apply (qml_bycps_call "magic_func") [magic_a])
                  else magic_a
              in
              #<If:CPS_DEBUG>
                apply_fun_tracer a [b] magic_a
                #<Else>
                magic_a
                #<End>
          | IL.CpsBypass il_bypass -> qml_bypass_of_il_bypass il_bypass
        in
        (* if !atomic *)
        (* then *)
          QC.apply cps_function [ QC.ident b ; QC.ident k ]
        (* else *)
        (*   let cpsapply = qml_bycps_call "apply" in *)
        (*   QC.apply cpsapply [ cps_function ; QC.ident b ; QC.ident k ] *)

    | IL.ApplyNary (cps_function as id, args, IL.Continuation k, stack_infos_opt) ->
        let cps_function = qml_function_of_cps_function cps_function in
        let cps_function =
          if env.options.server_side && (not env.options.qml_closure) then
            (* FIXME: could call specialized magic_funcN to keep
             * some type errors in the backend *)
            #<If:QMLC_NO_MAGIC>
              cps_function
            #<Else>
              let magic =
            (* let arity = List.length args in
               let bypass =
                 if arity <= 5 then "magic_func" ^ string_of_int arity
                 else "magic_func_more" in
               qml_bycps_call bypass *) qml_byobj_magic () in
              QC.apply magic [cps_function]
            #<End>
          else
            cps_function
        in
        let cps_function =
          match id with
          | IL.CpsVident (IL.Value _a) ->
              #<If:CPS_DEBUG>
                let args = List.map (fun (IL.Value id) -> id) args in
                apply_fun_tracer _a args cps_function
                #<Else>
                cps_function
                #<End>
          | _ -> cps_function
        in
        let rev_args = List.rev_map (fun (IL.Value id) -> QC.ident id) args in
        let k =
          match stack_infos_opt with
          | None -> QC.ident k
          | Some {IL.caller_cont = caller_cont_opt; IL.callee_name = name_opt; IL.position = position_opt} ->
              let caller_cont =
                match caller_cont_opt with
                | None -> QC.record ["none", QC.unit ()]
                | Some (IL.Continuation caller_cont) -> QC.record ["some", QC.ident caller_cont] in
              let name = Option.default "anon fun" name_opt in
              let position = Option.default "no pos" position_opt in
              let args = #<If:CPS_STACK_TRACE$contains "arg"> List.rev rev_args #<Else> [] #<End> in
              QC.apply
                (QC.bypass (BslKey.normalize "bslcps_update_cont"))
                [QC.ident k; caller_cont; QC.string name; QC.string position; QC.opa_tuple args] in
        let apply = QC.apply cps_function (List.rev (k :: rev_args)) in
        (* if !atomic *)
        (* then  *)
          apply
        (* else *)
        (*   let fct = QC.lambda (Ident.next "_") apply in *)
        (*   let cpsapply0 = qml_bycps_call "apply0" in *)
        (*   QC.apply cpsapply [ fct ; QC.ident k ] *)

    | IL.ApplyBypass (il_bypass, args, IL.Continuation k) ->
        let qml_bypass = qml_bypass_of_il_bypass il_bypass in
        let bypass_result = QC.apply qml_bypass (List.map (function (IL.Value x) -> QC.ident x) args) in
        let v = Ident.next "bypass_result" in
        let cpsreturn = qml_bycps_call "return" in
        QC.letin [v, bypass_result]
          (QC.apply cpsreturn [ QC.ident k ; QC.ident v ])

    | IL.Match (IL.Value v, pat_terms) ->
        let pat_terms =
          let map (pat, term) = (pat, aux term) in
          List.map map pat_terms in
        QC.match_ (QC.ident v) pat_terms

    | IL.Done (IL.Value v, _) -> toplevel_done := true ; toplevel_cont v

    | IL.Directive (`spawn, _, _)
    | IL.Directive (`wait , _, _)
      -> assert false (* removed by qml -> IL *)

    | IL.Directive (`atomic, terms, _) ->
        let term = List.get_only_element terms in
        let _ = atomic := true in
        aux term

    | IL.Directive (`immovable, _, _) -> assert false (* cf remark in qml -> IL *)

    | IL.Directive (`create_lazy_record, _, _) -> assert false (* expressed as const after qml -> IL *)

    | IL.Directive (`module_, _, _) -> assert false (* removed by qml -> IL *)

    | IL.Directive (`restricted_bypass _, _, _) -> assert false (* rewrited in a expanded_bypass after qml -> IL or removed by hoisting *)

    | IL.Directive (`asynchronous_toplevel, _, _) ->
        (* at toplevel only, checked by qml -> IL *)
        assert false

    (* other directive : no specific treatment done in the cps *)
    | IL.Directive (directive, terms, tys) ->
        let exprs = List.map aux terms in
        QC.directive directive exprs tys

    | IL.Skip qml -> qml

  in
  let qml = aux term in
  (* if not (!toplevel_done) then assert false else  *)
  private_env, qml



(*
val code_elt : t -> QmlAst.code_elt -> t * QmlAst.code
val code : t -> QmlAst.code -> t * QmlAst.code
*)

(*
   Notes about this top-level transformation

   - db stuff + new types are ignored and not returned by this transformation
   - toplevel values becomes barrier

val t = expr

-->

val t_b = make_barrier ()
val _ =
   << expr >>_cont{ v -> release_barrier t_b v}

the access to t in the rest of the code is transformed by :
{ wait cont t_b }

in case of a re-binding :

val y = t

if t is a top level barrier, we replace y by the call to wait t in the rest of the code.
value y is removed from the code.

to avoid nightmare of type error, segfault, etc.. val t is no more defined at top level.
so, if any probleme appear during the construction, we'll get a : unbound value error.

*)

(** facility to manipulate barriers *)
module Barrier :
sig
  val make : Ident.t -> QmlAst.expr
  val release : barrier_id:Ident.t -> value:Ident.t -> QmlAst.expr
  val blocking_wait : Ident.t -> QmlAst.expr

  (**
     A bypass for setting by side-effect to QmlCpsServerLib global properties.
     This should by used before a the execution of the continuation releasing a barrier.
  *)
  val before_wait : unit -> QmlAst.expr

  (**
     Special case for synchronous toplevel.
     Make sence only before the lanch of the server.
     The scheduler [loop_until] the barrier was released.
  *)
  val toplevel_wait : Ident.t -> QmlAst.expr
end =
struct

  let black_if_magic fct_name =
    #<If:QMLC_NO_MAGIC>
      fct_name
    #<Else>
      "black_"^fct_name
    #<End>

  let make _ident =
    let cpsbarrier =
      let fct_name = black_if_magic "make_barrier" in
      qml_bycps_call fct_name in
    let barrier = QC.apply cpsbarrier [ QC.string (Ident.to_string _ident) ] in
    let barrier =
      #<If:CPS_DEBUG>
        runtime_debug DebugLevel.make_barrier
        (Printf.sprintf "make_barrier : %s" (Ident.to_string _ident))
        barrier
      #<Else>
        barrier
      #<End>
    in
    barrier

  let release ~barrier_id ~value =
    let cpsrelease =
      let fct_name = black_if_magic "release_barrier" in
      qml_bycps_call fct_name in
    let release_barrier = QC.apply cpsrelease [ QC.ident barrier_id ; QC.ident value ] in
    let release_barrier =
      #<If:CPS_DEBUG>
        runtime_debug DebugLevel.release_barrier
        (Printf.sprintf "release_barrier : %s" (Ident.to_string barrier_id))
        release_barrier
      #<Else>
        release_barrier
      #<End>
    in
    release_barrier

  let before_wait () =
    QC.apply (qml_bycps_call "before_wait") [ QC.unit () ]

  let blocking_wait barrier_id =
    let cpsblockingwait =
      let fct_name = black_if_magic "blocking_wait" in
      qml_bycps_call fct_name in
    let blocking_wait = QC.apply cpsblockingwait [ QC.ident barrier_id ] in
    let blocking_wait =
      #<If:CPS_DEBUG>
        runtime_debug DebugLevel.blocking_wait
        (Printf.sprintf "blocking_wait : %s" (Ident.to_string barrier_id))
        blocking_wait
      #<Else>
        blocking_wait
      #<End>
    in
    blocking_wait

  let toplevel_wait barrier_id =
    let cpstoplevelwait =
      let fct_name = black_if_magic "toplevel_wait" in
      qml_bycps_call fct_name in
    let toplevel_wait = QC.apply cpstoplevelwait [ QC.ident barrier_id ] in
    toplevel_wait
end

let private_env_add id barrier_id private_env =
  { private_env with
      toplevel_barrier = IdentMap.add id barrier_id private_env.toplevel_barrier
  }

let private_env_add_skipped_fun id arity fskip_id fcps_id private_env =
  { private_env with
      skipped_functions = IdentMap.add id (arity, fskip_id, fcps_id) private_env.skipped_functions
  }

let simpl_let_in = function
  | Q.LetIn (_, [(x, expr)], Q.Ident (_, y)) when Ident.equal x y -> expr
  | expr -> expr

let code_elt (env:env) (private_env:private_env) code_elt =
  match code_elt with
  | Q.NewVal (label, defs) ->

      let rec fold_filter_map private_env (id, expr) =
        let immediate_value_or_barrier ?(can_skip_toplvl=false) () =
          let is_asynchronous, expr =
            match expr with
            | Q.Directive (_, `asynchronous_toplevel, [e], _) -> true, e
            | _ -> false, expr
          in
          let private_env, il_term = il_of_qml ~can_skip_toplvl:can_skip_toplvl env private_env expr in
          let private_env, il_term = il_simplification env private_env il_term in
          match il_term with
            (* a barrier won't be needed when an expression is skipable at toplvl *)
          | IL.Skip expr ->
              begin
                (* let toplevel_cont v = QC.ident v in *)
                (* let private_env, expr = qml_of_il ~toplevel_cont env private_env il_term in *)
                (* simplification : if the code is [val f = let x = foo in x], replace it by [val f = foo] *)
                (* much simplier and efficienter to detect after generation *)
                let expr = simpl_let_in expr in
                private_env, [ (id, expr) ]
              end
                (* the expression has not been skiped at toplvl, *)
          | _ ->
              begin
                let asynchronous = env.options.toplevel_concurrency || is_asynchronous in
                let local_barrier_id, barrier_id, make_barrier =
                  let barrier_id = Ident.refreshf ~map:"%s_barrier" id in
                  let make_barrier = Barrier.make barrier_id in
                  let local_barrier_id = if asynchronous then Ident.refresh barrier_id else barrier_id in
                  local_barrier_id, barrier_id, make_barrier
                in
                let toplevel_cont value = Barrier.release ~barrier_id:local_barrier_id ~value in
                let private_env, expr = qml_of_il ~toplevel_cont env private_env il_term in
                let expr = simpl_let_in expr in
                if asynchronous
                then
                  begin
                    private_env_add id barrier_id private_env,
                    [ (barrier_id,
                       QC.letin [local_barrier_id, make_barrier]
                         (QC.letin [Ident.next "barrier_unit", expr]
                            (QC.ident local_barrier_id)
                         )
                      ) ]
                  end
                else
                  begin
                    private_env,
                    [ (id,
                       QC.letin [Ident.nextf "before", Barrier.before_wait ()]
                         (QC.letin [barrier_id, make_barrier]
                            (QC.letin [Ident.next "barrier_unit", expr]
                               (Barrier.toplevel_wait barrier_id)
                            )
                         )
                      ) ]
                  end
              end
        in
        let immediate_lambda arity =
          let private_env, il_term = il_of_qml ~can_skip_toplvl:true env private_env expr in
          let private_env, il_term = il_simplification env private_env il_term in
          let toplevel_cont v = QC.ident v in
          match il_term with
          | IL.Skip e ->
              (* 2 version of the lambda must be created, one is CPS and the other is a SKIP *)
              (* It is mandatory to have both versions, the fun_SKIP will be used when the fun's call
                 is complete and the fun_CPS will be used in all other cases *)
              let fskip = e in
              let fskip_id =  Ident.refreshf ~map:"%s_skip" id in
              let private_env = private_env_add_skipped_fun id arity fskip_id id private_env in
              let fskip_eta_exp = QmlAstUtils.Lambda.eta_expand_ast arity (QC.ident id) in
              let private_env, fcps_il = il_of_qml env private_env fskip_eta_exp in
              let private_env, fcps = qml_of_il ~toplevel_cont env private_env fcps_il in
              let fcps = simpl_let_in fcps in
              private_env, [ (fskip_id, fskip); (id, fcps) ]
          | _ ->
              (* if the lambda is not skipable, only a CPS version is generated *)
              let private_env, expr = qml_of_il ~toplevel_cont env private_env il_term in
              let expr = simpl_let_in expr in
              private_env, [ (id, expr) ]
        in
        match expr with
        | Q.Const _ -> immediate_value_or_barrier ~can_skip_toplvl:true ()
        | Q.Ident (_, x) ->
            (* alias case *)
          begin
            match
              private_env_get_skipped_fun x private_env,(* skipping information *)
              IdentMap.find_opt x private_env.toplevel_barrier(* barrier information *)
            with
            (* on a skipped function *)
            | Some (arity, x_skip_id, x_cps_id),_ ->
                (* we recreate a two version function skip and cps *)
              let skip_id =  Ident.refreshf ~map:"%s_skip" id in
              let private_env = private_env_add_skipped_fun id arity x_skip_id x_cps_id private_env in
              private_env, [ (skip_id,  QC.ident x_skip_id) ; (id, QC.ident x_cps_id )  ]

            (* on a barrier *)
            | _, Some barrier when env.options.toplevel_concurrency ->
              private_env_add id barrier private_env, [] (* removing this re-binding *)

            (* general case *)
            | _ -> immediate_value_or_barrier ~can_skip_toplvl:true ()
          end

        | Q.LetIn _
        | Q.LetRecIn _ -> immediate_value_or_barrier ()

        | Q.Directive (_, `restricted_bypass _, [Q.Lambda (_, l, _)], _)
        | Q.Lambda (_, l, _) -> immediate_lambda (List.length l)

        | Q.Apply _ -> immediate_value_or_barrier ~can_skip_toplvl:true ()

        | Q.Match _ -> immediate_value_or_barrier ~can_skip_toplvl:true ()

        (* optimization for simple record *)
        (* <!> see the corresponding optimization in qml -> IL *)
        | Q.Record _ -> immediate_value_or_barrier ~can_skip_toplvl:true ()

        | Q.Dot _ -> immediate_value_or_barrier ~can_skip_toplvl:true ()

        | Q.ExtendRecord _ -> immediate_value_or_barrier ()

        | Q.Directive (_, `restricted_bypass _, _, _)
        | Q.Bypass _ -> immediate_value_or_barrier ()

        | Q.Coerce (_, e, _) -> fold_filter_map private_env (id, e)

        | Q.Path _ ->
            failwith "Internal error: At this stage, all first-class paths should have been compiled."

        (* control the presence of cps directive at top-level *)

        | Q.Directive (_, `spawn, [_], _) -> immediate_value_or_barrier ()
        | Q.Directive (_, `wait, [_], _) -> immediate_value_or_barrier ()
        | Q.Directive (_, `atomic, [_], _) -> immediate_value_or_barrier ()

        (* TODO: decide what to do with that, probably remove it *)
        | Q.Directive (_, `immovable, [_], _) -> assert false

        (* Some explication on hybrid value :
           - When we encountered a hybrid_value we
           know that we compile a client code. (Indeed hybrid_value can
           be introduce only on client_code)
           - We know also that compiler is before javascript
           compilation (else we would have no client code)
           - And compiler is before cps rewriting on server (because
           it's make after javascript compilation)

           Then we compile only the client value. Javascript compiler
           will compile hybrid_value like a server value and this
           value will be computed by cps after javascript compiler

           CpsClient  :
             hybrid_value(client, server)
               -> hybrid_value(cpsclient, server)
           JsCompiler :
             hybrid_value(cpsclient, server)
               -> "a js cps string using cpsclient" ^ server ^ "..."
           CpsServer :
             "a js cps string using cpsclient" ^ server ^ "..."
               -> "a js cps string using cpsclient" ^ cpsserver ^ "..."
        *)
        | Q.Directive (_, `hybrid_value, l, tys) ->
            begin
              match l with
              | [_server] ->
                  private_env, [(id, expr)]
              | [client; server] ->
                  ignore server;
                  let private_env, e = fold_filter_map private_env (id, client) in
                  (match e with
                   | [] -> assert false
                   | [ (id, e) ] ->
                       private_env,
                       [ id, QC.directive `hybrid_value [e ; server] tys ]
                   | _ -> assert false)
              | _ -> assert false
            end

        | Q.Directive (_, `asynchronous_toplevel, _, _) -> immediate_value_or_barrier ()

        | Q.Directive (_, `llarray, _, _) -> immediate_value_or_barrier ~can_skip_toplvl:true ()

        (* with other directive, there is no way to know if the value can be immediate or not *)
        (* this can be optimized, case by case *)
        | Q.Directive _ -> immediate_value_or_barrier ()

      in
      let private_env, defs = List.fold_left_map fold_filter_map private_env defs in
      private_env,
      begin
        match List.flatten defs with
        | [] -> []
        | defs -> List.map (fun def -> Q.NewVal (label, [def])) defs (*[ NewVal defs ]*)
      end

  | Q.NewValRec (label, defs) ->

      let rec fold_map private_env (id, expr) =
        match expr with

        (* hack case : TODO: remove this when this could be a valid pre-condition *)
        | Q.Coerce (_, expr, _ ) -> fold_map private_env (id, expr)

        (* normal case *)
        | Q.Lambda _ ->
          let private_env, il_term = il_of_qml ~can_skip_toplvl:false env private_env expr in
          let private_env, il_term = il_simplification env private_env il_term in
          let toplevel_cont v = QC.ident v in
          begin match il_term with
          | IL.Skip _ -> assert false
          | _ ->
             (* if the lambda is not skipable, only a CPS version is generated *)
            let private_env, expr = qml_of_il ~toplevel_cont env private_env il_term in
            let expr =
              match expr with
              | Q.LetIn (_, [(x,expr)], Q.Ident (_, y)) when Ident.equal x y -> expr
              | _ -> expr
            in private_env, (id, expr)
          end


        | _ ->
            (* FIXME: use OpaError *)
            OManager.i_error
              "Internal error: there should be no recursive non-functional value at this stage: %a"
              QmlPrint.pp#expr expr
      in
      let private_env, defs = List.fold_left_map fold_map private_env defs in
      private_env, [ Q.NewValRec (label, defs) ]

  (* other top level QmlAst.code_elt are ignored and removed *)
  | _ -> private_env , []


let code (env:env) (private_env:private_env) code =
  List.fold_left_collect (code_elt env) private_env code

(* these two functions instrument the code with directives
 * @cps_stack_lambda and @cps_stack_apply
 * @cps_stack_lambda is put just under all the lambdas
 * @cps_stack_apply is put on the Apply Node when what is being applied is not a bypass
 *)
let instrument_expr e =
  let rec aux tra (env:Obj.t option ref option) e =
    match e with
    | Q.Lambda (label, args, e) ->
        let env = ref None in
        let e = aux tra (Some env) e in
        Q.Lambda (label, args, QC.directive (`cps_stack_lambda env) [e] [])
    | Q.Directive (label,`partial_apply info,[Q.Apply (label2,e,el)],tyl) ->
        let e = aux tra env e in
        let el = List.map (aux tra env) el in
        Q.Directive (label,`partial_apply info,[Q.Apply (label2,e,el)],tyl)
    | Q.Apply (_, Q.Directive (_, `restricted_bypass _, _, _), _)
    | Q.Apply (_, Q.Directive (_, `may_cps, _, _), _)
    | Q.Apply (_, Q.Bypass _,_) -> tra env e
    | Q.Apply (label,f,_) ->
        let name_opt =
          match f with
          | Q.Ident (_,i) -> Some (Ident.stident i)
          | _ -> None in
        let pos_opt =
          let pos = Annot.pos label in
          if FilePos.is_empty pos then None else Some (FilePos.to_string pos) in
        let e = tra env e in
        QC.directive (`cps_stack_apply (env,name_opt,pos_opt)) [e] []
    | _ -> tra env e in
  QmlAstWalk.Expr.traverse_map_context_down aux None e

let instrument code =
  List.map
    (function
     | Q.NewVal (label, iel) ->
         Q.NewVal (label, List.map (fun (i,e) -> (i, instrument_expr e)) iel)
     | Q.NewValRec (label, iel) ->
         Q.NewValRec (label, List.map (fun (i,e) -> (i, instrument_expr e)) iel)
     | _ -> assert false)
    code

(* utils for back'ends *)
let cps_pass ~side env qml_code =
  let qml_code = #<If:CPS_STACK_TRACE>instrument qml_code#<Else>qml_code#<End> in
  let private_env_initial = Package.load_dependencies ~side in
  let private_env, r = code env private_env_initial qml_code in
  Package.save_current ~side ~private_env_initial ~private_env;
  let _ =
    #<If:CPS_VERBOSE $minlevel DebugLevel.il_opt_timer>
      debug "il optimisation global time : %f s." (Chrono.read chrono_factorize_letcont) ;
      debug "%d letcont simplified" (Factorize.count ()) ;
      debug "il substitution global time : %f s." (Factorize.chrono_subst ())
    #<End> in

  match private_binding private_env with
  | [] -> r
  | bindings ->
      let label = Annot.nolabel "QmlCpsRewriter.cps_pass" in
      (Q.NewVal (label, bindings)) :: r

let no_cps_pass env code =
  let private_env = private_env_initial () in
  let bp_uncps = qml_bycps_call "uncps_native" in
  let bp_cps i = qml_bycps_call
    (Printf.sprintf "Notcps_compatibility.cps%d_native" i) in
  let dummy_cont = qml_bycps_call "Notcps_compatibility.dummy_cont" in
  let uncps expr =
    let ident = QmlAstCons.UntypedExpr.string "InsertedByNoCpsPass" in
    QmlAstCons.UntypedExpr.apply bp_uncps [ident; dummy_cont ;expr] in
  let max_arity_projectable = 5 in (* the maximum defined in ByCps.not_cpscompatiblity *)
  let cps key arity expr =
    if arity > max_arity_projectable then (
      OManager.serror "No cps pass can't project cps bypass %a which take functions with arity(=%d) > %d" BslKey.pp key arity max_arity_projectable;
      QmlAstCons.UntypedExpr.int 0
    )
    else
      QmlAstCons.UntypedExpr.apply (bp_cps arity) [expr] in
  let rec get_bp_tyargs bp =
    let k = U.bp_get_key bp in
    match env.bsl_bypass_typer k with
    | BslTypes.Fun (_, args, _) -> args
    | _ -> assert false
  in
  let rewrite expr =
    match expr with
    | Q.Apply (_, Q.Ident _, _) -> expr
    | Q.Apply (_, f, f_args) when (not(U.good_apply_property private_env f f_args))-> expr
    | Q.Apply (label, bypass, f_args) ->
        let key = U.bp_get_key bypass in
        if (env.bsl_bypass_tags key).BslTags.cps_bypass then (
          let f_args = List.fold_left
            (fun (typ_args, res) arg ->
               match typ_args with
               | (BslTypes.Fun (_,x,_))::q -> q, cps key (List.length x) arg::res
               | _::q -> q, arg::res
               | _ -> assert false)
            (get_bp_tyargs bypass, [])
            f_args in
          let f_args = List.rev (snd f_args) in
          let expr = Q.Apply (label, bypass, f_args) in
          uncps expr
        )
        else expr
    | _ -> expr
  in
  QmlAstWalk.CodeExpr.map
        (QmlAstWalk.Expr.map_up rewrite)
        code

(* keep it consistent with the name of the module *)
let serverlib_module_name = "QmlCpsServerLib"
let bsl = "OpabslgenMLRuntime.BslCps"

(* cf mli *)
let meta_cps_utils n =
  let b = FBuffer.create 1024 in
  let b = FBuffer.printf b "let uncps = %s.uncps_ml\n" bsl in
  let b = FBuffer.printf b "let uncps0 s k f = (); fun () -> uncps s k f\n" in
  let b =
    let b =
      let rec aux i acc b =
        if i > n then b else
          let acc = Printf.sprintf "%s x%d" acc i in
          let b = FBuffer.printf b "let uncps%d s k f%s = uncps s k (f%s)\n" i acc acc in
          aux (succ i) acc b
      in
      aux 1 "" b in
    let b = FBuffer.printf b "let cps f k = %s.return k f\n" serverlib_module_name in
    let b = FBuffer.printf b "let cps0 f k = %s.return k (f ())\n" serverlib_module_name in
    let b =
      let rec aux i acc b =
        if i > n then b else
          let acc = Printf.sprintf "%s x%d" acc i in
          let b = FBuffer.printf b "let cps%d f%s k = %s.return k (f%s)\n" i acc serverlib_module_name acc in
          aux (succ i) acc b
      in aux 1 "" b in
    b
  in
  FBuffer.contents b


(*

  TODO: do not generated unused cont introduction
  as in this example: (_v10_cont)

rec _v0_aux(_v0_i, _v7_cont) =
      match _v0_i with
      | 0 ->
          _v6_val =  {}
          @restricted_bypass[cps](%%bslcps_return%%)(_v7_cont, _v6_val)
      | _v1_i ->
          _v5_val =
            _v2_arg =  "toto"
            _v0__v0_bslpervasives_print_endline_skip(_v2_arg)
          _v4_val =  _v0_`_v0_pred_pointer.opa`_skip(_v1_i)
          _v10_cont =
            @restricted_bypass[cps](%%bslcps_ccont%%)(_v7_cont,
              (_v3_val ->
                 @restricted_bypass[cps](%%bslcps_return%%)(_v7_cont, _v3_val)))
          _v0_aux(_v4_val, _v10_cont)
      end
*)