make make-vector future-safe

One interesting corner case is when a vector is allocated
in a way that would exceed a memory limit. The custodian
captured with a future is used to guard large allocations.

racket/src/racket/gc2/gc2.h

@@ -163,9 +163,15 @@ GC2_EXTERN int GC_set_account_hook(int type, void *c1, uintptr_t b, void *c2);
 
 GC2_EXTERN uintptr_t GC_get_account_memory_limit(void *c1);
 /*
-  Returns a moemory accounting limit for c1 (or any ancestor),
+  Returns a memory accounting limit for c1 (or any ancestor),
   or 0 if none is set. */
 
+GC2_EXTERN void GC_set_accounting_custodian(void *c);
+/*
+  Sets a custodian for checking memory limits for the next allocation.
+  This custodian should be cleared when allocation returns, but it
+  will be reset to NULL if a GC is triggered. */
+
 GC2_EXTERN void GC_gcollect(void);
 GC2_EXTERN void GC_gcollect_minor(void);
 /*

racket/src/racket/gc2/mem_account.c

@@ -145,7 +145,7 @@ inline static int create_blank_owner_set(NewGC *gc)
   return create_blank_owner_set(gc);
 }
 
-inline static int custodian_to_owner_set(NewGC *gc,Scheme_Custodian *cust)
+inline static int custodian_to_owner_set(NewGC *gc, Scheme_Custodian *cust)
 {
   int i;
 
@@ -878,11 +878,16 @@ int BTC_single_allocation_limit(NewGC *gc, size_t sizeb)
  * GC_out_of_memory protects any user-requested allocation whose size
  * is independent of any existing object, then we can enforce the limit. */
 {
-  Scheme_Thread *p = scheme_current_thread;
+  if (gc->alternate_accounting_custodian) {
-  if (p)
+    int set = custodian_to_owner_set(gc, gc->alternate_accounting_custodian);
-    return (custodian_single_time_limit(gc, thread_get_owner(p)) < sizeb);
+    return (custodian_single_time_limit(gc, set) < sizeb);
-  else
+  } else {
-    return (gc->place_memory_limit < sizeb);
+    Scheme_Thread *p = scheme_current_thread;
+    if (p)
+      return (custodian_single_time_limit(gc, thread_get_owner(p)) < sizeb);
+    else
+      return (gc->place_memory_limit < sizeb);
+  }
 }
 
 static uintptr_t BTC_get_account_hook(void *c1)

racket/src/racket/gc2/newgc.c

@@ -230,6 +230,11 @@ inline static void out_of_memory_gc(NewGC* gc) {
   out_of_memory();
 }
 
+void GC_set_accounting_custodian(void *c) {
+  NewGC *gc = GC_get_GC();
+  gc->alternate_accounting_custodian = c;
+}
+
 /*****************************************************************************/
 /* OS-level memory management                                                */
 /*                                                                           */
@@ -1289,11 +1294,13 @@ static void *allocate_big(const size_t request_size_bytes, int type)
   if (GC_gen0_alloc_only) return NULL;
 
 #ifdef NEWGC_BTC_ACCOUNT
