Add real time CSP procedure support.

Construction is still incorrect but the types should be OK.

src/compiler/flx_bind/flx_inner_type_of_index.ml

@@ -112,9 +112,7 @@ assert false
 *)
 
   | SYMDEF_function ((ps,_),rt,effects,props,_) ->
-(*
 print_endline ("** BEGIN ** Calculating Function type for function " ^ sym.Flx_sym.id ^ " index "^si index);
-*)
       let ptyp = typeof_paramspec_t ps in
 
       (* Calculate the return type. *)
@@ -154,7 +152,13 @@ print_endline ("** END **** Abnormal Exit Function type for function " ^ sym.Flx
       let d = bt sym.Flx_sym.sr ptyp in
       let e = bt sym.Flx_sym.sr effects in
       let ft = 
-        if List.mem `Cfun props then btyp_cfunction (d, rt)
+        if List.mem `Csp props then 
+          let t = btyp_rtfunction (d, rt) in
+          begin 
+            print_endline ("CSP function detected in inner type of index " ^ Flx_btype.st t); 
+            t
+          end
+        else if List.mem `Cfun props then btyp_cfunction (d, rt) 
         else if List.mem `LinearFunction props then btyp_lineareffector (d, e, rt)
         else btyp_effector (d, e, rt)
       in

src/compiler/flx_core/flx_ast.ml

@@ -358,6 +358,7 @@ and funkind_t = [
   | `GeneratorMethod
   | `Method
   | `Object
+  | `Csp
 ]
 
 and property_t = [
@@ -398,6 +399,7 @@ and property_t = [
   | `Service_call        (* does a svc instruction (directly or indirectly maybe*)
   | `NoService_call      (* does not do a svc instruction definitely *)
   | `LinearFunction
+  | `Csp
 ]
 
 and type_qual_t = [

src/compiler/flx_core/flx_beta.ml

@@ -529,6 +529,7 @@ print_endline ("Beta-reducing typeop " ^ op ^ ", type=" ^ sbt bsym_table t);
   | BTYP_linearfunction (a,b) -> btyp_linearfunction (br a, br b)
   | BTYP_lineareffector (a,e,b) -> btyp_lineareffector (br a, br e, br b)
   | BTYP_cfunction (a,b) -> btyp_cfunction (br a, br b)
+  | BTYP_rtfunction (a,b) -> btyp_rtfunction (br a, br b)
 
   | BTYP_ptr (m,t,ts)  -> btyp_ptr m (br t) (List.map br ts)
 

src/compiler/flx_core/flx_btype.ml

@@ -111,6 +111,7 @@ and t =
   | BTYP_linearfunction of t * t
   | BTYP_lineareffector of t * t * t
   | BTYP_cfunction of t * t
+  | BTYP_rtfunction of t * t
   | BTYP_void
   | BTYP_label (* type of a label *)
   | BTYP_fix of int * kind (* meta type *)
@@ -193,6 +194,7 @@ let flat_iter
   | BTYP_linearfunction (a,b) -> f_btype a; f_btype b
   | BTYP_lineareffector (a,e,b) -> f_btype a; f_btype e; f_btype b
   | BTYP_cfunction (a,b) -> f_btype a; f_btype b
+  | BTYP_rtfunction (a,b) -> f_btype a; f_btype b
   | BTYP_rev t -> f_btype t
   | BTYP_uniq t -> f_btype t
   | BTYP_borrowed t -> f_btype t
@@ -353,6 +355,7 @@ and str_of_btype typ =
   | BTYP_effector (d,e,c) -> "BTYP_effector(" ^ s d ^ " ->["^s e^"] " ^ s c ^")"
   | BTYP_lineareffector (d,e,c) -> "BTYP_lineareffector(" ^ s d ^ " ->["^s e^"] " ^ s c ^")"
   | BTYP_cfunction (d,c) -> "BTYP_cfunction(" ^ s d ^ " --> " ^ s c ^")"
+  | BTYP_rtfunction (d,c) -> "BTYP_rtfunction(" ^ s d ^ " --> " ^ s c ^")"
 
   | BTYP_rev t -> "BTYP_rev("^ s t ^")" 
   | BTYP_uniq t -> "BTYP_uniq(" ^ s t ^ ")"
@@ -518,6 +521,7 @@ let complete_type t =
     | BTYP_linearfunction (a,b) -> uf a;uf b
     | BTYP_lineareffector (a,e,b) -> uf a; uf e; uf b
     | BTYP_cfunction (a,b) -> uf a;uf b
+    | BTYP_rtfunction (a,b) -> uf a;uf b
     | BTYP_ptr (_,a,_) -> uf a
     | BTYP_fix (i,_) when (-i) = depth -> ()
     | BTYP_fix (i,_) when (-i) > depth -> raise (Free_fixpoint t')
@@ -935,6 +939,10 @@ let btyp_lineareffector (args, effects, ret) =
 let btyp_cfunction (args, ret) =
   BTYP_cfunction (args, ret)
 
+(** Construct a BTYP_rtfunction type. *)
+let btyp_rtfunction (args, ret) =
+  BTYP_rtfunction (args, ret)
+
 (** Construct a BTYP_fix type. *)
 let btyp_fix i mt =
 (*
@@ -1163,6 +1171,7 @@ let rec map ?(f_bid=fun i -> i) ?(f_btype=fun t -> t) ?(f_kind=fun k->k) = funct
   | BTYP_linearfunction (a,b) -> btyp_linearfunction (f_btype a, f_btype b)
   | BTYP_lineareffector (a,e,b) -> btyp_lineareffector (f_btype a, f_btype e, f_btype b)
   | BTYP_cfunction (a,b) -> btyp_cfunction (f_btype a, f_btype b)
+  | BTYP_rtfunction (a,b) -> btyp_rtfunction (f_btype a, f_btype b)
 
   | BTYP_rev t -> btyp_rev (f_btype t)
   | BTYP_uniq t -> btyp_uniq (f_btype t)
@@ -1423,6 +1432,7 @@ and unfold msg t =
     | BTYP_function (a,b) -> btyp_function (uf a,uf b)
     | BTYP_effector (a,e, b) -> btyp_effector (uf a,uf e,uf b)
     | BTYP_cfunction (a,b) -> btyp_cfunction (uf a,uf b)
+    | BTYP_rtfunction (a,b) -> btyp_rtfunction (uf a,uf b)
     | BTYP_ptr (m,t,ts)  -> btyp_ptr m (uf t) (List.map uf ts)
     | BTYP_fix (i,_) when (-i) = depth -> t
     | BTYP_fix (i,_) when (-i) > depth -> 

src/compiler/flx_core/flx_btype.mli

@@ -71,6 +71,7 @@ and t = private
   | BTYP_linearfunction of t * t
   | BTYP_lineareffector of t * t * t
   | BTYP_cfunction of t * t
+  | BTYP_rtfunction of t * t
   | BTYP_void
   | BTYP_label
   | BTYP_fix of int * kind 
@@ -192,6 +193,7 @@ val btyp_effector : t * t * t -> t
 val btyp_linearfunction : t * t -> t
 val btyp_lineareffector : t * t * t -> t
 val btyp_cfunction : t * t -> t
+val btyp_rtfunction : t * t -> t
 val btyp_fix : int -> kind -> t
 val btyp_type_tuple : t list -> t
 val btyp_type_function : (bid_t * kind) list * kind * t -> t

src/compiler/flx_core/flx_btype_kind.ml

@@ -131,6 +131,7 @@ print_endline ("Flx_btype_kind.metatype' case type_apply: " ^ Flx_btype.st typ);
   | BTYP_rptsum (rpt, base) -> kind_max [kind_type; (mt rpt); (mt base)]
 
   | BTYP_cfunction (d,c)
+  | BTYP_rtfunction (d,c)
   | BTYP_linearfunction (d,c)
   | BTYP_lineareffector (d,_,c)
   | BTYP_function (d,c) 

src/compiler/flx_core/flx_btype_occurs.ml

@@ -61,6 +61,7 @@ let var_occurs bsym_table t =
     | BTYP_effector (a,e,b) -> aux a; aux e; aux b
 
     | BTYP_cfunction (a,b) -> aux a; aux b
+    | BTYP_rtfunction (a,b) -> aux a; aux b
 
     | BTYP_ptr (_,t,ts)  -> aux t; List.iter aux ts
     | BTYP_rev a -> aux a

src/compiler/flx_core/flx_btype_rec.ml

@@ -10,6 +10,7 @@ let rec check_rec t = match t with
    | BTYP_linearfunction _
    | BTYP_lineareffector _
    | BTYP_cfunction _
+   | BTYP_rtfunction _
    | BTYP_variant _
      -> ()
 
@@ -55,6 +56,7 @@ let fix i t =
     | BTYP_linearfunction (a,b) -> btyp_linearfunction (aux a, aux b)
     | BTYP_lineareffector (a,e,b) -> btyp_lineareffector (aux a, aux e, aux b)
     | BTYP_cfunction (a,b) -> btyp_cfunction (aux a, aux b)
+    | BTYP_rtfunction (a,b) -> btyp_rtfunction (aux a, aux b)
 
     | BTYP_ptr (m,t,ts) -> btyp_ptr m (aux t) (List.map aux ts)
 

src/compiler/flx_core/flx_fold.ml

@@ -36,6 +36,7 @@ let fold (bsym_table: Flx_bsym_table.t) counter t =
     | BTYP_linearfunction (a,b) -> ax a; ax b
     | BTYP_lineareffector (a,e, b) -> ax a; ax e; ax b
     | BTYP_cfunction (a,b) -> ax a; ax b
+    | BTYP_rtfunction (a,b) -> ax a; ax b
 
     | BTYP_rev a -> ax a
 

src/compiler/flx_core/flx_print.ml

@@ -909,6 +909,9 @@ and sb bsym_table depth fixlist counter prec tc =
     | BTYP_cfunction (args, result) ->
       6,(sbt 6 args) ^ " --> " ^ (sbt 6 result)
 
+    | BTYP_rtfunction (args, result) ->
+      6,(sbt 6 args) ^ " -rt-> " ^ (sbt 6 result)
+
     | BTYP_rptsum (t1,t2) ->
       begin match t1 with
       | BTYP_unitsum k -> 3, si k ^"*+"^sbt 3 t2
@@ -1247,6 +1250,7 @@ and string_of_lvalue (x,t) =
   end
 
 and string_of_property = function
+| `Csp -> "csp"
 | `Subtype -> "subtype"
 | `Recursive -> "recursive"
 | `Inline -> "inline"
@@ -1424,6 +1428,7 @@ and string_of_funkind kind =
     | `GeneratorMethod-> "method generator"
     | `Method-> "method"
     | `Object -> "object"
+    | `Csp -> "csp"
 
 and string_of_effects t =
   match t with

src/compiler/flx_cpp_backend/flx_cal_type_offsets.ml

@@ -229,6 +229,7 @@ let rec get_offsets' syms bsym_table typ : offset_kind_t list =
   | BTYP_effector _ 
   | BTYP_function _ -> [`Ptr "0"]
   | BTYP_cfunction _ -> []
+  | BTYP_rtfunction _ -> []
 
   | BTYP_label -> [`Ptr "0"] (* see jump_address_t, target_frame at offset 0 *)
 

src/compiler/flx_cpp_backend/flx_gen.ml

@@ -313,6 +313,7 @@ let gen_procedure_methods filename syms bsym_table
   let cxx_name = cid_of_flxid (Flx_bsym.id bsym) in
   match Flx_bsym.bbdcl bsym with
   | BBDCL_fun (props,vs,bps,BTYP_void,effects,exes) ->
+if List.mem `Csp props then print_endline ("Backend gen_procedure_methods finds csp proc " ^ bsym.id);
     if length ts <> length vs then
     failwith
     (
@@ -353,7 +354,7 @@ let gen_procedure_methods filename syms bsym_table
 *)
     in
 
-    let cont = "::flx::rtl::con_t *" in
+    let cont = if List.mem `Csp props then "rt_con_t *" else "::flx::rtl::con_t *" in
     let heap_call_arg_sig, heap_call_arg =
       match argtype with
       | BTYP_tuple [] -> cont ^ "_ptr_caller","0"

src/compiler/flx_cpp_backend/flx_gen_func.ml

@@ -30,6 +30,7 @@ open Flx_btype_subst
 
 (* vs here is the (name,index) list of type variables *)
 let gen_function syms bsym_table props index id sr vs bps ret' ts instance_no =
+if List.mem `Csp props then print_endline ("Actually generating rt function " ^ id);
   let stackable = mem `Stack_closure props in
   let heapable = mem `Heap_closure props in
   let requires_ptf = mem `Requires_ptf props in
@@ -82,7 +83,11 @@ let gen_function syms bsym_table props index id sr vs bps ret' ts instance_no =
   let ret = rt' vs ret' in
   if ret = btyp_tuple [] then "// elided (returns unit)\n" else
 
-  let funtype = Flx_fold.fold bsym_table syms.counter (btyp_function (argtype, ret)) in
+  let funtype = 
+    if List.mem `Csp props then btyp_rtfunction (argtype, ret) 
+    else btyp_function (argtype, ret)
+  in
+  let funtype = Flx_fold.fold bsym_table syms.counter funtype  in
 
   let argtypename = cpp_typename syms bsym_table argtype in
   let funtypename =
@@ -147,12 +152,13 @@ let gen_function syms bsym_table props index id sr vs bps ret' ts instance_no =
   let members = find_members syms bsym_table index ts in
   match ret with
   | BTYP_void ->
+    let cont = if List.mem `Csp props then "rt_con_t" else "::flx::rtl::con_t" in
     let name = cpp_instance_name syms bsym_table index ts in
     let ctor = ctor_dcl name in
     "struct " ^ name ^
     (match funtypename with
     | Some x -> ": "^x
-    | None -> if not heapable then "" else ": ::flx::rtl::con_t"
+    | None -> if not heapable then "" else ": " ^ cont 
     )
     ^
     " {\n" ^
@@ -184,15 +190,15 @@ let gen_function syms bsym_table props index id sr vs bps ret' ts instance_no =
     (if argtype = btyp_tuple [] || argtype = btyp_void ()
     then
       (if stackable then "  void stack_call();\n" else "") ^
-      (if heapable then "  ::flx::rtl::con_t *call(::flx::rtl::con_t*);\n" else "")
+      (if heapable then "  " ^ cont ^ " *call(" ^ cont ^ " *);\n" else "")
     else
       (if stackable then "  void stack_call("^argtypename^" const &);\n" else "") ^
-      (if heapable then "  ::flx::rtl::con_t *call(::flx::rtl::con_t*,"^argtypename^" const &);\n" else "")
+      (if heapable then "  " ^ cont ^ " *call(" ^ cont ^ " *,"^argtypename^" const &);\n" else "")
     ) ^
     (*
     "  //resume\n" ^
     *)
-    (if heapable then "  ::flx::rtl::con_t *resume();\n" else "")
+    (if heapable then "  " ^ cont ^ " *resume();\n" else "")
     ^
     "};\n"
 

src/compiler/flx_cpp_backend/flx_gen_functions.ml

@@ -61,9 +61,14 @@ let gen_functions syms bsym_table (shapes: Flx_set.StringSet.t ref) shape_table
     in
     match Flx_bsym.bbdcl bsym with
     | BBDCL_fun (props,vs,ps,ret,effects,_) ->
+if List.mem `Csp props then print_endline ("Generating rt function " ^ bsym.id);
       let is_proc = match ret with | BTYP_void -> true | _ -> false in
       let is_escape = match ret with | BTYP_fix(0,_) -> true | _ -> false in
-      let name = (if is_escape then "ESCAPE " else "") ^ (if is_proc then "PROCEDURE" else "FUNCTION") in
+      let name = 
+         (if List.mem `Csp props then "CSP " else "") ^ 
+         (if is_escape then "ESCAPE " else "") ^ 
+         (if is_proc then "PROCEDURE" else "FUNCTION") 
+      in
       bcat s ("\n//------------------------------\n");
       let ft = btyp_effector (Flx_bparams.get_btype ps,effects,ret) in
       if mem `Cfun props || mem `Pure props && not (mem `Heap_closure props) then begin

src/compiler/flx_cpp_backend/flx_name.ml

@@ -282,6 +282,7 @@ print_endline ("Flx_tgen.cpp_type_classname " ^ sbt bsym_table t);
   | BTYP_linearfunction _ -> "_ft" ^ cid_of_bid (tix t)
 
   | BTYP_cfunction _ -> "_cft" ^ cid_of_bid (tix t)
+  | BTYP_rtfunction _ -> "_rtft" ^ cid_of_bid (tix t)
   | BTYP_array _ -> "_at" ^ cid_of_bid (tix t)
   | BTYP_tuple _ -> "_tt" ^ cid_of_bid (tix t)
   | BTYP_intersect _ -> "_intersection" ^ cid_of_bid (tix t)
@@ -456,6 +457,7 @@ and cpp_structure_name syms bsym_table t =
   | BTYP_linearfunction (d,c) -> "_ft<" ^ tn d ^ "," ^ tn c ^ ">" 
 
   | BTYP_cfunction (d,c) -> "_cft<" ^  tn d ^ "," ^ tn c ^">"
+  | BTYP_rtfunction (d,c) -> "_rtft<" ^  tn d ^ "," ^ tn c ^">"
 
   | BTYP_compactrptsum _
   | BTYP_compactsum _
@@ -561,6 +563,7 @@ and cpp_typename syms bsym_table t =
   | BTYP_lineareffector _ -> cpp_type_classname syms bsym_table t ^ "*"
   | BTYP_linearfunction _ -> cpp_type_classname syms bsym_table t ^ "*"
   | BTYP_cfunction _ -> cpp_type_classname syms bsym_table t ^ "*"
+  | BTYP_rtfunction _ -> cpp_type_classname syms bsym_table t ^ "*"
   | BTYP_ptr (`RW,t,[]) -> cpp_typename syms bsym_table t ^ "*"
   | BTYP_ptr (`R,t,[]) -> cpp_typename syms bsym_table t ^ " const*"
   | BTYP_ptr (`V,t,[]) -> cpp_typename syms bsym_table t ^ " const*"

src/compiler/flx_cpp_backend/flx_tgen.ml

@@ -208,6 +208,13 @@ let rec gen_type_name syms bsym_table (index,typ) =
     let name = cn typ in
     "struct " ^ name ^ ";\n"
 
+  | BTYP_rtfunction _ ->
+    descr ^
+    let name = cn typ in
+    "struct " ^ name ^ ";\n"
+
+
+
   | BTYP_cfunction (d,c) -> descr ^ "\n"
 
   | BTYP_rptsum _ 
@@ -391,6 +398,7 @@ let rec gen_type syms bsym_table (index,typ) =
 
 
   | BTYP_linearfunction (a,BTYP_void) 
+
   | BTYP_function (a,BTYP_void) ->
     descr ^
     let name = cn typ
@@ -411,6 +419,27 @@ let rec gen_type syms bsym_table (index,typ) =
     "  virtual ::flx::rtl::con_t *resume()=0;\n"  ^
     "};\n"
 
+  | BTYP_rtfunction (a,BTYP_void) ->
+print_endline ("Generating rt function type " ^ Flx_btype.st t); 
+    descr ^
+    let name = cn typ
+    and argtype = tn a
+    and unitproc = a = btyp_tuple [] || a = btyp_void ()
+    in
+    "struct " ^ name ^
+    ": rt_con_t {\n" ^
+    "  typedef void rettype;\n" ^
+    "  typedef " ^ (if unitproc then "void" else argtype) ^ " argtype;\n" ^
+    (if unitproc
+    then
+    "  virtual rt_con_t *call(rt_con_t *)=0;\n"
+    else
+    "  virtual rt_con_t *call(rt_con_t *, "^argtype^" const &)=0;\n"
+    ) ^
+    "  virtual "^name^" *clone()=0;\n"  ^
+    "  virtual rt_con_t *resume()=0;\n"  ^
+    "};\n"
+
   (* ESCAPE FUNCTION *)
   | BTYP_linearfunction (a,BTYP_fix (0,_))
   | BTYP_function (a,BTYP_fix (0,_)) ->

src/compiler/flx_desugar/flx_curry.ml

@@ -139,7 +139,7 @@ let fix_param sr seq p =
   vs,(p,traint)           (* Reassemble *)
 
 
-let cal_props kind props = match kind with
+let cal_props (kind:funkind_t) props = match kind with
   | `CFunction -> `Cfun::props
   | `InlineFunction -> if not (List.mem `Inline props) then `Inline::props else props
   | `GeneratedInlineProcedure-> `GeneratedInline::props
@@ -154,6 +154,7 @@ let cal_props kind props = match kind with
   | `Function
   | `Object
   | `Method -> props
+  | `Csp -> `Csp::props 
 
 (** Currying, A.K.A. Shonfinkeling *)
 let mkcurry seq sr name vs args return_type effects kind body props =

src/compiler/flx_desugar/flx_desugar.ml

@@ -424,6 +424,7 @@ print_endline ("STMT_curry " ^ name' ^ ", rettype=" ^ string_of_typecode ret);
       let qn = `AST_name (sr,name',[]) in
       let sname = `AST_suffix (sr,(qn,domain)) in
       match kind with
+      | `Csp
       | `Function
       | `LinearFunction
       | `GeneratedInlineProcedure