Rework array_drop_back

to `array_pop_back` which moves the last element out to an `option[elem]`

lib/builtin.ml

@@ -27,7 +27,7 @@ type t =
   | Mod
   | Array_get
   | Array_length
-  | Array_drop_back
+  | Unsafe_array_pop_back
   | Array_data
   | Array_capacity
   | Fixed_array_get
@@ -157,9 +157,9 @@ let tbl =
           Simple ) );
   Hashtbl.add tbl "__array_length"
     (Array_length, Tfun ([ { p with pt = tarray (Qvar "0") } ], tint, Simple));
-  Hashtbl.add tbl "__array_drop_back"
-    ( Array_drop_back,
-      Tfun ([ { pt = tarray (Qvar "0"); pattr = Dmut } ], tunit, Simple) );
+  Hashtbl.add tbl "__unsafe_array_pop_back"
+    ( Unsafe_array_pop_back,
+      Tfun ([ { pt = tarray (Qvar "0"); pattr = Dmut } ], Qvar "0", Simple) );
   Hashtbl.add tbl "__array_data"
     ( Array_data,
       Tfun ([ { p with pt = tarray (Qvar "0") } ], traw_ptr (Qvar "0"), Simple)

lib/codegen/arr.ml

@@ -195,7 +195,9 @@ struct
 
     { dummy_fn_value with lltyp = unit_t }
 
-  let array_drop_back param args =
+  let unsafe_array_pop_back param args allocref =
+    (* We assume there is at least one item, and don't actually check the size.
+       But we do decrease the size of the array by one. *)
     let arr =
       match args with
       | [ arr ] -> arr
@@ -206,31 +208,21 @@ struct
     let dst = Llvm.build_gep int_t arr.value [| ci 0 |] "size" builder in
     let sz = Llvm.build_load int_t dst "size" builder in
 
-    let start_bb = Llvm.insertion_block builder in
-    let parent = Llvm.block_parent start_bb in
-
-    let drop_last_bb = Llvm.append_block context "drop_last" parent in
-    let cont_bb = Llvm.append_block context "cont" parent in
-
-    let cmp = Llvm.(build_icmp Icmp.Sgt) sz (ci 0) "" builder in
-    ignore (Llvm.build_cond_br cmp drop_last_bb cont_bb builder);
-
-    Llvm.position_at_end drop_last_bb builder;
     let index = Llvm.build_sub sz (ci 1) "" builder in
+    ignore (Llvm.build_store index dst builder);
+
     let ptr = data_get arr.value arr.typ (Idyn index) in
 
     let item_typ = item_type arr.typ in
     let llitem_typ = get_lltype_def item_typ in
 
-    Auto.free param
-      { value = ptr; kind = Ptr; typ = item_typ; lltyp = llitem_typ };
+    let v = { value = ptr; kind = Ptr; lltyp = llitem_typ; typ = item_typ } in
+    let src = bring_default_var v in
 
-    ignore (Llvm.build_store index dst builder);
-    ignore (Llvm.build_br cont_bb builder);
+    let dst = get_prealloc !allocref param llitem_typ "" in
 
-    Llvm.position_at_end cont_bb builder;
-
-    { dummy_fn_value with lltyp = unit_t }
+    store_or_copy ~src ~dst;
+    { v with value = dst; kind = Ptr }
 
   let array_data args =
     let arr =

lib/codegen/arr_intf.ml

@@ -22,7 +22,10 @@ module type S = sig
   val array_length : unsafe:bool -> llvar list -> llvar
   val array_capacity : llvar list -> llvar
   val array_realloc : llvar list -> llvar
-  val array_drop_back : param -> llvar list -> llvar
+
+  val unsafe_array_pop_back :
+    param -> llvar list -> Monomorph_tree.alloca -> llvar
+
   val array_data : llvar list -> llvar
 
   val unsafe_array_create :

lib/codegen/codegen.ml

@@ -750,7 +750,7 @@ end = struct
     | Array_get -> array_get args fnc.ret
     | Array_length -> array_length ~unsafe:false args
     | Unsafe_array_length -> array_length ~unsafe:true args
-    | Array_drop_back -> array_drop_back param args
+    | Unsafe_array_pop_back -> unsafe_array_pop_back param args allocref
     | Array_data -> array_data args
     | Array_capacity -> array_capacity args
     | Fixed_array_get -> (

lib/map_module.ml

@@ -10,7 +10,7 @@ module type Map_tree = sig
 
   val map_decl : mname:Path.t -> string -> sub -> type_decl -> sub * type_decl
   val absolute_module_name : mname:Path.t -> string -> string
-  val map_type : sub -> typ -> sub * typ
+  val map_type : mname:Path.t -> sub -> typ -> sub * typ
 end
 
 module Canonize = struct
@@ -69,7 +69,7 @@ end
 
 module Make (C : Map_tree) = struct
   let rec map_body mname nsub sub (e : Typed_tree.typed_expr) =
-    let sub, typ = C.map_type sub e.typ in
+    let sub, typ = C.map_type ~mname sub e.typ in
     let sub, expr = map_expr mname nsub sub e.expr in
     (sub, Typed_tree.{ e with typ; expr })
 
@@ -116,7 +116,7 @@ module Make (C : Map_tree) = struct
         let sub, fs =
           List.fold_left_map
             (fun sub (n, u, t) ->
-              let sub, t = C.map_type sub t in
+              let sub, t = C.map_type ~mname sub t in
               (sub, (n, u, t)))
             sub fs
         in
@@ -188,19 +188,19 @@ module Make (C : Map_tree) = struct
     let sub, tparams =
       List.fold_left_map
         (fun sub p ->
-          let sub, pt = C.map_type sub p.pt in
+          let sub, pt = C.map_type ~mname sub p.pt in
           (sub, { p with pt }))
         sub abs.func.tparams
     in
-    let sub, ret = C.map_type sub abs.func.ret in
+    let sub, ret = C.map_type ~mname sub abs.func.ret in
     let sub, kind =
       match abs.func.kind with
       | Simple -> (sub, Simple)
       | Closure l ->
           let sub, l =
             List.fold_left_map
               (fun sub c ->
-                let sub, cltyp = C.map_type sub c.cltyp in
+                let sub, cltyp = C.map_type ~mname sub c.cltyp in
                 let clname, clmname =
                   C.change_var ~mname c.clname c.clmname sub
                 in
@@ -212,7 +212,7 @@ module Make (C : Map_tree) = struct
     let sub, touched =
       List.fold_left_map
         (fun sub t ->
-          let sub, ttyp = C.map_type sub Typed_tree.(t.ttyp) in
+          let sub, ttyp = C.map_type ~mname sub Typed_tree.(t.ttyp) in
           (sub, { t with ttyp }))
         sub abs.func.touched
     in
@@ -247,7 +247,7 @@ module Make (C : Map_tree) = struct
         let sub, decls =
           List.fold_left_map
             (fun sub (n, u, t) ->
-              let sub, t = C.map_type sub t in
+              let sub, t = C.map_type ~mname sub t in
               (sub, (n, u, t)))
             sub decls
         in
@@ -261,10 +261,10 @@ module Make (C : Map_tree) = struct
         let sub, decl = C.map_decl ~mname n sub decl in
         ((sub, nsub), Mtype (l, n, decl))
     | Mfun (l, t, n) ->
-        let a, t = C.map_type sub t in
+        let a, t = C.map_type ~mname sub t in
         ((a, nsub), Mfun (l, t, n))
     | Mext (l, t, n, c) ->
-        let a, t = C.map_type sub t in
+        let a, t = C.map_type ~mname sub t in
         ((a, nsub), Mext (l, t, n, c))
     | Mpoly_fun (l, abs, n, u) ->
         (* Change Var-nodes in body here *)
@@ -277,7 +277,7 @@ module Make (C : Map_tree) = struct
         let (a, nsub), decls =
           List.fold_left_map
             (fun (sub, nsub) (l, n, u, t) ->
-              let a, t = C.map_type sub t in
+              let a, t = C.map_type ~mname sub t in
               ((a, nsub), (l, n, u, t)))
             (sub, nsub) decls
         in
@@ -323,7 +323,7 @@ module Make (C : Map_tree) = struct
         let sub, decl = C.map_decl ~mname n sub decl in
         (sub, Mtypedef decl)
     | Mvalue (typ, cn) ->
-        let sub, typ = C.map_type sub typ in
+        let sub, typ = C.map_type ~mname sub typ in
         (sub, Mvalue (typ, cn))
 
   and map_intf mname sub intf =

lib/module.ml

@@ -145,7 +145,7 @@ module Map_canon : Map_module.Map_tree = struct
     | None | Some _ -> ());
     (id, m)
 
-  let map_decl ~mname _ sub decl =
+  let load_type ~mname typ =
     let rec load_type = function
       | Tconstr (name, _) -> (
           match Path.rm_head name with
@@ -158,6 +158,10 @@ module Map_canon : Map_module.Map_tree = struct
           load_type ret
       | Ttuple ts -> List.iter load_type ts
     in
+    load_type typ
+
+  let map_decl ~mname _ sub decl =
+    let load_type = load_type ~mname in
 
     let rec map_kind = function
       | Dalias typ -> load_type typ
@@ -172,7 +176,10 @@ module Map_canon : Map_module.Map_tree = struct
     (sub, decl)
 
   let absolute_module_name = absolute_module_name
-  let map_type = Map_module.Canonize.canonize
+
+  let map_type ~mname sub typ =
+    load_type ~mname typ;
+    Map_module.Canonize.canonize sub typ
 end
 
 module Canon = Map_module.Make (Map_canon)

lib/typing/exclusivity.ml

@@ -23,7 +23,12 @@ module Contains_allocation = struct
                false ts)
         then
           (* Unparameterized types can also contain allocations *)
-          let decl = get_decl name in
+          let decl =
+            try get_decl name
+            with Not_found ->
+              print_endline (Path.show name);
+              failwith "med"
+          in
           let sub = map_params ~inst:ts ~params:decl.params in
           let rec check_decl decl_kind =
             match decl_kind with

lib/typing/typing.ml

@@ -1416,7 +1416,7 @@ struct
           let sub, fields =
             Array.fold_left_map
               (fun sub f ->
-                let sub, ftyp = map_type sub f.ftyp in
+                let sub, ftyp = map_type ~mname sub f.ftyp in
                 (sub, { f with ftyp }))
               sub fields
           in
@@ -1427,7 +1427,7 @@ struct
               (fun sub ct ->
                 match ct.ctyp with
                 | Some typ ->
-                    let sub, ctyp = map_type sub typ in
+                    let sub, ctyp = map_type ~mname sub typ in
                     (sub, { ct with ctyp = Some ctyp })
                 | None -> (sub, ct))
               sub ctors
@@ -1441,7 +1441,7 @@ struct
           in
           (sub, Dabstract (Some Types.(decl.kind)))
       | Dalias typ ->
-          let sub, typ = map_type sub typ in
+          let sub, typ = map_type ~mname sub typ in
           (sub, Dalias typ)
       | Dabstract None -> (sub, Dabstract None)
     in
@@ -1476,7 +1476,7 @@ module Subst_functor_impl (* : Map_module.Map_tree *) = struct
 
   let absolute_module_name = Module.absolute_module_name
 
-  let map_type (find_type, subs, decls) typ =
+  let map_type ~mname:_ (find_type, subs, decls) typ =
     let typ =
       List.fold_left
         (fun typ { base; with_ } -> apply_pathsub ~base ~with_ typ)
@@ -1506,7 +1506,7 @@ module Resolve_aliases_impl (* : Map_module.Map_tree *) = struct
 
   let absolute_module_name = Module.absolute_module_name
 
-  let map_type (find_type, subs, decls) typ =
+  let map_type ~mname:_ (find_type, subs, decls) typ =
     (* Use aliases if they are available *)
     let typ = resolve_alias (find_type decls) typ in
     ((find_type, subs, decls), typ)

std/array.smu

@@ -1,7 +1,7 @@
+import option
 import prelude
 
 let data = __array_data
-let drop_back = __array_drop_back
 let length = __array_length
 
 use prelude
@@ -95,6 +95,16 @@ fun map(arr, f) {
   inner(!ret, 0)
 }
 
+fun pop_back(arr&) {
+  use option
+  if length(arr) == 0 {
+    #none
+  }
+  else {
+    #some(__unsafe_array_pop_back(&arr))
+  }
+}
+
 fun swap_items(arr&, i, j) {
   if not (i == j) {
     let itmp = !arr.[i]
@@ -108,7 +118,7 @@ fun clear(arr&) {
     if 0 == length(arr) {
       ()
     } else {
-      drop_back(&arr)
+      pop_back(&arr).ignore()
       inner()
     }
   }

std/dune

@@ -7,7 +7,7 @@
 
 (rule
  (targets array.o array.smi)
- (deps %{bin:schmu} array.smu prelude.smi)
+ (deps %{bin:schmu} array.smu prelude.smi option.smi)
  (action
   (progn
    (run schmu -m --no-std array.smu))))

std/string.smu

@@ -68,7 +68,7 @@ fun concat(delim, strings) {
     append(&ret, str)
   })
   array/push(&ret, !'\000')
-  array/drop_back(&ret)
+  array/pop_back(&ret).ignore()
   ret
 }
 

test/functions.t/closure_inference.smu

@@ -20,7 +20,7 @@ fun string_of_view(view) {
     array/push(&ret, !string/get(view.pbuf, c))
   })
   array/push(&ret, !'\000')
-  array/drop_back(&ret)
+  array/pop_back(&ret).ignore()
   ret
 }
 

test/functions.t/polymorphic_lambda_argument.smu

@@ -3,7 +3,7 @@ let arr = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]
 fun string_add_null(str&) {
   string/modify_buf(&str, fun(arr&) {
     array/push(&arr, !0u8)
-    array/drop_back(&arr)
+    array/pop_back(&arr).ignore()
   })
 }