-  if(GC_out_of_memory) {
+  if (GC_out_of_memory || gc->alternate_accounting_custodian) {
     if (premaster_or_place_gc(gc)) {
       if (BTC_single_allocation_limit(gc, request_size_bytes)) {
         /* We're allowed to fail. Check for allocations that exceed a single-time
            limit. See BTC_single_allocation_limit() for more information. */
+        if (gc->alternate_accounting_custodian)
+          return NULL;
         GC_out_of_memory();
       }
     }
@@ -5502,6 +5509,8 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full,
   gc->mark_gen1 = (gc->gc_full || gc->started_incremental) && !gc->all_marked_incremental;
   gc->check_gen1 = gc->gc_full && !gc->all_marked_incremental;
 
+  gc->alternate_accounting_custodian = NULL;
+
   /* ------------------------------------------------------------ */
   /* Prepare                                                      */
 

racket/src/racket/gc2/newgc.h

@@ -337,6 +337,7 @@ typedef struct NewGC {
   GC_Post_Propagate_Hook_Proc GC_post_propagate_hook;
   GC_Treat_As_Incremental_Mark_Proc treat_as_incremental_mark_hook;
   short treat_as_incremental_mark_tag;
+  void *alternate_accounting_custodian;
 
   GC_Immobile_Box *immobile_boxes;
 

racket/src/racket/src/future.c

@@ -432,6 +432,10 @@ static void init_cpucount(void);
 # define scheme_future_longjmp(newbuf, v) scheme_longjmp(newbuf, v)
 #endif
 
+#ifndef MZ_PRECISE_GC
+# define GC_set_accounting_custodian(c) /* nothing */
+#endif
+
 /**********************************************************************/
 /* Arguments for a newly created future thread                        */
 /**********************************************************************/
@@ -3145,6 +3149,35 @@ Scheme_Structure *scheme_rtcall_allocate_structure(int count, Scheme_Struct_Type
   return (Scheme_Structure *)retval;
 }
 
+Scheme_Object *scheme_rtcall_allocate_vector(int count)
+  XFORM_SKIP_PROC
+/* Called in future thread */
+{
+  Scheme_Future_Thread_State *fts = scheme_future_thread_state;
+  future_t *future = fts->thread->current_ft;
+  Scheme_Object *retval;
+
+  future->prim_protocol = SIG_ALLOC_VECTOR;
+
+  future->arg_i0 = count;
+
+  future->time_of_request = get_future_timestamp();
+  future->source_of_request = "[allocate_structure]";
+  future->source_type = FSRC_OTHER;
+
+  future_do_runtimecall(fts, NULL, 1, 0, 0);
+
+  /* Fetch the future again, in case moved by a GC */
+  future = fts->thread->current_ft;
+
+  future->arg_s0 = NULL;
+
+  retval = future->retval_s;
+  future->retval_s = NULL;
+
+  return retval;
+}
+
 Scheme_Object *scheme_rtcall_tail_apply(Scheme_Object *rator, int argc, Scheme_Object **argv)
   XFORM_SKIP_PROC
 /* Called in future thread */
@@ -3535,6 +3568,28 @@ static void do_invoke_rtcall(Scheme_Future_State *fs, future_t *future)
 
         future->retval_s = (Scheme_Object *)res;
 
+        break;
+      }
+    case SIG_ALLOC_VECTOR:
+      {
+        GC_CAN_IGNORE Scheme_Object *res;
+        intptr_t count = future->arg_i0;
+
+        future->arg_s0 = NULL;
+
+        GC_set_accounting_custodian(future->cust);
+
+        res = scheme_malloc_tagged(sizeof(Scheme_Vector)
+                                   + ((count - mzFLEX_DELTA) * sizeof(Scheme_Object *)));
+        if (res) {
+          res->type = scheme_vector_type;
+          SCHEME_VEC_SIZE(res) = count;
+        }
+
+        GC_set_accounting_custodian(NULL);
+
+        future->retval_s = res;
+
         break;
       }
     case SIG_TAIL_APPLY:

racket/src/racket/src/future.h

@@ -241,11 +241,12 @@ typedef struct fsemaphore_t {
 #define SIG_ALLOC_MARK_SEGMENT 3
 #define SIG_ALLOC_VALUES       4
 #define SIG_ALLOC_STRUCT       5
-#define SIG_MAKE_FSEMAPHORE    6
+#define SIG_ALLOC_VECTOR       6
-#define SIG_FUTURE             7
+#define SIG_MAKE_FSEMAPHORE    7
-#define SIG_WRONG_TYPE_EXN     8
+#define SIG_FUTURE             8
-#define SIG_TAIL_APPLY         9
+#define SIG_WRONG_TYPE_EXN     9
-#define SIG_APPLY_AFRESH       10
+#define SIG_TAIL_APPLY         10
+#define SIG_APPLY_AFRESH       11
 
 # include "jit_ts_protos.h"
 
@@ -256,6 +257,7 @@ extern uintptr_t scheme_rtcall_alloc(void);
 extern void scheme_rtcall_new_mark_segment(Scheme_Thread *p);
 extern void scheme_rtcall_allocate_values(int count, Scheme_Thread *t);
 extern Scheme_Structure *scheme_rtcall_allocate_structure(int argc, Scheme_Struct_Type *stype);
+extern Scheme_Object *scheme_rtcall_allocate_vector(int count);
 extern Scheme_Object *scheme_rtcall_make_fsemaphore(Scheme_Object *ready);
 extern Scheme_Object *scheme_rtcall_make_future(Scheme_Object *proc);
 extern Scheme_Object *scheme_rtcall_tail_apply(Scheme_Object *rator, int argc, Scheme_Object **argv);

racket/src/racket/src/gen-jit-ts.rkt

@@ -153,7 +153,7 @@
    })
    (newline))
 
