Work on arrays

2024-09-19 00:15:39 +03:00 · 2024-01-22 16:49:58 +01:00 · 2024-01-22 16:49:58 +01:00 · 8a139f6a3c
commit 8a139f6a3c
parent 50d3164f36
10 changed files with 168 additions and 74 deletions
--- a/compiler/driver.ml
+++ b/compiler/driver.ml
@ -224,7 +224,7 @@ module Passes = struct
      ~avoid_exceptions
      ~closure_conversion
      ~monomorphize_types :
-      untyped Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list =
+      typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list =
    let prg, type_ordering =
      dcalc options ~includes ~optimize ~check_invariants ~typed
    in
@ -276,11 +276,12 @@ module Passes = struct
      if monomorphize_types then (
        Message.emit_debug "Monomorphizing types...";
        let prg, type_ordering = Lcalc.Monomorphize.program prg in
+        Message.emit_debug "Retyping lambda calculus...";
        let prg = Typing.program ~leave_unresolved:ErrorOnAny prg in
        prg, type_ordering)
      else prg, type_ordering
    in
-    Program.untype prg, type_ordering
+    prg, type_ordering

  let scalc
      options
@ -298,8 +299,6 @@ module Passes = struct
      lcalc options ~includes ~optimize ~check_invariants ~typed:Expr.typed
        ~avoid_exceptions ~closure_conversion ~monomorphize_types
    in
-    Message.emit_debug "Retyping lambda calculus...";
-    let prg = Typing.program ~leave_unresolved:LeaveAny prg in
    debug_pass_name "scalc";
    ( Scalc.From_lcalc.translate_program
        ~config:{ keep_special_ops; dead_value_assignment; no_struct_literals }
--- a/compiler/driver.mli
+++ b/compiler/driver.mli
@ -54,7 +54,7 @@ module Passes : sig
    avoid_exceptions:bool ->
    closure_conversion:bool ->
    monomorphize_types:bool ->
-    Shared_ast.untyped Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list
+    Shared_ast.typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list

  val scalc :
    Cli.options ->
--- a/compiler/lcalc/monomorphize.ml
+++ b/compiler/lcalc/monomorphize.ml
@ -37,17 +37,27 @@ type tuple_instance = {
  fields : (StructField.t * naked_typ) list;
 }

+type array_instance = {
+  name : StructName.t;
+  len_field : StructField.t;
+  content_field : StructField.t;
+  content_typ : naked_typ;
+}
+
 type monomorphized_instances = {
  (* The keys are the types inside the [TOption] (before monomorphization). *)
  options : option_instance TypMap.t;
  (* The keys are the [TTuple] types themselves (before monomorphization). *)
  tuples : tuple_instance TypMap.t;
+  (* The keys are the types inside the [TArray] (before monomorphization). *)
+  arrays : array_instance TypMap.t;
 }

 let collect_monomorphized_instances (prg : typed program) :
    monomorphized_instances =
  let option_instances_counter = ref 0 in
  let tuple_instances_counter = ref 0 in
+  let array_instances_counter = ref 0 in
  let rec collect_typ acc typ =
    match Mark.remove typ with
    | TTuple args when List.for_all (fun t -> Mark.remove t <> TAny) args ->
@ -79,7 +89,32 @@ let collect_monomorphized_instances (prg : typed program) :
        }
      in
      List.fold_left collect_typ new_acc args
-    | TArray t | TDefault t -> collect_typ acc t
+    | TArray t ->
+      let new_acc =
+        {
+          acc with
+          arrays =
+            TypMap.update (Mark.remove t)
+              (fun monomorphized_name ->
+                match monomorphized_name with
+                | Some e -> Some e
+                | None ->
+                  incr array_instances_counter;
+                  Some
+                    {
+                      len_field = StructField.fresh ("length", Pos.no_pos);
+                      content_field = StructField.fresh ("content", Pos.no_pos);
+                      content_typ = Mark.remove t;
+                      name =
+                        StructName.fresh []
+                          ( "array_" ^ string_of_int !array_instances_counter,
+                            Pos.no_pos );
+                    })
+              acc.arrays;
+        }
+      in
+      collect_typ new_acc t
+    | TDefault t -> collect_typ acc t
    | TArrow (args, ret) ->
      List.fold_left collect_typ (collect_typ acc ret) args
    | TOption t when Mark.remove t <> TAny ->
