diff options
| -rw-r--r-- | emit.fun | 34 | ||||
| -rw-r--r-- | il.fun | 12 | ||||
| -rw-r--r-- | parser.fun | 141 | ||||
| -rw-r--r-- | parser.sig | 3 |
4 files changed, 148 insertions, 42 deletions
@@ -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 @@ -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 @@ -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 @@ -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 |