-(define proto-counter 11)
+(define proto-counter 20)
 
 (define (gen-protos t)
   (define-values (arg-types result-type) (parse-type t))

racket/src/racket/src/jit_ts.c

@@ -141,6 +141,7 @@ define_ts_l_s(scheme_jit_make_vector, FSRC_OTHER)
 # endif
 define_ts_ss_s(equal_as_bool, FSRC_MARKS)
 define_ts_sss_s(extract_one_cc_mark_to_tag, FSRC_MARKS)
+define_ts_iS_s(scheme_checked_make_vector, FSRC_MARKS)
 #endif
 
 #ifdef JIT_APPLY_TS_PROCS
@@ -225,6 +226,7 @@ define_ts_s_s(scheme_box, FSRC_OTHER)
 # define ts_scheme_string_eq_2 scheme_string_eq_2
 # define ts_scheme_byte_string_eq_2 scheme_byte_string_eq_2
 # define ts_extract_one_cc_mark_to_tag extract_one_cc_mark_to_tag
+# define ts_scheme_checked_make_vector scheme_checked_make_vector
 # define ts_tail_call_with_values_from_multiple_result tail_call_with_values_from_multiple_result
 # define ts_raise_bad_call_with_values raise_bad_call_with_values
 # define ts_call_with_values_from_multiple_result_multi call_with_values_from_multiple_result_multi

racket/src/racket/src/jit_ts_protos.h

@@ -1,90 +1,90 @@
-#define SIG_siS_s 11
+#define SIG_siS_s 20
 typedef Scheme_Object* (*prim_siS_s)(Scheme_Object*, int, Scheme_Object**);
 Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g358, int g359, Scheme_Object** g360);
-#define SIG_iSs_s 12
+#define SIG_iSs_s 21
 typedef Scheme_Object* (*prim_iSs_s)(int, Scheme_Object**, Scheme_Object*);
 Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g361, Scheme_Object** g362, Scheme_Object* g363);
-#define SIG_s_s 13
+#define SIG_s_s 22
 typedef Scheme_Object* (*prim_s_s)(Scheme_Object*);
 Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g364);
-#define SIG_n_s 14
+#define SIG_n_s 23
 typedef Scheme_Object* (*prim_n_s)(Scheme_Native_Lambda*);
 Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Lambda* g365);
-#define SIG__s 15
+#define SIG__s 24
 typedef Scheme_Object* (*prim__s)();
 Scheme_Object* scheme_rtcall__s(const char *who, int src_type, prim__s f );
-#define SIG_ss_s 16
+#define SIG_ss_s 25
 typedef Scheme_Object* (*prim_ss_s)(Scheme_Object*, Scheme_Object*);
 Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g366, Scheme_Object* g367);
-#define SIG_ssi_s 17
+#define SIG_ssi_s 26
 typedef Scheme_Object* (*prim_ssi_s)(Scheme_Object*, Scheme_Object*, int);
 Scheme_Object* scheme_rtcall_ssi_s(const char *who, int src_type, prim_ssi_s f, Scheme_Object* g368, Scheme_Object* g369, int g370);
-#define SIG_tt_s 18
+#define SIG_tt_s 27
 typedef Scheme_Object* (*prim_tt_s)(const Scheme_Object*, const Scheme_Object*);
 Scheme_Object* scheme_rtcall_tt_s(const char *who, int src_type, prim_tt_s f, const Scheme_Object* g371, const Scheme_Object* g372);
-#define SIG_ss_m 19
+#define SIG_ss_m 28
 typedef MZ_MARK_STACK_TYPE (*prim_ss_m)(Scheme_Object*, Scheme_Object*);
 MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g373, Scheme_Object* g374);
