[RefC] Suppress arglist wrapper

CHANGELOG_NEXT.md

@@ -9,6 +9,14 @@ This CHANGELOG describes the merged but unreleased changes. Please see [CHANGELO
 
 ### Compiler changes
 
+### Backend changes
+
+#### RefC
+
+* Supress code generation of _arglist wrappers to reduce code size and compilation time.
+
+* Removed Value_Arglist to reduce Closure's allocation overhead and make code simply.
+
 ### Library changes
 
 #### Prelude

src/Compiler/RefC/RefC.idr

@@ -384,34 +384,17 @@ addHeader = update HeaderFiles . insert
 
 
 
-makeArglist : {auto a : Ref ArgCounter Nat}
-           -> {auto t : Ref TemporaryVariableTracker (List (List String))}
-           -> {auto oft : Ref OutfileText Output}
-           -> {auto il : Ref IndentLevel Nat}
-           -> Nat
-           -> List AVar
-           -> Core (String)
-makeArglist missing xs = do
-    c <- getNextCounter
-    let arglist = "arglist_" ++ (show c)
-    emit EmptyFC $  "Value_Arglist *"
-                 ++ arglist
-                 ++ " = newArglist(" ++ show missing
-                 ++ "," ++ show (length xs + missing)
-                 ++ ");"
-    pushArgToArglist arglist xs 0
-    pure arglist
-where
-    pushArgToArglist : String
-                    -> List AVar
-                    -> Nat
-                    -> Core ()
-    pushArgToArglist arglist [] k = pure ()
-    pushArgToArglist arglist (arg :: args) k = do
-        emit EmptyFC $ arglist
-                    ++ "->args[" ++ show k ++ "] = "
-                    ++ " newReference(" ++ varName arg ++");"
-        pushArgToArglist arglist args (S k)
+fillClosureArgs : {auto oft : Ref OutfileText Output}
+                -> {auto il : Ref IndentLevel Nat}
+                -> String
+                -> List AVar
+                -> Bits8
+                -> Core ()
+fillClosureArgs clos [] k = pure ()
+fillClosureArgs clos (arg :: args) k = do
+     emit EmptyFC $ clos ++ "->args[" ++ show k ++ "] = newReference(" ++ varName arg ++");"
+     fillClosureArgs clos args (k + 1)
+
 
 fillConstructorArgs : {auto oft : Ref OutfileText Output}
                    -> {auto il : Ref IndentLevel Nat}
@@ -467,24 +450,8 @@ const2Integer c i =
         _ => i
 
 
-
-
-
--- we return for each of the ANF a set of statements and two possible return statements
--- The first one for non-tail statements, the second one for tail statements
--- this way, we can deal with tail calls and tail recursion.
--- The higher-level invocation first executes the normal statements and then
--- assign the return value
-record ReturnStatement where
-    constructor MkRS
-    nonTailCall : String
-    tailCall : String
-
 data TailPositionStatus = InTailPosition | NotInTailPosition
 
-callByPosition : TailPositionStatus -> ReturnStatement -> String
-callByPosition InTailPosition = tailCall
-callByPosition NotInTailPosition = nonTailCall
 
 mutual
     copyConstructors : {auto a : Ref ArgCounter Nat}
@@ -527,7 +494,7 @@ mutual
         newTemporaryVariableLevel
         varBindLines sc args Z
         assignment <- cStatementsFromANF body tailStatus
-        emit EmptyFC $ retValVar ++ " = " ++ callByPosition tailStatus assignment ++ ";"
+        emit EmptyFC $ retValVar ++ " = " ++ assignment ++ ";"
         freeTmpVars
         emit EmptyFC $ "break;"
         decreaseIndentation
@@ -559,7 +526,7 @@ mutual
         increaseIndentation
         newTemporaryVariableLevel
         assignment <- cStatementsFromANF caseBody tailStatus
-        emit EmptyFC $ retValVar ++ " = " ++ callByPosition tailStatus assignment ++ ";"
+        emit EmptyFC $ retValVar ++ " = " ++ assignment ++ ";"
         freeTmpVars
         emit EmptyFC "break;"
         decreaseIndentation
@@ -583,7 +550,7 @@ mutual
         increaseIndentation
         newTemporaryVariableLevel
         assignment <- cStatementsFromANF defaultBody tailStatus
-        emit EmptyFC $ retValVar ++ " = " ++ callByPosition tailStatus assignment ++ ";"
+        emit EmptyFC $ retValVar ++ " = " ++ assignment ++ ";"
         freeTmpVars
         decreaseIndentation
         emit EmptyFC "  }"
@@ -631,45 +598,45 @@ mutual
                       -> {auto il : Ref IndentLevel Nat}
                       -> ANF
                       -> TailPositionStatus
-                      -> Core ReturnStatement
-    cStatementsFromANF (AV fc x) _ = do
-        let returnLine = "newReference(" ++ varName x  ++ ")"
-        pure $ MkRS returnLine returnLine
-    cStatementsFromANF (AAppName fc _ n args) _ = do
+                      -> Core String
+    cStatementsFromANF (AV fc x) _ = pure $ "newReference(" ++ varName x  ++ ")"
+    cStatementsFromANF (AAppName fc _ n args) tailstatus = do
         emit fc $ ("// start " ++ cName n ++ "(" ++ showSep ", " (map (\v => varName v) args) ++ ")")
-        arglist <- makeArglist 0 args
-        c <- getNextCounter
-        let f_ptr_name = "fPtr_" ++ show c
-        emit fc $ "Value *(*"++ f_ptr_name ++ ")(Value_Arglist*) = "++  cName n ++ "_arglist;"
-        let closure_name = "closure_" ++ show c
-        emit fc $ "Value *"
-               ++ closure_name
-               ++ " = (Value*)makeClosureFromArglist("
-               ++ f_ptr_name
-               ++ ", "
-               ++ arglist
-               ++ ");"
-        emit fc $ ("// end   " ++ cName n ++ "(" ++ showSep ", " (map (\v => varName v) args) ++ ")")
-        pure $ MkRS ("trampoline(" ++ closure_name ++ ")") closure_name
+        let closure_name = "closure_" ++ show !(getNextCounter)
+        case tailstatus of
+            InTailPosition    => do
+                let nargs = length args
+                emit fc $ "Value_Closure *"
+                       ++ closure_name
+                       ++ " = makeClosure((Value *(*)())" ++ cName n
+                       ++ ", " ++ show nargs ++ ", " ++ show nargs ++ ");"
+                fillClosureArgs closure_name args 0
+            NotInTailPosition => do
+              emit fc $ "Value *" ++ closure_name
+                       ++ " = trampoline(" ++ cName n ++ "("
+                       ++ (concat $ intersperse ", " $ map varName args) ++ "));"
+        emit fc $ "// end   " ++ cName n ++ "(" ++ showSep ", " (map (\v => varName v) args) ++ ")"
+        pure $ "((Value *)" ++ closure_name ++ ")"
+
     cStatementsFromANF (AUnderApp fc n missing args) _ = do
-        arglist <- makeArglist missing args
-        c <- getNextCounter
-        let f_ptr_name = "closure_" ++ show c
-        let f_ptr = "Value *(*"++ f_ptr_name ++ ")(Value_Arglist*) = "++  cName n ++ "_arglist;"
-        emit fc f_ptr
-        let returnLine = "(Value*)makeClosureFromArglist(" ++ f_ptr_name  ++ ", " ++ arglist ++ ")"
-        pure $ MkRS returnLine returnLine
-    cStatementsFromANF (AApp fc _ closure arg) _ =
-        pure $ MkRS ("apply_closure(" ++ varName closure ++ ", " ++ varName arg ++ ")")
-                    ("tailcall_apply_closure(" ++ varName closure ++ ", " ++ varName arg ++ ")")
+        let closure_name = "closure_" ++ show !(getNextCounter)
+        let nargs = length args
+        emit fc $ "Value_Closure *"
+               ++ closure_name
+               ++ " = makeClosure((Value *(*)())" ++ cName n
+               ++ ", " ++ show (nargs + missing) ++ ", " ++ show nargs ++ ");"
+        fillClosureArgs closure_name args 0
+        pure $ "((Value *)" ++ closure_name ++ ")"
+    cStatementsFromANF (AApp fc _ closure arg) tailstatus =
+        pure $ case tailstatus of
+          NotInTailPosition => "apply_closure(" ++ varName closure ++ ", " ++ varName arg ++ ")"
+          InTailPosition    => "tailcall_apply_closure(" ++ varName closure ++ ", " ++ varName arg ++ ")"
     cStatementsFromANF (ALet fc var value body) tailPosition = do
         valueAssignment <- cStatementsFromANF value NotInTailPosition
-        emit fc $ "Value * var_" ++ (show var) ++ " = " ++ nonTailCall valueAssignment ++ ";"
+        emit fc $ "Value * var_" ++ (show var) ++ " = " ++ valueAssignment ++ ";"
         registerVariableForAutomaticFreeing $ "var_" ++ (show var)
-        bodyAssignment <- cStatementsFromANF body tailPosition
-        pure $ bodyAssignment
-    cStatementsFromANF (ACon fc n UNIT tag []) _ = do
-        pure $ MkRS "(Value*)NULL" "(Value*)NULL"
+        cStatementsFromANF body tailPosition
+    cStatementsFromANF (ACon fc n UNIT tag []) _ = pure "(Value*)NULL"
     cStatementsFromANF (ACon fc n _ tag args) _ = do
         c <- getNextCounter
         let constr = "constructor_" ++ (show c)
@@ -682,15 +649,14 @@ mutual
         emit fc $ " // constructor " ++ cName n
 
         fillConstructorArgs constr args 0
-        pure $ MkRS ("(Value*)" ++ constr) ("(Value*)" ++ constr)
+        pure $ "(Value*)" ++ constr
+
     cStatementsFromANF (AOp fc _ op args) _ = do
         argsVec <- cArgsVectANF args
-        let opStatement = cOp op argsVec
-        pure $ MkRS opStatement opStatement
+        pure $ cOp op argsVec
     cStatementsFromANF (AExtPrim fc _ p args) _ = do
         emit fc $ "// call to external primitive " ++ cName p
-        let returnLine = (cCleanString (show (toPrim p)) ++ "("++ showSep ", " (map varName args) ++")")
-        pure $ MkRS returnLine returnLine
+        pure $ cCleanString (show (toPrim p)) ++ "("++ showSep ", " (map varName args) ++")"
     cStatementsFromANF (AConCase fc sc alts mDef) tailPosition = do
         c <- getNextCounter
         switchReturnVar <- getNewVarThatWillNotBeFreedAtEndOfBlock
@@ -711,22 +677,19 @@ mutual
         emit fc switchLine
         conBlocks (varName sc) alts switchReturnVar 0 tailPosition
         case mDef of
-            Nothing => do
-                emit EmptyFC $ "}"
-                emit EmptyFC $ "free(" ++ constructorField ++ ");"
-                pure $ MkRS switchReturnVar switchReturnVar
+            Nothing => pure ()
             (Just d) => do
                 emit EmptyFC $ "  default : {"
                 increaseIndentation
                 newTemporaryVariableLevel
                 defaultAssignment <- cStatementsFromANF d tailPosition
-                emit EmptyFC $ switchReturnVar ++ " = " ++ callByPosition tailPosition defaultAssignment ++ ";"
+                emit EmptyFC $ switchReturnVar ++ " = " ++ defaultAssignment ++ ";"
                 freeTmpVars
                 decreaseIndentation
                 emit EmptyFC $ "  }"
-                emit EmptyFC $ "}"
-                emit EmptyFC $ "free(" ++ constructorField ++ ");"
-                pure $ MkRS switchReturnVar switchReturnVar
+        emit EmptyFC $ "}"
+        emit EmptyFC $ "free(" ++ constructorField ++ ");"
+        pure switchReturnVar
     cStatementsFromANF (AConstCase fc sc alts def) tailPosition = do
         switchReturnVar <- getNewVarThatWillNotBeFreedAtEndOfBlock
         let newValueLine = "Value * " ++ switchReturnVar ++ " = NULL;"
@@ -737,20 +700,17 @@ mutual
                 constBlockSwitch alts switchReturnVar 0 tailPosition
                 constDefaultBlock def switchReturnVar tailPosition
                 emit EmptyFC "}"
-                pure $ MkRS switchReturnVar switchReturnVar
             False => do
                 (compareField, compareFunction) <- makeNonIntSwitchStatementConst alts 0 "" ""
                 emit fc $ "switch("++ compareFunction ++ "(" ++ varName sc ++ ", " ++ show (length alts) ++ ", " ++ compareField ++ ")){"
                 constBlockSwitch alts switchReturnVar 0 tailPosition
                 constDefaultBlock def switchReturnVar tailPosition
                 emit EmptyFC "}"
                 emit EmptyFC $ "free(" ++ compareField ++ ");"
-                pure $ MkRS switchReturnVar switchReturnVar
-    cStatementsFromANF (APrimVal fc c) _ = pure $ MkRS (cConstant c) (cConstant c)
-    cStatementsFromANF (AErased fc) _ = pure $ MkRS "NULL" "NULL"
-    cStatementsFromANF (ACrash fc x) _ = do
-        emit fc $ "// CRASH"
-        pure $ MkRS "NULL" "NULL"
+        pure switchReturnVar
+    cStatementsFromANF (APrimVal fc c) _ = pure $ cConstant c
+    cStatementsFromANF (AErased fc) _ = pure "NULL"
+    cStatementsFromANF (ACrash fc x) _ = emit fc "// CRASH" >> pure "NULL"
 
 
 
@@ -769,9 +729,6 @@ functionDefSignature n args = do
     let fn = (cName !(getFullName n))
     pure $  "\n\nValue *"  ++ fn ++ "\n(\n" ++ (showSep "\n" (argsStringList)) ++ "\n)"
 
-functionDefSignatureArglist : {auto c : Ref Ctxt Defs} -> Name  -> Core String
-functionDefSignatureArglist n = pure $  "Value *"  ++ (cName !(getFullName n)) ++ "_arglist(Value_Arglist* arglist)"
-
 
 getArgsNrList : List ty -> Nat -> List Nat
 getArgsNrList [] _ = []
@@ -900,35 +857,19 @@ createCFunctions : {auto c : Ref Ctxt Defs}
                 -> Core ()
 createCFunctions n (MkAFun args anf) = do
     fn <- functionDefSignature n args
-    fn' <- functionDefSignatureArglist n
-    update FunctionDefinitions $ \otherDefs => (fn ++ ";\n") :: (fn' ++ ";\n") :: otherDefs
+    update FunctionDefinitions $ \otherDefs => (fn ++ ";\n") :: otherDefs
     newTemporaryVariableLevel
     let argsNrs = getArgsNrList args Z
     emit EmptyFC fn
     emit EmptyFC "{"
     increaseIndentation
     assignment <- cStatementsFromANF anf InTailPosition
-    emit EmptyFC $ "Value *returnValue = " ++ tailCall assignment ++ ";"
+    emit EmptyFC $ "Value *returnValue = " ++ assignment ++ ";"
     freeTmpVars
     emit EmptyFC $ "return returnValue;"
     decreaseIndentation
     emit EmptyFC  "}\n"
     emit EmptyFC  ""
-    emit EmptyFC fn'
-    emit EmptyFC "{"
-    increaseIndentation
-    emit EmptyFC $ "return " ++ (cName !(getFullName n))
-    increaseIndentation
-    emit EmptyFC $ "("
-    increaseIndentation
-    let commaSepArglist = addCommaToList (map (\a => "arglist->args["++ show a ++"]") argsNrs)
-    traverse_ (emit EmptyFC) commaSepArglist
-    decreaseIndentation
-    emit EmptyFC ");"
-    decreaseIndentation
-    decreaseIndentation
-    emit EmptyFC  "}\n"
-    emit EmptyFC  ""
     pure ()
 
 
@@ -952,26 +893,9 @@ createCFunctions n (MkAForeign ccs fargs ret) = do
                       _ => pure ()
              else emit EmptyFC $ additionalFFIStub fctName fargs ret
           let fnDef = "Value *" ++ (cName n) ++ "(" ++ showSep ", " (replicate (length fargs) "Value *") ++ ");"
-          fn_arglist <- functionDefSignatureArglist n
-          update FunctionDefinitions $ \otherDefs => (fnDef ++ "\n") :: (fn_arglist ++ ";\n") :: otherDefs
+          update FunctionDefinitions $ \otherDefs => (fnDef ++ "\n") :: otherDefs
           typeVarNameArgList <- createFFIArgList fargs
 
-          emit EmptyFC fn_arglist
-          emit EmptyFC "{"
-          increaseIndentation
-          emit EmptyFC $ "return " ++ (cName n)
-          increaseIndentation
-          emit EmptyFC $ "("
-          increaseIndentation
-          let commaSepArglist = addCommaToList (map (\a => "arglist->args["++ show a ++"]") (getArgsNrList fargs Z))
-          traverse_ (emit EmptyFC) commaSepArglist
-          decreaseIndentation
-          emit EmptyFC ");"
-          decreaseIndentation
-          decreaseIndentation
-          emit EmptyFC  "}\n"
-          emit EmptyFC  ""
-
           emitFDef n typeVarNameArgList
           emit EmptyFC "{"
           increaseIndentation

support/refc/_datatypes.h

@@ -24,7 +24,6 @@
 #define STRING_TAG 12
 
 #define CLOSURE_TAG 15
-#define ARGLIST_TAG 16
 #define CONSTRUCTOR_TAG 17
 
 #define IOREF_TAG 20
@@ -36,7 +35,6 @@
 #define MUTEX_TAG 30
 #define CONDITION_TAG 31
 
-#define COMPLETE_CLOSURE_TAG 98 // for trampoline tail recursion handling
 #define WORLD_TAG 99
 
 typedef struct {
@@ -121,17 +119,10 @@ typedef struct {
 
 typedef struct {
   Value_header header;
-  int32_t total;
-  int32_t filled;
-  Value **args;
-} Value_Arglist;
-
-typedef Value *(*fun_ptr_t)(Value_Arglist *);
-
-typedef struct {
-  Value_header header;
-  fun_ptr_t f;
-  Value_Arglist *arglist;
+  Value *(*f)();
+  uint8_t arity;
+  uint8_t filled; // length of args.
+  Value *args[0];
 } Value_Closure;
 
 typedef struct {