Fix OCaml compiler regressions

src/lib/ast/analysis_semantic.ml

@@ -91,6 +91,26 @@ module Semantic = struct
         | Core.VDecl _ | Core.TDecl _ | Core.Import _ | Core.CImport _ -> map)
       String_map.empty program.value.decls
 
+  let check_duplicate_function_definitions state (program : Core.program) =
+    let definitions = ref String_map.empty in
+    let check (fn : Core.function_decl) =
+      match fn.value.definition with
+      | None -> ()
+      | Some _ ->
+          let name = fn.value.name.value in
+          if String_map.mem name !definitions then
+            add_diagnostic state Error fn.loc
+              (Printf.sprintf "duplicate function definition %s" name)
+          else definitions := String_map.add name () !definitions
+    in
+    List.iter
+      (fun (decl : Core.top_decl) ->
+        match decl.value with
+        | Core.FDecl fn -> check fn
+        | Core.Foreign foreign -> List.iter check foreign.value.decls
+        | Core.VDecl _ | Core.TDecl _ | Core.Import _ | Core.CImport _ -> ())
+      program.value.decls
+
   let duplicate_binding env name =
     match env with
     | [] -> false
@@ -788,9 +808,6 @@ module Semantic = struct
         if not statement_context then
           add_diagnostic state Error expr.loc
             "mutation is statement-only and cannot be used as a value";
-        if not (is_lvalue write.value.target) then
-          add_diagnostic state Error expr.loc
-            "mutation target must be assignable";
         (match expr_annotation state write.value.target with
         | Some { resolved_type = Some resolved; _ } ->
             if not (resolved_is_pointerish resolved) then
@@ -843,6 +860,7 @@ module Semantic = struct
         functions = collect_functions typed.program.program;
       }
     in