-#define SIG_Sl_s 20
+#define SIG_Sl_s 29
 typedef Scheme_Object* (*prim_Sl_s)(Scheme_Object**, intptr_t);
 Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g375, intptr_t g376);
-#define SIG_l_s 21
+#define SIG_l_s 30
 typedef Scheme_Object* (*prim_l_s)(intptr_t);
 Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, intptr_t g377);
-#define SIG_bsi_v 22
+#define SIG_bsi_v 31
 typedef void (*prim_bsi_v)(Scheme_Bucket*, Scheme_Object*, int);
 void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g378, Scheme_Object* g379, int g380);
-#define SIG_iiS_v 23
+#define SIG_iiS_v 32
 typedef void (*prim_iiS_v)(int, int, Scheme_Object**);
 void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g381, int g382, Scheme_Object** g383);
-#define SIG_ss_v 24
+#define SIG_ss_v 33
 typedef void (*prim_ss_v)(Scheme_Object*, Scheme_Object*);
 void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g384, Scheme_Object* g385);
-#define SIG_b_v 25
+#define SIG_b_v 34
 typedef void (*prim_b_v)(Scheme_Bucket*);
 void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g386);
-#define SIG_sl_s 26
+#define SIG_sl_s 35
 typedef Scheme_Object* (*prim_sl_s)(Scheme_Object*, intptr_t);
 Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g387, intptr_t g388);
-#define SIG_iS_s 27
+#define SIG_iS_s 36
 typedef Scheme_Object* (*prim_iS_s)(int, Scheme_Object**);
 Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g389, Scheme_Object** g390);
-#define SIG_S_s 28
+#define SIG_S_s 37
 typedef Scheme_Object* (*prim_S_s)(Scheme_Object**);
 Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g391);
-#define SIG_s_v 29
+#define SIG_s_v 38
 typedef void (*prim_s_v)(Scheme_Object*);
 void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g392);
-#define SIG_iSi_s 30
+#define SIG_iSi_s 39
 typedef Scheme_Object* (*prim_iSi_s)(int, Scheme_Object**, int);
 Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g393, Scheme_Object** g394, int g395);
-#define SIG_siS_v 31
+#define SIG_siS_v 40
 typedef void (*prim_siS_v)(Scheme_Object*, int, Scheme_Object**);
 void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g396, int g397, Scheme_Object** g398);
-#define SIG_Sii_s 32
+#define SIG_Sii_s 41
 typedef Scheme_Object* (*prim_Sii_s)(Scheme_Object**, int, int);
 Scheme_Object* scheme_rtcall_Sii_s(const char *who, int src_type, prim_Sii_s f, Scheme_Object** g399, int g400, int g401);
-#define SIG_z_p 33
+#define SIG_z_p 42
 typedef void* (*prim_z_p)(size_t);
 void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g402);
-#define SIG_si_s 34
+#define SIG_si_s 43
 typedef Scheme_Object* (*prim_si_s)(Scheme_Object*, int);
 Scheme_Object* scheme_rtcall_si_s(const char *who, int src_type, prim_si_s f, Scheme_Object* g403, int g404);
-#define SIG_sis_v 35
+#define SIG_sis_v 44
 typedef void (*prim_sis_v)(Scheme_Object*, int, Scheme_Object*);
 void scheme_rtcall_sis_v(const char *who, int src_type, prim_sis_v f, Scheme_Object* g405, int g406, Scheme_Object* g407);
-#define SIG_ss_i 36
+#define SIG_ss_i 45
 typedef int (*prim_ss_i)(Scheme_Object*, Scheme_Object*);
 int scheme_rtcall_ss_i(const char *who, int src_type, prim_ss_i f, Scheme_Object* g408, Scheme_Object* g409);
-#define SIG_iSp_v 37
+#define SIG_iSp_v 46
 typedef void (*prim_iSp_v)(int, Scheme_Object**, void*);
 void scheme_rtcall_iSp_v(const char *who, int src_type, prim_iSp_v f, int g410, Scheme_Object** g411, void* g412);