@ -144,7 +179,8 @@ let collect_monomorphized_instances (prg : typed program) :
  in
  let acc =
    Scope.fold_left
-      ~init:{ options = TypMap.empty; tuples = TypMap.empty }
+      ~init:
+        { options = TypMap.empty; tuples = TypMap.empty; arrays = TypMap.empty }
      ~f:(fun acc item _ ->
        match item with
        | Topdef (_, typ, e) -> collect_typ (collect_expr acc e) typ
@ -173,7 +209,8 @@ let rec monomorphize_typ
  match Mark.remove typ with
  | TStruct _ | TEnum _ | TAny | TClosureEnv | TLit _ -> typ
  | TArray t1 ->
-    TArray (monomorphize_typ monomorphized_instances t1), Mark.get typ
+    ( TStruct (TypMap.find (Mark.remove t1) monomorphized_instances.arrays).name,
+      Mark.get typ )
  | TDefault t1 ->
    TDefault (monomorphize_typ monomorphized_instances t1), Mark.get typ
  | TArrow (t1s, t2) ->
@ -281,43 +318,30 @@ let rec monomorphize_expr
    let new_args = List.map (monomorphize_expr monomorphized_instances) args in
    let new_tys = List.map (monomorphize_typ monomorphized_instances) tys in
    Expr.eappop ~op ~args:new_args ~tys:new_tys (Mark.get e)
+  | EArray args ->
+    let new_args = List.map (monomorphize_expr monomorphized_instances) args in
+    let array_instance =
+      TypMap.find
+        (match Mark.remove (Expr.maybe_ty (Mark.get e)) with
+        | TArray t -> Mark.remove t
+        | _ -> failwith "should not happen")
+        monomorphized_instances.arrays
+    in
+    Expr.estruct ~name:array_instance.name
+      ~fields:
+        (StructField.Map.add array_instance.content_field
+           (Expr.earray new_args (Mark.get e))
+           (StructField.Map.singleton array_instance.len_field
+              (Expr.elit
+                 (LInt (Runtime.integer_of_int (List.length args)))
+                 (Mark.get e))))
+      (Mark.get e)
  | _ -> Expr.map ~f:(monomorphize_expr monomorphized_instances) e

 let program (prg : typed program) :
    untyped program * Scopelang.Dependency.TVertex.t list =
  let monomorphized_instances = collect_monomorphized_instances prg in
-  (* First we augment the [decl_ctx] with the monomorphized instances *)
-  let prg =
-    {
-      prg with
-      decl_ctx =
-        {
-          prg.decl_ctx with
-          ctx_enums =
-            TypMap.fold
-              (fun _ (option_instance : option_instance) (ctx_enums : enum_ctx) ->
-                EnumName.Map.add option_instance.name
-                  (EnumConstructor.Map.add option_instance.none_cons
-                     (TLit TUnit, Pos.no_pos)
-                     (EnumConstructor.Map.singleton option_instance.some_cons
-                        (option_instance.some_typ, Pos.no_pos)))
-                  ctx_enums)
-              monomorphized_instances.options prg.decl_ctx.ctx_enums;
-          ctx_structs =
-            TypMap.fold
-              (fun _ (tuple_instance : tuple_instance)
-                   (ctx_structs : struct_ctx) ->
-                StructName.Map.add tuple_instance.name
-                  (List.fold_left
-                     (fun acc (field, typ) ->
-                       StructField.Map.add field (typ, Pos.no_pos) acc)
-                     StructField.Map.empty tuple_instance.fields)
-                  ctx_structs)
-              monomorphized_instances.tuples prg.decl_ctx.ctx_structs;
-        };
-    }
-  in
-  (* And we remove the polymorphic option type *)
+  (* First we remove the polymorphic option type *)
  let prg =
    {
      prg with
@ -349,6 +373,54 @@ let program (prg : typed program) :
        };
    }
  in
