Variadic function declarations and calls

4 files changed, 148 insertions, 42 deletions

diff --git a/emit.fun b/emit.fun
index c794f26..ada0217 100644
--- a/emit.fun
+++ b/emit.fun
@@ -847,6 +847,36 @@ functor Emit(I: IL) = struct
     List.app (printAllocVar rinfo) toAlloc
   end
 
+  fun getUsedRegs rinfo =
+  let
+    val regs = Array.array (usedRegNum, false)
+
+    fun loop idx =
+      if idx = Array.length rinfo then
+        ()
+      else
+        let
+          val (_, vt) = Array.sub (rinfo, idx)
+        in
+          case vt of
+            VtReg reg => Array.update (regs, reg2idx reg - firstUsedReg, true)
+          | _ => ();
+          loop (idx + 1)
+        end
+    val () = loop 0
+
+    fun collect idx acc =
+      if idx = usedRegNum then
+        acc
+      else
+        if Array.sub (regs, idx) then
+          collect (idx + 1) (idx2reg (idx + firstUsedReg) :: acc)
+        else
+          collect (idx + 1) acc
+  in
+    collect 0 []
+  end
+
   fun regAlloc (F as I.Fi { vregs, ops, paramNum, ... }) =
   let
     val (toAlloc, regInfo) = prepareRegInfo paramNum ops vregs
@@ -858,6 +888,10 @@ functor Emit(I: IL) = struct
 
     val () = linearscan regInfo intervals
     val () = printAlloced regInfo toAlloc
+
+    val usedRegs = getUsedRegs regInfo
+    val () = printfn
+      `"used registers: " Plist preg usedRegs (", ", true, 0) %
   in
     raise Unimplemented
   end
diff --git a/il.fun b/il.fun
index 55f97de..9f8c2b7 100644
--- a/il.fun
+++ b/il.fun
@@ -385,6 +385,14 @@ functor IL(P: PARSER) = struct
     if isFunc then Reg v else Addr v
   end
 
+  fun convStrlit ctx id t =
+  let
+    val v = getNew8 ctx
+  in
+    ctxPutOp ctx (IrSet (v, SaAddr (id, 0w0)));
+    (if P.isArray t then Addr else Reg) v
+  end
+
   fun convId ctx (P.Gid p) = convGLconst ctx p
     | convId (Lctx { localVars, paramNum, ... }) (P.Lid id) =
       if id < paramNum then (* function parameter *)
@@ -994,7 +1002,7 @@ functor IL(P: PARSER) = struct
     Reg vRes
   end
 
-  and convExpr ctx ea: ev =
+  and convExpr ctx ea =
   let
     val P.EA (e, _, _, t) = ea
   in
@@ -1002,7 +1010,7 @@ functor IL(P: PARSER) = struct
       P.Eid (_, loc) => convId ctx (valOf loc)
     | P.Econst (_, P.Ninteger w) => convConst ctx (w, t)
     | P.Econst (_, _) => raise Unreachable
-    | P.Estrlit id => convGLconst ctx (id, false)
+    | P.Estrlit id => convStrlit ctx id t
     | P.EmemberByV (ea, field) => convFieldAccessByV ctx ea field
     | P.EmemberByP (ea, field) => convFieldAccesByP ctx ea field
     | P.EsizeofType t => convSizeOfType ctx t
diff --git a/parser.fun b/parser.fun
index 0948305..ae5f2e3 100644
--- a/parser.fun
+++ b/parser.fun
@@ -102,7 +102,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     double_t |
     *)
     pointer_t of int * ctype |
-    function_t of ctype * ctype list |
+    function_t of ctype * ctype list * bool |
     array_t of Word64.word * ctype |
     struct_t of
      { name: nid, size: word, alignment: word,
@@ -161,6 +161,8 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     params: (int option * P.tkPos) list option
   }
 
+  datatype funcParam = FpParam of rawDecl | FpTripleDot
+
   val updateRD = fn z =>
   let
     fun from id pos spec t ini params = { id, pos, spec, t, ini, params }
@@ -295,7 +297,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     Pointer of int |
     Id of int * P.tkPos |
     AbstructRoot of P.tkPos |
-    FuncApp of (int option * P.tkPos * ctype) list |
+    FuncApp of bool * (int option * P.tkPos * ctype) list |
     ArrayApplication of Word64.word
 
   datatype abstructPolicy = APpermitted | APenforced | APprohibited
@@ -374,9 +376,10 @@ functor Parser(structure Tree: TREE; structure P: PPC;
           Printf out I plevel A2 pctype true t %
         else
           Printf out `"{" I plevel `"} " A2 pctype false t %
-    | function_t (ret, params) => Printf out `"{"
+    | function_t (ret, params, variadic) => Printf out `"{"
       Plist (pctype short) params (if short then "" else ", ", false, 2)
-        `"}" `(if short then "" else " -> ") A2 pctype short ret %
+        `(if variadic then if short then "V" else " variadic" else "") `"}"
+        `(if short then "" else " -> ") A2 pctype short ret %
     | array_t (n, el) =>
         Printf out `"[" W n `"]" A2 pctype short el %
     | struct_t { name, ... } => Printf out A2 ptagged ("r", "struct") name %