-#define SIG_sss_s 38
+#define SIG_sss_s 47
 typedef Scheme_Object* (*prim_sss_s)(Scheme_Object*, Scheme_Object*, Scheme_Object*);
 Scheme_Object* scheme_rtcall_sss_s(const char *who, int src_type, prim_sss_s f, Scheme_Object* g413, Scheme_Object* g414, Scheme_Object* g415);
-#define SIG__v 39
+#define SIG__v 48
 typedef void (*prim__v)();
 void scheme_rtcall__v(const char *who, int src_type, prim__v f );
-#define SIG_iS_v 40
+#define SIG_iS_v 49
 typedef void (*prim_iS_v)(int, Scheme_Object**);
 void scheme_rtcall_iS_v(const char *who, int src_type, prim_iS_v f, int g416, Scheme_Object** g417);

racket/src/racket/src/jitinline.c

@@ -773,6 +773,51 @@ static Scheme_Object *alloc_structure(Scheme_Object *_stype, int argc)
   return (Scheme_Object *)inst;
 }
 
+#ifdef MZ_USE_FUTURES
+static Scheme_Object *checked_make_vector(int argc)
+  XFORM_SKIP_PROC
+/* Arguments on runstack */
+{
+  Scheme_Object *vec, *val, *c = MZ_RUNSTACK[0];
+
+  if (SCHEME_INTP(c)
+      && (SCHEME_INT_VAL(c) >= 0)
+      /* Upper bound ensures that we don't have to deal with overflow: */
+      && (SCHEME_INT_VAL(c) < 0x1000000)) {
+    /* In a future thread, we can try to call scheme_malloc_tagged() directory,
+       but it might fail and return NULL */
+    intptr_t count = SCHEME_INT_VAL(c), i, size;
+    size = (sizeof(Scheme_Vector)
+            + ((count - mzFLEX_DELTA) * sizeof(Scheme_Object *)));
+    if ((count < 1024) || scheme_use_rtcall)
+      vec = scheme_malloc_tagged(size);
+    else
+      vec = scheme_malloc_fail_ok(scheme_malloc_tagged, size);
+    if (vec) {
+      vec->type = scheme_vector_type;
+      SCHEME_VEC_SIZE(vec) = count;
+    } else {
+      /* Must be in a future thread */
+      vec = scheme_rtcall_allocate_vector(count);
+      if (!vec) {
+        /* Unusual failure --- maybe "out of memory" */
+        return ts_scheme_checked_make_vector(argc, MZ_RUNSTACK);
+      }
+    }
+
+    val = ((argc > 1) ? MZ_RUNSTACK[1] : scheme_make_integer(0));
+    for (i = 0; i < count; i++) {
+      SCHEME_VEC_ELS(vec)[i] = val;
+    }
+
+    return vec;
+  } else
+    return ts_scheme_checked_make_vector(argc, MZ_RUNSTACK);
+}
+#else
+# define checked_make_vector ts_scheme_checked_make_vector
+#endif
+
 Scheme_Structure *scheme_jit_allocate_structure(int argc, Scheme_Struct_Type *stype)
 {
   Scheme_Structure *inst;
@@ -1108,6 +1153,10 @@ static int generate_inlined_constant_varref_test(mz_jit_state *jitter, Scheme_Ob
 static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator,
                                  Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3,
                                  int dest);
+static int generate_make_vector_alloc(mz_jit_state *jitter,
+                                      Scheme_Object *rator,
+                                      Scheme_Object *rand1, Scheme_Object *rand2,
+                                      int dest);
 
 int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, int is_tail, int multi_ok, 
 				  Branch_Info *for_branch, int branch_short, int result_ignored,
@@ -2063,6 +2112,8 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
     } else if (IS_NAMED_PRIM(rator, "vector-immutable")
                || IS_NAMED_PRIM(rator, "vector")) {
       return generate_vector_alloc(jitter, rator, NULL, app, NULL, dest);
+    } else if (IS_NAMED_PRIM(rator, "make-vector")) {
+      return generate_make_vector_alloc(jitter, rator, app->rand, NULL, dest);
     } else if (IS_NAMED_PRIM(rator, "list*")
                || IS_NAMED_PRIM(rator, "values")) {
       /* on a single argument, `list*' or `values' is identity */
@@ -3916,6 +3967,8 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
     } else if (IS_NAMED_PRIM(rator, "vector-immutable")
                || IS_NAMED_PRIM(rator, "vector")) {
       return generate_vector_alloc(jitter, rator, NULL, NULL, app, dest);
+    } else if (IS_NAMED_PRIM(rator, "make-vector")) {
+      return generate_make_vector_alloc(jitter, rator, app->rand1, app->rand2, dest);
     } else if (IS_NAMED_PRIM(rator, "make-rectangular")) {
       GC_CAN_IGNORE jit_insn *ref, *ref2, *ref3, *ref4, *refslow, *refdone;
 
@@ -5276,6 +5329,38 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator,
   return 1;
 }
 
