Don't keep allocating nullary constructors

rts/idris_gc.c

@@ -12,10 +12,14 @@ VAL copy(VM* vm, VAL x) {
     switch(GETTY(x)) {
     case CON:
         ar = CARITY(x);
-        allocCon(cl, vm, CTAG(x), ar, 1);
-        for(i = 0; i < ar; ++i) {
-//            *argptr = copy(vm, *((VAL*)(x->info.c.args)+i)); // recursive version
-            cl->info.c.args[i] = x->info.c.args[i];
+        if (ar == 0 && CTAG(x) < 256) {
+            return x;
+        } else {
+            allocCon(cl, vm, CTAG(x), ar, 1);
+            for(i = 0; i < ar; ++i) {
+    //            *argptr = copy(vm, *((VAL*)(x->info.c.args)+i)); // recursive version
+                cl->info.c.args[i] = x->info.c.args[i];
+            }
         }
         break;
     case FLOAT:

rts/idris_main.c

@@ -15,6 +15,8 @@ int main(int argc, char* argv[]) {
     __idris_argv = argv;
 
     VM* vm = init_vm(opts.max_stack_size, opts.init_heap_size, 1);
+    initNullaries();
+
     _idris__123_runMain0_125_(vm, NULL);
 
 #ifdef IDRIS_DEBUG
@@ -29,5 +31,6 @@ int main(int argc, char* argv[]) {
         print_stats(&stats);
     }
 
+    freeNullaries();
     return EXIT_SUCCESS;
 }

rts/idris_rts.c

@@ -828,12 +828,16 @@ VAL copyTo(VM* vm, VAL x) {
     switch(GETTY(x)) {
     case CON:
         ar = CARITY(x);
-        allocCon(cl, vm, CTAG(x), ar, 1);
+        if (ar == 0 && CTAG(x) < 256) { // globally allocated
+            cl = x;
+        } else {
+            allocCon(cl, vm, CTAG(x), ar, 1);
 
-        argptr = (VAL*)(cl->info.c.args);
-        for(i = 0; i < ar; ++i) {
-            *argptr = copyTo(vm, *((VAL*)(x->info.c.args)+i)); // recursive version
-            argptr++;
+            argptr = (VAL*)(cl->info.c.args);
+            for(i = 0; i < ar; ++i) {
+                *argptr = copyTo(vm, *((VAL*)(x->info.c.args)+i)); // recursive version
+                argptr++;
+            }
         }
         break;
     case FLOAT:
@@ -962,6 +966,29 @@ VAL idris_recvMessage(VM* vm) {
     return msg;
 }
 #endif
+
+VAL* nullary_cons;
+
+void initNullaries() {
+    int i;
+    VAL cl;
+    nullary_cons = malloc(256 * sizeof(VAL));
+    for(i = 0; i < 256; ++i) {
+        cl = malloc(sizeof(Closure));
+        SETTY(cl, CON);
+        cl->info.c.tag_arity = i << 8;
+        nullary_cons[i] = cl;
+    }
+}
+
+void freeNullaries() {
+    int i;
+    for(i = 0; i < 256; ++i) {
+        free(nullary_cons[i]);
+    }
+    free(nullary_cons);
+}
+
 int __idris_argc;
 char **__idris_argv;
 

rts/idris_rts.h

@@ -219,6 +219,12 @@ void idris_doneAlloc(VM* vm);
   SETTY(cl, CON); \
   cl->info.c.tag_arity = ((t) << 8) | (a);
 
+#define NULL_CON(x) nullary_cons[x]
+
+extern VAL* nullary_cons;
+void initNullaries();
+void freeNullaries();
+
 void* vmThread(VM* callvm, func f, VAL arg);
 
 // Copy a structure to another vm's heap

src/IRTS/CodegenC.hs

@@ -153,6 +153,8 @@ bcc i (ASSIGNCONST l c)
     mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)"
     mkConst _ = "MKINT(42424242)"
 bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
+bcc i (MKCON l loc tag []) | tag < 256
+    = indent i ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"
 bcc i (MKCON l loc tag args)
     = indent i ++ alloc loc tag ++
       indent i ++ setArgs 0 args ++ "\n" ++

src/IRTS/Lang.hs

@@ -217,7 +217,7 @@ allocUnique defs (n, LFun opts fn args e)
           = findUp (LCon Nothing i n as)
     findUp (LV (Glob n))
        | Just (LConstructor _ i 0) <- lookupCtxtExact n defs
-          = findUp (LCon Nothing i n [])
+          = return $ LCon Nothing i n [] -- nullary cons are global, no need to update
     findUp (LApp t f as) = LApp t <$> findUp f <*> mapM findUp as
     findUp (LLazyApp n as) = LLazyApp n <$> mapM findUp as
     findUp (LLazyExp e) = LLazyExp <$> findUp e