+  (* Then we augment the [decl_ctx] with the monomorphized instances *)
+  let prg =
+    {
+      prg with
+      decl_ctx =
+        {
+          prg.decl_ctx with
+          ctx_enums =
+            TypMap.fold
+              (fun _ (option_instance : option_instance) (ctx_enums : enum_ctx) ->
+                EnumName.Map.add option_instance.name
+                  (EnumConstructor.Map.add option_instance.none_cons
+                     (TLit TUnit, Pos.no_pos)
+                     (EnumConstructor.Map.singleton option_instance.some_cons
+                        (monomorphize_typ monomorphized_instances
+                           (option_instance.some_typ, Pos.no_pos))))
+                  ctx_enums)
+              monomorphized_instances.options prg.decl_ctx.ctx_enums;
+          ctx_structs =
+            TypMap.fold
+              (fun _ (tuple_instance : tuple_instance)
+                   (ctx_structs : struct_ctx) ->
+                StructName.Map.add tuple_instance.name
+                  (List.fold_left
+                     (fun acc (field, typ) ->
+                       StructField.Map.add field
+                         (monomorphize_typ monomorphized_instances
+                            (typ, Pos.no_pos))
+                         acc)
+                     StructField.Map.empty tuple_instance.fields)
+                  ctx_structs)
+              monomorphized_instances.tuples
+              (TypMap.fold
+                 (fun _ (array_instance : array_instance)
+                      (ctx_structs : struct_ctx) ->
+                   StructName.Map.add array_instance.name
+                     (StructField.Map.add array_instance.content_field
+                        ( TArray
+                            (monomorphize_typ monomorphized_instances
+                               (array_instance.content_typ, Pos.no_pos)),
+                          Pos.no_pos )
+                        (StructField.Map.singleton array_instance.len_field
+                           (TLit TInt, Pos.no_pos)))
+                     ctx_structs)
+                 monomorphized_instances.arrays prg.decl_ctx.ctx_structs);
+        };
+    }
+  in
  let prg =
    Bindlib.unbox
    @@ Bindlib.box_apply
@ -371,6 +443,7 @@ let program (prg : typed program) :
            ~varf:Fun.id prg.code_items)
  in
  let prg = Program.untype prg in
+  Message.emit_debug "Prg:@.%a" (Print.program ~debug:true) prg;
  ( prg,
    Scopelang.Dependency.check_type_cycles prg.decl_ctx.ctx_structs
      prg.decl_ctx.ctx_enums )
--- a/compiler/lcalc/monomorphize.mli
+++ b/compiler/lcalc/monomorphize.mli
@ -22,6 +22,9 @@ val program :
 (** This function performs type monomorphization in a Catala program with two
    main actions: {ul
    {- transforms tuples into named structs.}
-    {- creates monomorphized instances of TOption for every occurence of the type.}}
+    {- creates monomorphized instances of [TOption] for every occurence of the type.}
+    {- creates monomorphized instances of [TArray] for every occurence of the type;
+    each instance is a struct with a integer [length] field and a [content] field whose
+    type still is [TArray].}}
    It also returns the new type ordering for the program.
 *)
--- a/compiler/scalc/from_lcalc.ml
+++ b/compiler/scalc/from_lcalc.ml
@ -259,7 +259,16 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
    when ctxt.config.keep_special_ops ->
    let exceptions =
      match Mark.remove exceptions with
-      | EArray exceptions -> exceptions
+      | EStruct { fields; _ } -> (
+        let _, exceptions =
+          List.find
+            (fun (field, _) ->
+              String.equal (Mark.remove (StructField.get_info field)) "content")
+            (StructField.Map.bindings fields)
+        in
+        match Mark.remove exceptions with
+        | EArray exceptions -> exceptions
+        | _ -> failwith "should not happen")
      | _ -> failwith "should not happen"
    in
    let just = unthunk just in
--- a/compiler/scalc/to_c.ml
+++ b/compiler/scalc/to_c.ml
@ -316,7 +316,7 @@ let format_op (fmt : Format.formatter) (op : operator Mark.pos) : unit =
  | HandleDefault -> Format.pp_print_string fmt "catala_handle_default"
  | HandleDefaultOpt | FromClosureEnv | ToClosureEnv -> failwith "unimplemented"