+int generate_make_vector_alloc(mz_jit_state *jitter,
+                               Scheme_Object *rator,
+                               Scheme_Object *rand1, Scheme_Object *rand2,
+                               int dest)
+/* de-sync'd ok */
+{
+  GC_CAN_IGNORE jit_insn *refrts USED_ONLY_FOR_FUTURES;
+  Scheme_Object *args[3];
+  int argc = (rand2 ? 2 : 1);
+
+  args[0] = rator;
+  args[1] = rand1;
+  args[2] = rand2;
+
+  scheme_generate_app(NULL, args, argc, argc, jitter, 0, 0, 0, 2);
+
+  mz_rs_sync();
+  JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
+
+  jit_movi_i(JIT_R1, argc);
+
+  jit_prepare(1);
+  jit_pusharg_i(JIT_R1);
+  (void)mz_finish_lwe(checked_make_vector, refrts);
+  jit_retval(dest);
+
+  jit_addi_l(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(argc));
+  mz_runstack_popped(jitter, argc);
+
+  return 1;
+}
+
 int scheme_generate_inlined_test(mz_jit_state *jitter, Scheme_Object *obj, int branch_short, 
                                  Branch_Info *for_branch)
 /* de-sync'd ok; syncs before jump */

racket/src/racket/src/schpriv.h

@@ -4475,6 +4475,7 @@ Scheme_Object *scheme_checked_make_flrectangular (int argc, Scheme_Object *argv[
 Scheme_Object *scheme_procedure_arity_includes(int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_checked_char_to_integer (int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_checked_integer_to_char (int argc, Scheme_Object *argv[]);
+Scheme_Object *scheme_checked_make_vector (int argc, Scheme_Object *argv[]);
 
 Scheme_Object *scheme_check_not_undefined (int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_check_assign_not_undefined (int argc, Scheme_Object *argv[]);

racket/src/racket/src/vector.c

@@ -41,7 +41,6 @@ READ_ONLY Scheme_Object *scheme_unsafe_struct_ref_proc;
 
 /* locals */
 static Scheme_Object *vector_p (int argc, Scheme_Object *argv[]);
-static Scheme_Object *make_vector (int argc, Scheme_Object *argv[]);
 static Scheme_Object *vector (int argc, Scheme_Object *argv[]);
 static Scheme_Object *vector_immutable (int argc, Scheme_Object *argv[]);
 static Scheme_Object *vector_length (int argc, Scheme_Object *argv[]);
@@ -84,7 +83,9 @@ scheme_init_vector (Scheme_Env *env)
   scheme_vector_p_proc = p;
 
   REGISTER_SO(scheme_make_vector_proc);
-  p = scheme_make_immed_prim(make_vector, "make-vector", 1, 2);
+  p = scheme_make_immed_prim(scheme_checked_make_vector, "make-vector", 1, 2);
+  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
+                                                            | SCHEME_PRIM_IS_BINARY_INLINED);
   scheme_add_global_constant("make-vector", p, env);
   scheme_make_vector_proc = p;
 
@@ -319,8 +320,8 @@ vector_p (int argc, Scheme_Object *argv[])
   return (SCHEME_CHAPERONE_VECTORP(argv[0]) ? scheme_true : scheme_false);
 }
 
-static Scheme_Object *
+Scheme_Object *
-make_vector (int argc, Scheme_Object *argv[])
+scheme_checked_make_vector (int argc, Scheme_Object *argv[])
 {
   Scheme_Object *vec, *fill;
   intptr_t len;