+    check_duplicate_function_definitions state typed.program.program;
     let env = [ initial_scope typed ] in
     List.iter
       (fun (decl : Core.top_decl) ->

src/lib/ast/llvm_ir.ml

@@ -617,13 +617,60 @@ let create_string_literal t value =
   let zero = Llvm.const_int (i32_type t) 0 in
   Llvm.const_in_bounds_gep (Llvm.type_of init) global [| zero; zero |]
 
+let constant_is_signed = function
+  | Analysis.ResolvedInt (Haven_token.Token.Signed, _) -> true
+  | _ -> false
+
+let constant_cast t value source target =
+  if Analysis.equal_resolved_type source target then Some value
+  else
+    match (source, target) with
+    | Analysis.ResolvedInt _, Analysis.ResolvedInt (_, bits) ->
+        Option.map
+          (fun constant ->
+            Llvm.const_of_int64
+              (Llvm.integer_type t.context bits)
+              constant (constant_is_signed source))
+          (Llvm.int64_of_const value)
+    | Analysis.ResolvedInt _, Analysis.ResolvedFloat ->
+        Option.map
+          (fun constant ->
+            Llvm.const_float (float_type t) (Int64.to_float constant))
+          (Llvm.int64_of_const value)
+    | Analysis.ResolvedFloat, Analysis.ResolvedInt (_, bits) ->
+        Option.map
+          (fun constant ->
+            Llvm.const_of_int64
+              (Llvm.integer_type t.context bits)
+              (Int64.of_float constant) (constant_is_signed target))
+          (Llvm.float_of_const value)
+    | source, target
+      when Analysis.resolved_is_pointerish source
+           && Analysis.resolved_is_pointerish target ->
+        Some (Llvm.const_pointercast value (ptr_type t))
+    | source, Analysis.ResolvedInt (_, bits)
+      when Analysis.resolved_is_pointerish source ->
+        Some
+          (Llvm.const_ptrtoint value
+             (Llvm.integer_type t.context bits))
+    | Analysis.ResolvedInt _, target
+      when Analysis.resolved_is_pointerish target ->
+        Some (Llvm.const_inttoptr value (ptr_type t))
+    | _ -> None
+
 let rec constant_of_expr t (expr : Core.expression) =
   let resolved = expr_resolved_type t expr in
   match expr.value with
   | Core.Literal lit -> constant_of_literal t expr.loc resolved lit
   | Core.Nil when Analysis.resolved_is_pointerish resolved ->
       Some (Llvm.const_null (llvm_type_of_resolved t resolved))
-  | Core.As cast -> constant_of_expr t cast.value.inner
+  | Core.As cast ->
+      Option.bind
+        (constant_of_expr t cast.value.inner)
+        (fun value ->
+          constant_cast t value
+            (expr_resolved_type t cast.value.inner)
+            resolved)
   | Core.SizeExpr inner ->
       let size =
         Llvm_target.DataLayout.abi_size
@@ -1557,6 +1604,13 @@ and emit_enum_literal t (expr : Core.expression) (enum_lit : Core.enum_literal)
   | _ -> fail ~loc:expr.loc "enum literal requires enum type during LLVM lowering"
 
 and emit_binary t (expr : Core.expression) (binary : Core.binary) =
+  match binary.value.op with
+  | Core.LogicAnd | Core.LogicOr ->
+      emit_logical_binary t expr binary
+  | _ ->
+      emit_eager_binary t expr binary
+
+and emit_eager_binary t (expr : Core.expression) (binary : Core.binary) =
   let lhs = emit_expr t binary.value.left in
   let rhs = emit_expr t binary.value.right in
   let lhs_ty = expr_resolved_type t binary.value.left in
@@ -1590,34 +1644,39 @@ and emit_binary t (expr : Core.expression) (binary : Core.binary) =
         | _ -> assert false
       in
       Llvm.build_fcmp pred lhs rhs "fcmp" t.builder
-  | ( Core.LogicAnd | Core.LogicOr ), _, _, Analysis.ResolvedInt (_, 1) ->
-      let lhs_bool = emit_to_bool t binary.value.left lhs in
-      let current_block = Llvm.insertion_block t.builder in
-      let fn_value = Llvm.block_parent current_block in
-      let rhs_block = Llvm.append_block t.context "logic.rhs" fn_value in
-      let end_block = Llvm.append_block t.context "logic.end" fn_value in
-      ignore
-        (Llvm.build_cond_br lhs_bool
-           (if binary.value.op = Core.LogicAnd then rhs_block else end_block)
-           (if binary.value.op = Core.LogicAnd then end_block else rhs_block)
-           t.builder);
-      Llvm.position_at_end rhs_block t.builder;
-      let rhs_value = emit_expr t binary.value.right in
-      let rhs_bool = emit_to_bool t binary.value.right rhs_value in
-      let rhs_block_final = Llvm.insertion_block t.builder in
-      ignore (Llvm.build_br end_block t.builder);
-      Llvm.position_at_end end_block t.builder;
-      let incoming =
-        if binary.value.op = Core.LogicAnd then
-          [ (Llvm.const_int (i1_type t) 0, current_block); (rhs_bool, rhs_block_final) ]
-        else
-          [ (Llvm.const_int (i1_type t) 1, current_block); (rhs_bool, rhs_block_final) ]
-      in
-      Llvm.build_phi incoming "logic.phi" t.builder
   | _, _, _, (Analysis.ResolvedVec _ | Analysis.ResolvedMatrix _) ->
       emit_vector_or_matrix_binary t expr binary lhs rhs lhs_ty rhs_ty result_ty
   | _ -> emit_nonfloat_binary t expr binary lhs rhs lhs_ty rhs_ty result_ty
 
+and emit_logical_binary t (expr : Core.expression) (binary : Core.binary) =
+  let result_ty = expr_resolved_type t expr in
+  if not (Analysis.equal_resolved_type result_ty (Analysis.ResolvedInt (Unsigned, 1))) then
+    fail ~loc:expr.loc "logical operator lowering bug";
+  let lhs = emit_expr t binary.value.left in
+  let lhs_bool = emit_to_bool t binary.value.left lhs in
+  let current_block = Llvm.insertion_block t.builder in
+  let fn_value = Llvm.block_parent current_block in
+  let rhs_block = Llvm.append_block t.context "logic.rhs" fn_value in
+  let end_block = Llvm.append_block t.context "logic.end" fn_value in
+  ignore
+    (Llvm.build_cond_br lhs_bool
+       (if binary.value.op = Core.LogicAnd then rhs_block else end_block)
+       (if binary.value.op = Core.LogicAnd then end_block else rhs_block)
+       t.builder);
+  Llvm.position_at_end rhs_block t.builder;
+  let rhs_value = emit_expr t binary.value.right in
+  let rhs_bool = emit_to_bool t binary.value.right rhs_value in
+  let rhs_block_final = Llvm.insertion_block t.builder in
+  ignore (Llvm.build_br end_block t.builder);
+  Llvm.position_at_end end_block t.builder;
+  let incoming =
+    if binary.value.op = Core.LogicAnd then
+      [ (Llvm.const_int (i1_type t) 0, current_block); (rhs_bool, rhs_block_final) ]
+    else
+      [ (Llvm.const_int (i1_type t) 1, current_block); (rhs_bool, rhs_block_final) ]
+  in
+  Llvm.build_phi incoming "logic.phi" t.builder
+
 and emit_nonfloat_binary t (expr : Core.expression) binary lhs rhs lhs_ty rhs_ty result_ty =
   let cast_to_result lhs rhs =
     if Analysis.resolved_is_numeric result_ty then
@@ -2285,7 +2344,8 @@ let declare_global_symbol t (decl : Core.var_decl) =
     (if decl.value.public then Llvm.Linkage.External else Llvm.Linkage.Internal)
     storage;
   Llvm.set_global_constant (not decl.value.is_mutable) storage;
-  if decl.value.init_expr = None then Llvm.set_initializer (zero_constant t resolved) storage;
+  if decl.value.init_expr = None && not decl.value.public then
+    Llvm.set_initializer (zero_constant t resolved) storage;
   let symbol =
     Variable_symbol
       { storage; resolved_type = resolved; is_mutable = decl.value.is_mutable }
@@ -2327,13 +2387,16 @@ let lower_global_initializer t (decl : Core.var_decl) =
   | Variable_symbol { storage; resolved_type; _ } -> (
       match decl.value.init_expr with
       | None ->
-          Llvm.set_initializer (zero_constant t resolved_type) storage;
-          t.global_inits_rev <- { decl; storage } :: t.global_inits_rev
+          if not decl.value.public then (
+            Llvm.set_global_constant false storage;
+            Llvm.set_initializer (zero_constant t resolved_type) storage;
+            t.global_inits_rev <- { decl; storage } :: t.global_inits_rev)
       | Some init -> (
           match constant_of_expr t init with
           | Some constant ->
               Llvm.set_initializer constant storage
           | None ->
+              Llvm.set_global_constant false storage;
               Llvm.set_initializer (zero_constant t resolved_type) storage;
               t.global_inits_rev <- { decl; storage } :: t.global_inits_rev))
   | Function_symbol _ -> fail "global %s unexpectedly resolved to function" decl.value.name.value

src/lib/parser/grammar.mly

@@ -46,7 +46,7 @@
 %left LT GT LE GE
 %left LSHIFT RSHIFT
 %left PLUS MINUS
-%left MULITPLY DIVIDE MODULO
+%left STAR SLASH PERCENT
 %nonassoc UMINUS BANG TILDE
 
 %start <program> program
@@ -210,9 +210,9 @@ expr:
   | l=expr WALRUS r=expr { mk_binary $startpos $endpos Mutate l r }
   | l=expr PLUS r=expr { mk_binary $startpos $endpos Add l r }
   | l=expr MINUS r=expr { mk_binary $startpos $endpos Subtract l r }
-  | l=expr STAR r=expr %prec MULITPLY { mk_binary $startpos $endpos Multiply l r }
-  | l=expr SLASH r=expr %prec DIVIDE { mk_binary $startpos $endpos Divide l r }
-  | l=expr PERCENT r=expr %prec MODULO { mk_binary $startpos $endpos Modulo l r }
+  | l=expr STAR r=expr { mk_binary $startpos $endpos Multiply l r }
+  | l=expr SLASH r=expr { mk_binary $startpos $endpos Divide l r }
+  | l=expr PERCENT r=expr { mk_binary $startpos $endpos Modulo l r }
   | l=expr AMP r=expr %prec BITWISE_AND { mk_binary $startpos $endpos BitwiseAnd l r }
   | l=expr CARET r=expr %prec BITWISE_XOR { mk_binary $startpos $endpos BitwiseXor l r }
   | l=expr PIPE r=expr %prec BITWISE_OR { mk_binary $startpos $endpos BitwiseOr l r }
@@ -328,12 +328,12 @@ identifier: i=IDENT { mk_id i $startpos $endpos } ;
 
 haven_type:
   | t=type_primary { t }
-  | t=type_primary STAR { mk_loc $startpos $endpos (PointerType t) }
-  | t=type_primary CARET {
+  | t=haven_type STAR { mk_loc $startpos $endpos (PointerType t) }
+  | t=haven_type CARET {
       let ty : haven_type_desc = BoxType t in
       mk_loc $startpos $endpos ty
     }
-  | t=type_primary LBRACKET c=integer_literal RBRACKET { mk_loc $startpos $endpos (ArrayType (mk_loc $startpos $endpos { element = t; count = c })) }
+  | t=haven_type LBRACKET c=integer_literal RBRACKET { mk_loc $startpos $endpos (ArrayType (mk_loc $startpos $endpos { element = t; count = c })) }
   ;
 
 type_primary:

src/test/test_llvm_ir.ml

@@ -123,6 +123,38 @@ let run () =
     (string_contains ctor_ir "@llvm.global_ctors");
   assert_true "non-constant globals should emit the init function"
     (string_contains ctor_ir "@__haven_global_init");
+  assert_true "startup-initialized data must remain writable in LLVM"
+    (string_contains ctor_ir "@GLOBAL = internal global i32 0");
+
+  let external_ir =
+    emit_ir
+      "pub state i32 supplied_elsewhere;\npub fn read() -> i32 { supplied_elsewhere }"
+  in
+  assert_true "initializer-less public state should remain an external declaration"
+    (string_contains external_ir "@supplied_elsewhere = external global i32");
+  assert_true "external declarations should not synthesize startup initialization"
+    (not (string_contains external_ir "@__haven_global_init"));
+
+  let constant_cast_ir =
+    emit_ir
+      "data u32 ZERO = as<u32>(0);\npub fn main() -> u32 { ZERO }"
+  in
+  assert_true "constant casts should match the declared global type"
+    (string_contains constant_cast_ir "@ZERO = internal constant i32 0");
+
+  let short_circuit_ir =
+    emit_ir
+      {|
+state i32 calls = 0;
+impure fn rhs() -> i32 {
+  calls = calls + 1;
+  1
+}
+pub impure fn test() -> i1 { 0 && rhs() }
+|}
+  in
+  assert_true "logical RHS should only be emitted in the conditional block"
+    (count_occurrences short_circuit_ir "call i32 @rhs()" = 1);
 
   let box_ir = emit_ir "pub fn forward(i32^ input) -> i32^ { defer unbox input; input }" in
   assert_true "box ownership should call box ref"

src/test/test_parser.ml

@@ -16,6 +16,12 @@ let run () =
   assert_parse_ok "specialization hole parameter types"
     "fn vadd(fvec? a, mat? b) { a }";
 
+  assert_parse_ok "nested pointer type"
+    "pub fn follow(i8** cursor) -> i8* { load cursor }";
+
+  assert_parse_ok "composed pointer and array postfixes"
+    "pub fn first(i8*[2] values) -> i8* { values[0] }";
+
   assert_parse_ok "compile-time assert statement"
     "fn vadd(fvec? a, fvec? b) { @assert a.dim == b.dim, \"dims must match\"; a + b }";
 
@@ -93,6 +99,18 @@ extend Buffer with {
   assert_true "specialization function should keep omitted return type through core conversion"
     (specialized_fn.value.return_type = None);
 
+  let associativity_core =
+    parse_to_core "pub fn calculate() -> i32 { 15 * 100 / 400 }"
+  in
+  let calculate_fn = find_named_function "calculate" associativity_core in
+  (match Option.bind calculate_fn.value.definition (fun body -> body.value.result) with
+  | Some { value = Core.Binary divide; _ }
+    when divide.value.op = Core.Divide -> (
+      match divide.value.left.value with
+      | Core.Binary multiply when multiply.value.op = Core.Multiply -> ()
+      | _ -> failwith "expected multiplication to be the left operand of division")
+  | _ -> failwith "expected same-tier arithmetic operators to associate left");
+
   let assert_core =
     parse_to_core
       "fn vadd(fvec? a, fvec? b) { @assert a.dim == b.dim, \"dims must match\"; a + b }"

src/test/test_rc.ml

@@ -18,7 +18,9 @@ let rc_cases =
     { name = "add"; expected_rc = 6 };
     { name = "prec1"; expected_rc = 90 };
     { name = "prec2"; expected_rc = 0 };
+    { name = "associativity"; expected_rc = 3 };
     { name = "shortcircuit"; expected_rc = 1 };
+    { name = "cast_mutate"; expected_rc = 7 };
     { name = "constant"; expected_rc = 0 };
     { name = "struct"; expected_rc = 3 };
     { name = "match"; expected_rc = 0 };

src/test/test_typing_semantics.ml

@@ -1,6 +1,17 @@
 open Test_support
 
 let run () =
+  let duplicate_function_pipeline =
+    parse_to_core
+      "fn duplicate() -> i32 { 1 }\nfn duplicate() -> i32 { 2 }\npub fn main() -> i32 { duplicate() }"
+    |> Analysis.Pipeline.run_core
+  in
+  assert_has_diagnostics "duplicate function definitions should fail semantic analysis"
+    duplicate_function_pipeline.semantic.diagnostics;
+  assert_any_diagnostic_message_contains "duplicate function definition wording"
+    "duplicate function definition duplicate"
+    duplicate_function_pipeline.semantic.diagnostics;
+
   let bad_semantics =
     parse_to_core "pub fn main() -> void { break; }" |> Analysis.Pipeline.run_core
   in

tests/inputs/associativity.hv

@@ -0,0 +1,3 @@
+pub fn sut() -> i32 {
+    15 * 100 / 400
+}

tests/inputs/cast_mutate.hv

@@ -0,0 +1,6 @@
+pub impure fn sut() -> i32 {
+    let mut i32 value = 0;
+    let i8* raw = as<i8*>(ref value);
+    as<i32*>(raw) := 7;
+    value
+}

tests/inputs/shortcircuit.hv

@@ -1,11 +1,18 @@
-pub fn and() -> i32 {
-    as<i32>(0 && (1 / 0))
+state i32 calls = 0;
+
+impure fn rhs() -> i32 {
+    calls = calls + 10;
+    1
+}
+
+impure fn and() -> i32 {
+    as<i32>(0 && rhs())
 }
 
-pub fn or() -> i32 {
-    as<i32>(1 || (1 / 0))
+impure fn or() -> i32 {
+    as<i32>(1 || rhs())
 }
 
-pub fn sut() -> i32 {
+pub impure fn sut() -> i32 {
     and() + or()
-}
+}