-let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
+let _format_string_list (fmt : Format.formatter) (uids : string list) : unit =
  let sanitize_quotes = Re.compile (Re.char '"') in
  Format.fprintf fmt "c(%a)"
    (Format.pp_print_list
@ -329,7 +329,6 @@ let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
 let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
    unit =
  match Mark.remove e with
-  | EVar v when v = Ast.dead_value -> Format.fprintf fmt "NULL"
  | EVar v -> format_var fmt v
  | EFunc f -> format_func_name fmt f
  | EStruct { fields = es; _ } ->
@ -346,12 +345,9 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
    Format.fprintf fmt "{%a_%a,@ {%a: %a}}" format_enum_name enum_name
      format_enum_cons_name cons format_enum_cons_name cons
      (format_expression ctx) e1
-  | EArray es ->
-    Format.fprintf fmt "list(%a)"
-      (Format.pp_print_list
-         ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
-         (fun fmt e -> Format.fprintf fmt "%a" (format_expression ctx) e))
-      es
+  | EArray _ ->
+    failwith
+      "should not happen, array initialization is caught at the statement level"
  | ELit l -> Format.fprintf fmt "%a" format_lit (Mark.copy e l)
  | EAppOp { op = (Map | Filter) as op; args = [arg1; arg2] } ->
    Format.fprintf fmt "%a(%a,@ %a)" format_op (op, Pos.no_pos)
@ -374,19 +370,6 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
      (format_expression ctx) arg1
  | EAppOp { op = HandleDefaultOpt | HandleDefault; args = _ } ->
    failwith "should not happen because of keep_special_ops"
-  | EApp { f = EFunc x, pos; args }
-    when Ast.FuncName.compare x Ast.handle_default = 0
-         || Ast.FuncName.compare x Ast.handle_default_opt = 0 ->
-    Format.fprintf fmt
-      "%a(@[<hov 0>catala_position(filename=\"%s\",@ start_line=%d,@ \
-       start_column=%d,@ end_line=%d, end_column=%d,@ law_headings=%a), %a)@]"
-      format_func_name x (Pos.get_file pos) (Pos.get_start_line pos)
-      (Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos)
-      format_string_list (Pos.get_law_info pos)
-      (Format.pp_print_list
-         ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
-         (format_expression ctx))
-      args
  | EApp { f; args } ->
    Format.fprintf fmt "%a(@[<hov 0>%a)@]" (format_expression ctx) f
      (Format.pp_print_list
@ -402,6 +385,15 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
  | ETuple _ | ETupleAccess _ ->
    Message.raise_internal_error "Tuple compilation to R unimplemented!"

+let typ_is_array (ctx : decl_ctx) (typ : typ) =
+  match Mark.remove typ with
+  | TStruct s_name ->
+    let fields = StructName.Map.find s_name ctx.ctx_structs in
+    StructField.Map.exists
+      (fun _ t -> match Mark.remove t with TArray _ -> true | _ -> false)
+      fields
+  | _ -> false
+
 let rec format_statement
    (ctx : decl_ctx)
    (fmt : Format.formatter)
@ -414,6 +406,13 @@ let rec format_statement
    Format.fprintf fmt "@[<hov 2>%a@];"
      (format_typ ctx (fun fmt -> format_var fmt (Mark.remove v)))
      ty
+    (* Below we detect array initializations which have special treatment. *)
+  | SLocalInit { name = v; expr = EStruct { fields; name }, _; typ }
+    when typ_is_array ctx typ ->
+    Format.fprintf fmt
+      "@[<hov 2>%a;@]@\n@[<hov 2>%a.content_field = malloc(sizeof(%a));@]"
+      (format_typ ctx (fun fmt -> format_var fmt (Mark.remove v)))
+      typ format_var (Mark.remove v) format_struct_name name
  | SLocalInit { name = v; expr = e; typ } ->
    Format.fprintf fmt "@[<hov 2>%a = %a;@]"
      (format_typ ctx (fun fmt -> format_var fmt (Mark.remove v)))
@ -470,15 +469,18 @@ let rec format_statement
    let pos = Mark.get s in
    Format.fprintf fmt
      "@[<hov 2>if (!(%a)) {@\n\
-       stop(catala_assertion_failure(@[<hov 0>catala_position(@[<hov \
-       0>filename=\"%s\",@ start_line=%d,@ start_column=%d,@ end_line=%d,@ \
-       end_column=%d,@ law_headings=@[<hv>%a@])@])@])@]@\n\
+       catala_fatal_error_raised.code = catala_assertion_failure;@,\
+       catala_fatal_error_raised.position.filename = \"%s\";@,\
+       catala_fatal_error_raised.position.start_line = %d;@,\
+       catala_fatal_error_raised.position.start_column = %d;@,\
+       catala_fatal_error_raised.position.end_line = %d;@,\
+       catala_fatal_error_raised.position.end_column = %d;@,\
+       longjmp(catala_fatal_error_jump_buffer, 0);@,\
       }"
      (format_expression ctx)
      (e1, Mark.get s)
      (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
-      (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
-      (Pos.get_law_info pos)
+      (Pos.get_end_line pos) (Pos.get_end_column pos)
  | SSpecialOp (OHandleDefaultOpt { exceptions; just; cons; return_typ }) ->
    let e_name =
      match Mark.remove return_typ with
--- a/compiler/shared_ast/typing.ml
+++ b/compiler/shared_ast/typing.ml
@ -310,12 +310,13 @@ let polymorphic_op_type (op : Operator.polymorphic A.operator Mark.pos) :
    | Log (PosRecordIfTrueBool, _) -> [bt] @-> bt
    | Log _ -> [any] @-> any
    | Length -> [array any] @-> it
-    | HandleDefault -> [array ([ut] @-> any); [ut] @-> bt; [ut] @-> any] @-> any
-    (* The [any] in this type definition should be [option any] but when
-       retyping after option monomorphization it would not work, so we let
-       unification instantiate a monomorphized option type at each new operator
-       instead. *)
-    | HandleDefaultOpt -> [array any; [ut] @-> bt; [ut] @-> any] @-> any
+    (* The [HandleDefault] and [HandleDefaultOpt] need to be typed before and
+       after the Lcalc monomorphization which affects arrays and option types.
+       Because of that, we give the operators very lax typing rules with [any]
+       but it doesn't matter for unification because the concrete types on which
+       they will be instantiated are stored in the [EAppOp] node. *)
+    | HandleDefault -> [any2; [ut] @-> bt; [ut] @-> any] @-> any
+    | HandleDefaultOpt -> [any2; [ut] @-> bt; [ut] @-> any] @-> any
    | ToClosureEnv -> [any] @-> cet
    | FromClosureEnv -> [cet] @-> any
  in
--- a/runtimes/c/runtime.c
+++ b/runtimes/c/runtime.c
@ -8,6 +8,7 @@ typedef enum catala_fatal_error_code
    catala_conflict,
    catala_crash,
    catala_empty,
+    catala_assertion_failure,
 } catala_fatal_error_code;

 typedef struct catala_code_position
--- a/tests/test_backends/main.c
+++ b/tests/test_backends/main.c
@ -62,6 +62,9 @@ int main()
        case catala_empty:
            error_kind = "Empty error not caught";
            break;
+        case catala_assertion_failure:
+            error_kind = "Asssertion failure";
+            break;
        }
        printf("\033[1;31m[ERROR]\033[0m %s in file %s:%d.%d-%d.%d\n",
               error_kind,
--- a/tests/test_backends/simple.catala_en
+++ b/tests/test_backends/simple.catala_en
@ -10,6 +10,7 @@ declaration enumeration Bar:
 declaration scope Baz:
  context a content Bar
  output b content decimal
+  output c content list of decimal

 scope Baz:
  definition a equals No
@ -22,4 +23,6 @@ scope Baz:
  exception definition b under condition
    a with pattern No
  consequence equals 42.0
+
+  definition c equals [b;b]
 ```