@@ -685,19 +688,24 @@ functor Parser(structure Tree: TREE; structure P: PPC;
       (pointer_t (n, t)) => if n > 1 then true else isObj t
     | _ => false
 
+  fun isArray t =
+    case resolveType t of
+      array_t _ => true
+    | _ => false
+
   fun isStruct t =
     case resolveType t of
-      (struct_t _) => true
+      struct_t _ => true
     | _ => false
 
   fun isUnion t =
     case resolveType t of
-      (union_t _) => true
+      union_t _ => true
     | _ => false
 
   fun funcParts t =
     case resolveType t of
-      (function_t pair) => pair
+      (function_t (t, params, _)) => (t, params)
     | _ => raise Unreachable
 
   fun pointsTo t =
@@ -1237,7 +1245,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
         let
           val ctx = updateCtx ctx u#strlits (fn l => id :: l) %
         in
-          (EA (Estrlit id, pos, false,
+          (EA (Estrlit id, pos, true,
               array_t (Word64.fromInt size, char_t)), ctx)
         end
     | Tk (T.CharConst (id, v)) => wrapNum id (int_t, Ninteger v)
@@ -1336,15 +1344,15 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     ((eof, expr), ctx)
   end
 
-  and convAggr under t =
+  and convAggr under t lvalue =
     case under of
       UNone => (
         case t of
-          function_t _ => pointer_t (1, t)
-        | array_t (_, el_t) => pointer_t (1, el_t)
-        | _ => t
+          function_t _ => (pointer_t (1, t), false)
+        | array_t (_, el_t) => (pointer_t (1, el_t), false)
+        | _ => (t, lvalue)
       )
-    | _ => t
+    | _ => (t, lvalue)
 
   and reduceVarToStack id =
   let
@@ -1373,8 +1381,9 @@ functor Parser(structure Tree: TREE; structure P: PPC;
                   reduceVarToStack lid
               else
                 ()
+            val (t, lvalue) = convAggr under t (not $ isFunc t)
           in
-            SOME (Lid lid, true, convAggr under t, NONE)
+            SOME (Lid lid, lvalue, t, NONE)
           end
         | NONE => findLocal scopes
       end
@@ -1387,7 +1396,11 @@ functor Parser(structure Tree: TREE; structure P: PPC;
       in
         case res of
           SOME (GsDecl (_, _, t, _)) =>
-            (Gid (id, isFunc t), not $ isFunc t, convAggr under t, NONE)
+          let
+            val (t', lvalue) = convAggr under t (not $ isFunc t)
+          in
+            (Gid (id, isFunc t), lvalue, t', NONE)
+          end
         | SOME (GsEnumConst v) => (Gid (id, false), false, int_t, SOME v)
         | SOME (GsTypedef _) =>
             P.error pos `"type in place of an identifier" %
@@ -1760,16 +1773,20 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     val func = check func
     val args = List.map checkArg args
 
-    fun convertArgs (t :: ts) (arg :: args) =
-      convEA t arg :: convertArgs ts args
-      | convertArgs [] [] = []
-      | convertArgs _ _ =
-          P.error pos `"function called with invalid number of arguments" %
+    fun convertArgs variadic (t :: ts) (arg :: args) =
+      convEA t arg :: convertArgs variadic ts args
+      | convertArgs _ [] [] = []
+      | convertArgs false [] _ =
+        P.error pos `"function called with too many arguments" %
+      | convertArgs true [] (arg :: args) =
+        promoteToInt arg :: convertArgs true [] args
+      | convertArgs _ _ [] =
+        P.error pos `"function called with too little arguments" %
   in
     case getT func of
-      pointer_t (1, function_t (rt, argTypes)) =>
+      pointer_t (1, function_t (rt, argTypes, variadic)) =>
       let
-        val args = convertArgs argTypes args
+        val args = convertArgs variadic argTypes args
       in
         EA (EfuncCall (func, args), pos, false, rt)
       end
@@ -1871,6 +1888,14 @@ functor Parser(structure Tree: TREE; structure P: PPC;
   end
    | checkMemberAccessByP _ _ = raise Unreachable
 
+  and checkStrlit under (EA (Estrlit id, pos, lvalue, t)) =
+  let
+    val (t, lvalue) = convAggr under t lvalue
+  in
+    EA (Estrlit id, pos, lvalue, t)
+  end
+    | checkStrlit _ _ = raise Unreachable
+
   and checkExpr ctx (under: under) (E as EA (e, pos, _, _)) =
   let
     val check = checkExpr ctx
@@ -1894,7 +1919,8 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     | Eunop (_, _) => checkUnop check under E
     | EmemberByV _ => checkMemberAccessByV (check UNone) E
     | EmemberByP _ => checkMemberAccessByP (check UNone) E
-    | Econst _ => E | Estrlit _ => E
+    | Econst _ => E
+    | Estrlit _ => checkStrlit under E
   end
 
   and tryGetTypedefName (Ctx ctx) id =
@@ -2678,21 +2704,46 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     | SOME _ => P.error pos `"parameter with invalid storage specifier" %
     | _ => ()
 
+
+  and parseParam ctx =
+  let
+    val (tk, _, ctx') = getTokenCtx ctx
+  in
+    case tk of
+      Tk T.TripleDot => (FpTripleDot, ctx')
+    | _ =>
+      let
+        val (prefix, ctx) = parseDeclPrefix ctx
+        val (parts, ctx) = parseDeclarator (false, APpermitted) [] ctx
+        val declaredId = assembleDeclarator prefix parts
+
+        val () = checkParamStorSpec declaredId
+      in
+        (FpParam declaredId, ctx)
+      end
+  end
+
   and parseFuncParams ctx =
   let
     fun collect ctx acc =
     let
-      val (prefix, ctx) = parseDeclPrefix ctx
-      val (parts, ctx) = parseDeclarator (false, APpermitted) [] ctx
-      val declaredId = assembleDeclarator prefix parts
+      val (param, ctx) = parseParam ctx
+      val isTd =
+        case param of
+          FpTripleDot => true
+        | _ => false
+      fun getP (FpParam p) = p
+        | getP _ = raise Unreachable
 
-      val () = checkParamStorSpec declaredId
       val (tk, pos, ctx) = getTokenCtx ctx
     in
-      case tk of
-        Tk T.EOS => (rev $ declaredId :: acc, ctx)
-      | Tk T.Comma => collect ctx (declaredId :: acc)
-      | _ => P.clerror pos [P.Ctk T.Comma, P.Ctk T.RParen]
+      case (isTd, tk) of
+        (true, Tk T.EOS) => (true, rev acc, ctx)
+      | (false, Tk T.EOS) => (false, rev $ (getP param) :: acc, ctx)
+      | (true, Tk T.Comma) => P.clerror pos [P.Ctk T.RParen]
+      | (false, Tk T.Comma) => collect ctx (getP param :: acc)
+      | (true, _) => P.clerror pos [P.Ctk T.RParen]
+      | (false, _) => P.clerror pos [P.Ctk T.Comma, P.Ctk T.RParen]
     end
 
     fun collect2 () =
@@ -2700,15 +2751,15 @@ functor Parser(structure Tree: TREE; structure P: PPC;
       val (tk, _, _) = getTokenCtx ctx
     in
       case tk of
-        Tk T.EOS => ([], ctx)
+        Tk T.EOS => (false, [], ctx)
       | _ => collect ctx []
     end
 
-    val (params, ctx) = collect2 ()
+    val (variadic, params, ctx) = collect2 ()
     val params =
       map (fn { id, pos, t, ... } => (id, pos, t)) params
   in
-    (FuncApp params, ctx)
+    (FuncApp (variadic, params), ctx)
   end
 
   and collectDDeclaratorTail parts untilEnd ctx =
@@ -2826,12 +2877,12 @@ functor Parser(structure Tree: TREE; structure P: PPC;
         pointer_t (plevel', t) => pointer_t (plevel' + plevel, t)
       | _ => pointer_t (plevel, t)
     end
-      | complete (FuncApp params :: tail) =
+      | complete (FuncApp (variadic, params) :: tail) =
       let
         val () = checkParamUniqueness [] params
         val params = map (fn (_, _, ctype) => ctype) params
       in
-        function_t (complete tail, params)
+        function_t (complete tail, params, variadic)
       end
       | complete (ArrayApplication n :: tail) = array_t (n, complete tail)
       | complete [] = ctype
@@ -2839,7 +2890,8 @@ functor Parser(structure Tree: TREE; structure P: PPC;
 
     val params =
       case parts of
-        _ :: FuncApp p :: _  => SOME $ map (fn (id, pos, _) => (id, pos)) p
+        _ :: FuncApp (_, p) :: _  =>
+          SOME $ map (fn (id, pos, _) => (id, pos)) p
       | _ => NONE
 
   in
@@ -3759,7 +3811,14 @@ functor Parser(structure Tree: TREE; structure P: PPC;
         checkParamTypes args
       | checkParamTypes [] = ()
 
-    val (rt, args) = funcParts t
+    val (rt, args) =
+      case t of
+        function_t (t, args, variadic) =>
+          if variadic then
+            P.error pos `"variadic function definition is not supported" %
+          else
+            (t, args)
+      | _ => raise Unreachable
 
     val () =
       if isScalar rt orelse rt = void_t then
@@ -3838,9 +3897,13 @@ functor Parser(structure Tree: TREE; structure P: PPC;
 
     val params = getParams [] 0
     fun printParam (id, t) out = Printf out `"%" I id `": " Pctype t %
-    val ret = case t of function_t (ret, _) => ret | _ => raise Unreachable
+    val (ret, variadic) =
+      case t of
+        function_t (ret, _, v) => (ret, v)
+      | _ => raise Unreachable
   in
     printf P.?name `" " Plist printParam params (", ", true, 2)
+        `(if variadic then " variadic" else "")
         `" -> " Pctype ret `"\n" %
   end
 
diff --git a/parser.sig b/parser.sig
index f536e41..6040800 100644
--- a/parser.sig
+++ b/parser.sig
@@ -22,7 +22,7 @@ signature PARSER = sig
     ulonglong_t |
 
     pointer_t of int * ctype |
-    function_t of ctype * ctype list |
+    function_t of ctype * ctype list * bool |
     array_t of Word64.word * ctype |
     struct_t of
      { name: nid, size: word, alignment: word,
@@ -155,6 +155,7 @@ signature PARSER = sig
   val isSigned: ctype -> bool
   val isPointer: ctype -> bool
   val pointsTo: ctype -> ctype
+  val isArray: ctype -> bool
 
   val typeRank: ctype -> int
   val resolveType: ctype -> ctype