summaryrefslogtreecommitdiff
path: root/il.fun
diff options
context:
space:
mode:
Diffstat (limited to 'il.fun')
-rw-r--r--il.fun213
1 files changed, 156 insertions, 57 deletions
diff --git a/il.fun b/il.fun
index 286cd32..0d45676 100644
--- a/il.fun
+++ b/il.fun
@@ -43,6 +43,7 @@ functor IL(P: PARSER) = struct
| IrLoad of vreg * vreg * accessClass (* %1 <- [%2] *)
| IrStore of vreg * vreg * accessClass (* [%1] <- %2 *)
+ | IrJmpc of cmpOp * vreg * vreg * label
| IrJz of vreg * label
| IrJnz of vreg * label
| IrJmp of label
@@ -243,6 +244,7 @@ functor IL(P: PARSER) = struct
| IrLoad (r1, r2, _) => de (r1, r2)
| IrStore (r1, r2, _) => { defs = [], use = [r1, r2] }
| IrJmp _ => { defs = [], use = [] }
+ | IrJmpc (_, r1, r2, _) => { defs = [], use = [r1, r2] }
| IrJz (r, _) => { defs = [], use = [r] }
| IrJnz (r, _) => { defs = [], use = [r] }
| IrNopLabel _ | IrNop _ => { defs = [], use = [] }
@@ -387,12 +389,12 @@ functor IL(P: PARSER) = struct
Reg v
end
- fun convGLconst ctx (id, isFunc) =
+ fun convGLconst ctx id =
let
val v = getNew8 ctx
in
ctxPutOp ctx (IrSet (v, SaAddr (id, 0w0)));
- if isFunc then Reg v else Addr v
+ Addr v
end
fun convStrlit ctx id t =
@@ -403,7 +405,7 @@ functor IL(P: PARSER) = struct
(if P.isArray t then Addr else Reg) v
end
- fun convId ctx (P.Gid p) = convGLconst ctx p
+ fun convId ctx (P.Gid id) = convGLconst ctx id
| convId (Lctx { localVars, paramNum, ... }) (P.Lid id) =
if id < paramNum then (* function parameter *)
(Reg (id + Vector.length localVars))
@@ -576,8 +578,7 @@ functor IL(P: PARSER) = struct
Reg vl
end
- and convCast _ (v, _, P.void_t) = v
- | convCast ctx (v, fromT, toT) =
+ and convCastScalar ctx v fromT toT =
case Word.compare (P.sizeOfType toT, P.sizeOfType fromT) of
EQUAL => v
| LESS => (
@@ -613,6 +614,30 @@ functor IL(P: PARSER) = struct
Reg vNew
end
+ and convCast _ (v, _, P.void_t) = v
+ | convCast ctx (v, fromT, toT) =
+ if P.isArray fromT then
+ let
+ val elT = P.elementType fromT
+ val () =
+ if toT <> P.pointer_t (1, elT) then raise Unreachable else ()
+ in
+ case v of
+ Addr v => Reg v
+ | _ => raise Unreachable
+ end
+ else if P.isFunc fromT then
+ let
+ val () =
+ if toT <> P.pointer_t (1, fromT) then raise Unreachable else ()
+ in
+ case v of
+ Addr v => Reg v
+ | _ => raise Unreachable
+ end
+ else
+ convCastScalar ctx v fromT toT
+
and convUnop ctx unop ea t: ev =
let
val v: ev = convExpr ctx ea
@@ -1050,20 +1075,17 @@ functor IL(P: PARSER) = struct
val t = P.getT ea
val v = convExpr C ea
val v = loadIfNeeded C t v
+
in
- if #onStack $ Vector.sub (localVars, id) then
- ctxPutOp C (IrLoad (id, v, typeAccessClass t))
- else
+ if #onStack $ Vector.sub (localVars, id) then (
+ ctxPutOp C (IrAlloc (id, 0w8, NONE));
+ ctxPutOp C (IrStore (id, v, typeAccessClass t))
+ ) else
ctxPutOp C (IrSet (id, SaVReg v))
end
| convIni ctx (id, SOME (P.CiniLayout lid)) =
let
- val size = P.getLayoutSize lid
- val () =
- if Word.mod (size, 0w8) <> 0w0 then
- raise Unreachable
- else
- ()
+ val size = wrapTo8 $ P.getLayoutSize lid
in
ctxPutOp ctx (IrAlloc (id, size, NONE));
ctxPutOp ctx (IrCopy (id, lid, size))
@@ -1340,7 +1362,7 @@ functor IL(P: PARSER) = struct
end
fun printCopy (to, from, size) =
- dprintf `"\tcopy " Preg ctx to `", .I" I from `", " W size %
+ dprintf `"\tcopy " Preg ctx to `", I." I from `", " W size %
fun printFcall (ret, f, args) =
let
@@ -1353,6 +1375,7 @@ functor IL(P: PARSER) = struct
in
dprintf `"fcall " Preg ctx f `"" Plist (preg ctx) args (", ", true, 0) %
end
+
fun printLabel (Lctx { labels, ... }) lid =
let
val (labelPos, use) = D.get labels lid
@@ -1373,6 +1396,15 @@ functor IL(P: PARSER) = struct
| Cmpsg => "cmpsg"
| Cmpsle => "cmpsle"
| Cmpsge => "cmpsge"
+
+ fun pjc (op', r1, r2, lid) =
+ let
+ val opRepr = cmpOpStr op'
+ val opRepr = "jmp" ^ String.extract (opRepr, 3, NONE)
+ in
+ dprintf `"\t" `opRepr `" "
+ Preg ctx r1 `", " Preg ctx r2 `", " Pl lid %
+ end
in
case op' of
IrSet (reg, arg) => printOpSet ctx reg arg
@@ -1401,6 +1433,7 @@ functor IL(P: PARSER) = struct
| IrStore (r1, r2, ac) =>
dprintf `"\t" Pac ac `" [" Preg ctx r1 `"] <- " Preg ctx r2 %
| IrJmp l => dprintf `"\tjmp " Pl l %
+ | IrJmpc q => pjc q
| IrJz p => pj p "jz"
| IrJnz p => pj p "jnz"
| IrNopLabel l => printLabel ctx l
@@ -1681,7 +1714,7 @@ functor IL(P: PARSER) = struct
| IrAlloc _ | IrLoad _ | IrStore _ | IrRet _ | IrFcall _
| IrCopy _ | IrJz _ | IrJnz _ => RtReg
- | IrJmp _ | IrNop _ | IrNopLabel _ => raise Unreachable
+ | IrJmpc _ | IrJmp _ | IrNop _ | IrNopLabel _ => raise Unreachable
end
fun eval (SOME ins) vregs =
@@ -1800,63 +1833,129 @@ functor IL(P: PARSER) = struct
| IrRet NONE => raise Unreachable
| IrSet (_, arg) => IrSet (rd, arg)
| IrNop _ | IrNopLabel _ | IrAlloc _ | IrCopy _ | IrJmp _ | IrJz _
- | IrJnz _ | IrStore _ => raise Unreachable
+ | IrJmpc _ | IrJnz _ | IrStore _ => raise Unreachable
end
- fun mergeIns (Lctx { vregs, ops, ... }) idx rd rs =
+ fun removeVR vregs vr =
let
- val () = dprintf `"removing %" I rs `"\n" %
-
- val { class, ... } = D.get vregs rs
- val () = D.set vregs rs
+ val { class, ... } = D.get vregs vr
+ in
+ D.set vregs vr
{ defs = [], use = [], class, t = RtRem, canFold = false }
- val ins = valOf o #1 $ D.get ops (idx - 1)
- val ir = changeDest rd ins
+ end
+
+ fun changeIns ops idx ins =
+ let
+ fun f (SOME _, v) = (ins, v)
+ | f (NONE, _) = raise Unreachable
+ in
+ D.update ops f idx
+ end
- fun f1 (SOME _, v) = (SOME ir, v)
- | f1 (NONE, _) = raise Unreachable
- fun f2 (SOME _, v) = (NONE, v)
- | f2 (NONE, _) = raise Unreachable
+ fun changeEl from to (x :: xs) acc =
+ changeEl from to xs $ (if x = from then to else x) :: acc
+ | changeEl _ _ [] acc = rev acc
- val () = D.update ops f1 (idx - 1)
- val () = D.update ops f2 idx
+ fun changeDef vregs vr from to =
+ let
+ val { defs, use, class, t, canFold } = D.get vregs vr
+ in
+ D.set vregs vr { defs = changeEl from to defs [], use, class, t,
+ canFold }
+ end
- val { defs, use, class, t, canFold } = D.get vregs rd
+ fun changeUse vregs vr from to =
+ let
+ val { defs, use, class, t, canFold } = D.get vregs vr
+ in
+ D.set vregs vr { defs, use = changeEl from to use [], class, t,
+ canFold }
+ end
- fun loop (d :: ds) acc =
- loop ds $ (if d = idx then idx - 1 else d) :: acc
- | loop [] acc = rev acc
- val () = D.set vregs rd { defs = loop defs [], use, class, t, canFold }
+ fun singleDefUse vregs vr =
+ let
+ val { defs, use, ... } = D.get vregs vr
in
- ()
+ case (defs, use) of
+ ([d], [_]) => SOME d
+ | _ => NONE
end
- fun optSet (C as Lctx { vregs, localVars, paramNum, ... })
+ fun fuseSet (Lctx { vregs, localVars, paramNum, ops, ... })
(idx, (SOME (IrSet (rd, SaVReg rs)), _))
=
if getCS vregs rd <> getCS vregs rs then
()
- else
- let
- val { defs, use, ... } = D.get vregs rs
- in
- case (defs, use) of
- ([d], [_]) =>
- if d = idx - 1 andalso rs >= Vector.length localVars + paramNum
- then
- mergeIns C idx rd rs
- else
- ()
- | _ => ()
- end
- | optSet _ _ = ()
+ else (
+ case singleDefUse vregs rs of
+ NONE => ()
+ | SOME d => (
+ if d = idx - 1 andalso rs >= Vector.length localVars + paramNum
+ then
+ let
+ val () = dprintf `"fusing instruction " I d `" with " I idx %
+ val () = removeVR vregs rs
- fun peephole (C as Lctx { ops, ... }) =
- let
- val () = D.appi (optSet C) ops
- in
- ()
- end
+ val ins = valOf o #1 $ D.get ops (idx - 1)
+ val ir = changeDest rd ins
+
+ val () = changeIns ops (idx - 1) (SOME ir)
+ val () = changeIns ops idx NONE
+ in
+ changeDef vregs rd idx (idx - 1)
+ end
+ else
+ ()
+ )
+ )
+ | fuseSet _ _ = ()
+
+ fun convCmpOp op' false = op'
+ | convCmpOp op' true =
+ case op' of
+ Cmpeq => Cmpneq
+ | Cmpneq => Cmpeq
+ | Cmpul => Cmpuge
+ | Cmpug => Cmpule
+ | Cmpule => Cmpug
+ | Cmpuge => Cmpul
+ | Cmpsl => Cmpsge
+ | Cmpsg => Cmpsle
+ | Cmpsle => Cmpsg
+ | Cmpsge => Cmpsl
+
+ fun fuseJmpCommon (Lctx { ops, vregs, ... }) idx rs lid isRev =
+ case singleDefUse vregs rs of
+ NONE => ()
+ | SOME d => (
+ case #1 $ D.get ops d of
+ SOME (IrCmp (op', _, r1, r2)) =>
+ let
+ val () = dprintf `"fusing instruction " I d `" with " I idx %
+ val () = removeVR vregs rs
+ val () = changeUse vregs r1 d idx
+ val () = changeUse vregs r2 d idx
+ val ins = IrJmpc (convCmpOp op' isRev, r1, r2, lid)
+ in
+ changeIns ops d NONE;
+ changeIns ops idx (SOME ins)
+ end
+ | _ => ()
+ )
+
+ fun fuseJmpc C (idx, (ins, _)) =
+ case ins of
+ SOME (IrJnz (rs, lid)) => fuseJmpCommon C idx rs lid false
+ | SOME (IrJz (rs, lid)) => fuseJmpCommon C idx rs lid true
+ | _ => ()
+
+ fun lowerMul C (idx, (ins, _)) = raise Unimplemented
+
+ fun peephole (C as Lctx { ops, ... }) = (
+ D.appi (fuseSet C) ops;
+ D.appi (fuseJmpc C) ops;
+ D.appi (lowerMul C) ops
+ )
fun removeUnusedLabels (Lctx { ops, labels, ... }) =
let