Skip to content

Commit

Permalink
Remove the monolithic optimization pass
Browse files Browse the repository at this point in the history
  • Loading branch information
@minoki
minoki committed Jul 7, 2024
1 parent 6bb2156 commit e01609b
Show file tree
Hide file tree
Showing 5 changed files with 0 additions and 871 deletions.
1 change: 0 additions & 1 deletion Makefile
View file
Original file line number Diff line number Diff line change
Expand Up @@ -56,7 +56,6 @@ sources = \
src/cps/inline.sml \
src/cps/decompose-recursive.sml \
src/cps/unpack-record-parameter.sml \
src/cps/misc.sml \
src/lua-syntax.sml \
src/lua-transform.sml \
src/codegen-lua.sml \
Expand Down
323 changes: 0 additions & 323 deletions src/cps.sml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -604,328 +604,6 @@ and transformX (ctx : Context, env) (exp : F.Exp) (revDecs : C.Dec list, k : con
end
end;

structure CpsDeadCodeAnalysis :> sig
type usage
val analyze : CSyntax.CExp -> usage
val isUsed : usage * TypedSyntax.VId -> bool
end = struct
local structure C = CSyntax
in
type graph = TypedSyntax.VIdSet.set TypedSyntax.VIdTable.hash_table
type usage = bool TypedSyntax.VIdTable.hash_table
fun addValue (C.Var v, set) = TypedSyntax.VIdSet.add (set, v)
| addValue (C.Unit, set) = set
| addValue (C.Nil, set) = set
| addValue (C.BoolConst _, set) = set
| addValue (C.IntConst _, set) = set
| addValue (C.WordConst _, set) = set
| addValue (C.CharConst _, set) = set
| addValue (C.Char16Const _, set) = set
| addValue (C.StringConst _, set) = set
| addValue (C.String16Const _, set) = set
fun goSimpleExp (_, C.PrimOp { primOp = _, tyargs = _, args }) = List.foldl addValue TypedSyntax.VIdSet.empty args
| goSimpleExp (_, C.Record fields) = Syntax.LabelMap.foldl addValue TypedSyntax.VIdSet.empty fields
| goSimpleExp (_, C.ExnTag { name = _, payloadTy = _ }) = TypedSyntax.VIdSet.empty
| goSimpleExp (_, C.Projection { label = _, record, fieldTypes = _ }) = addValue (record, TypedSyntax.VIdSet.empty)
| goSimpleExp (g, C.Abs { contParam = _, params = _, body, attr = _ }) = goExp (g, body, TypedSyntax.VIdSet.empty) (* What to do with params? *)
and goDec g (C.ValDec { exp, results }, acc) = let val s = goSimpleExp (g, exp)
in List.app (fn SOME r => TypedSyntax.VIdTable.insert g (r, s)
| NONE => ()) results
; if C.isDiscardable exp then
acc
else
TypedSyntax.VIdSet.union (acc, s)
end
| goDec g (C.RecDec defs, acc) = let val s = List.foldl (fn ({ body, ... }, acc) => goExp (g, body, acc)) acc defs
in List.app (fn { name, ... } => TypedSyntax.VIdTable.insert g (name, s)) defs
; acc
end
| goDec g (C.ContDec { name = _, params = _, body }, acc) = goExp (g, body, acc)
| goDec g (C.RecContDec defs, acc) = List.foldl (fn ((_, _, body), acc) => goExp (g, body, acc)) acc defs
| goDec g (C.ESImportDec { pure = _, specs, moduleName = _ }, acc) = ( List.app (fn (_, vid) => TypedSyntax.VIdTable.insert g (vid, TypedSyntax.VIdSet.empty)) specs
; acc
)
and goExp (g, C.Let { decs, cont }, acc) = goExp (g, cont, List.foldl (goDec g) acc decs)
| goExp (_, C.App { applied, cont = _, args, attr = _ }, acc) = List.foldl addValue (addValue (applied, acc)) args
| goExp (_, C.AppCont { applied = _, args }, acc) = List.foldl addValue acc args
| goExp (g, C.If { cond, thenCont, elseCont }, acc) = goExp (g, elseCont, goExp (g, thenCont, addValue (cond, acc)))
| goExp (g, C.Handle { body, handler = (_, h), successfulExitIn = _, successfulExitOut = _ }, acc) = goExp (g, body, goExp (g, h, acc))
| goExp (_, C.Unreachable, acc) = acc
(*: val makeGraph : CSyntax.CExp -> graph * TypedSyntax.VIdSet.set *)
fun makeGraph program = let val g = TypedSyntax.VIdTable.mkTable (1, Fail "dead code analysis table lookup failed")
in (g, goExp (g, program, TypedSyntax.VIdSet.empty))
end
fun analyze program = let val (g, root) = makeGraph program
val usage = TypedSyntax.VIdTable.mkTable (1, Fail "dead code analysis table lookup failed")
fun go vid = case TypedSyntax.VIdTable.find usage vid of
SOME true => ()
| _ => ( TypedSyntax.VIdTable.insert usage (vid, true)
; case TypedSyntax.VIdTable.find g vid of
SOME set => TypedSyntax.VIdSet.app go set
| NONE => ()
)
in TypedSyntax.VIdSet.app go root
; usage
end
fun isUsed (usage, vid) = case TypedSyntax.VIdTable.find usage vid of
SOME true => true
| _ => false
end (* local *)
end (* structure CpsDeadCodeAnalysis *)

structure CpsUsageAnalysis :> sig
datatype frequency = NEVER | ONCE | MANY
type usage = { call : frequency
, project : frequency
, ref_read : frequency
, ref_write : frequency
, other : frequency
, returnConts : CSyntax.CVarSet.set
, labels : (string option) Syntax.LabelMap.map
}
type cont_usage = { direct : frequency, indirect : frequency }
val neverUsed : usage
val neverUsedCont : cont_usage
type usage_table
type cont_usage_table
val getValueUsage : usage_table * TypedSyntax.VId -> usage
val getContUsage : cont_usage_table * CSyntax.CVar -> cont_usage
val analyze : CSyntax.CExp -> { usage : usage_table
, rec_usage : usage_table
, cont_usage : cont_usage_table
, cont_rec_usage : cont_usage_table
, dead_code_analysis : CpsDeadCodeAnalysis.usage
}
end = struct
local structure C = CSyntax
in
datatype frequency = NEVER | ONCE | MANY
fun oneMore NEVER = ONCE
| oneMore ONCE = MANY
| oneMore (many as MANY) = many
type usage = { call : frequency
, project : frequency
, ref_read : frequency
, ref_write : frequency
, other : frequency
, returnConts : CSyntax.CVarSet.set
, labels : (string option) Syntax.LabelMap.map
}
type cont_usage = { direct : frequency, indirect : frequency }
val neverUsed : usage = { call = NEVER
, project = NEVER
, ref_read = NEVER
, ref_write = NEVER
, other = NEVER
, returnConts = CSyntax.CVarSet.empty
, labels = Syntax.LabelMap.empty
}
val neverUsedCont : cont_usage = { direct = NEVER, indirect = NEVER }
type usage_table = (usage ref) TypedSyntax.VIdTable.hash_table
type cont_usage_table = (cont_usage ref) CSyntax.CVarTable.hash_table
fun getValueUsage (table : usage_table, v)
= case TypedSyntax.VIdTable.find table v of
SOME r => !r
| NONE => { call = MANY, project = MANY, ref_read = MANY, ref_write = MANY, other = MANY, returnConts = CSyntax.CVarSet.empty, labels = Syntax.LabelMap.empty } (* unknown *)
fun getContUsage (table : cont_usage_table, c)
= case CSyntax.CVarTable.find table c of
SOME r => !r
| NONE => { direct = MANY, indirect = MANY } (* unknown *)
fun useValue env (C.Var v) = (case TypedSyntax.VIdTable.find env v of
SOME r => let val { call, project, ref_read, ref_write, other, returnConts, labels } = !r
in r := { call = call, project = project, ref_read = ref_read, ref_write = ref_write, other = oneMore other, returnConts = returnConts, labels = labels }
end
| NONE => ()
)
| useValue _ C.Unit = ()
| useValue _ C.Nil = ()
| useValue _ (C.BoolConst _) = ()
| useValue _ (C.IntConst _) = ()
| useValue _ (C.WordConst _) = ()
| useValue _ (C.CharConst _) = ()
| useValue _ (C.Char16Const _) = ()
| useValue _ (C.StringConst _) = ()
| useValue _ (C.String16Const _) = ()
fun useValueAsCallee (env, cont, C.Var v)
= (case TypedSyntax.VIdTable.find env v of
SOME r => let val { call, project, ref_read, ref_write, other, returnConts, labels } = !r
in r := { call = oneMore call, project = project, ref_read = ref_read, ref_write = ref_write, other = other, returnConts = C.CVarSet.add (returnConts, cont), labels = labels }
end
| NONE => ()
)
| useValueAsCallee (_, _, C.Unit) = ()
| useValueAsCallee (_, _, C.Nil) = ()
| useValueAsCallee (_, _, C.BoolConst _) = ()
| useValueAsCallee (_, _, C.IntConst _) = ()
| useValueAsCallee (_, _, C.WordConst _) = ()
| useValueAsCallee (_, _, C.CharConst _) = ()
| useValueAsCallee (_, _, C.Char16Const _) = ()
| useValueAsCallee (_, _, C.StringConst _) = ()
| useValueAsCallee (_, _, C.String16Const _) = ()
fun useValueAsRecord (env, label, result, C.Var v)
= (case TypedSyntax.VIdTable.find env v of
SOME r => let val { call, project, ref_read, ref_write, other, returnConts, labels } = !r
val result' = case result of
SOME (TypedSyntax.MkVId (name, _)) => SOME name
| NONE => NONE
fun mergeOption (x as SOME _, _) = x
| mergeOption (NONE, y) = y
in r := { call = call, project = oneMore project, ref_read = ref_read, ref_write = ref_write, other = other, returnConts = returnConts, labels = Syntax.LabelMap.insertWith mergeOption (labels, label, result') }
end
| NONE => ()
)
| useValueAsRecord (_, _, _, C.Unit) = ()
| useValueAsRecord (_, _, _, C.Nil) = ()
| useValueAsRecord (_, _, _, C.BoolConst _) = ()
| useValueAsRecord (_, _, _, C.IntConst _) = ()
| useValueAsRecord (_, _, _, C.WordConst _) = ()
| useValueAsRecord (_, _, _, C.CharConst _) = ()
| useValueAsRecord (_, _, _, C.Char16Const _) = ()
| useValueAsRecord (_, _, _, C.StringConst _) = ()
| useValueAsRecord (_, _, _, C.String16Const _) = ()
fun useValueAsRefRead (env, C.Var v)
= (case TypedSyntax.VIdTable.find env v of
SOME r => let val { call, project, ref_read, ref_write, other, returnConts, labels } = !r
in r := { call = call, project = project, ref_read = oneMore ref_read, ref_write = ref_write, other = other, returnConts = returnConts, labels = labels }
end
| NONE => ()
)
| useValueAsRefRead (_, C.Unit) = ()
| useValueAsRefRead (_, C.Nil) = ()
| useValueAsRefRead (_, C.BoolConst _) = ()
| useValueAsRefRead (_, C.IntConst _) = ()
| useValueAsRefRead (_, C.WordConst _) = ()
| useValueAsRefRead (_, C.CharConst _) = ()
| useValueAsRefRead (_, C.Char16Const _) = ()
| useValueAsRefRead (_, C.StringConst _) = ()
| useValueAsRefRead (_, C.String16Const _) = ()
fun useValueAsRefWrite (env, C.Var v)
= (case TypedSyntax.VIdTable.find env v of
SOME r => let val { call, project, ref_read, ref_write, other, returnConts, labels } = !r
in r := { call = call, project = project, ref_read = ref_read, ref_write = oneMore ref_write, other = other, returnConts = returnConts, labels = labels }
end
| NONE => ()
)
| useValueAsRefWrite (_, C.Unit) = ()
| useValueAsRefWrite (_, C.Nil) = ()
| useValueAsRefWrite (_, C.BoolConst _) = ()
| useValueAsRefWrite (_, C.IntConst _) = ()
| useValueAsRefWrite (_, C.WordConst _) = ()
| useValueAsRefWrite (_, C.CharConst _) = ()
| useValueAsRefWrite (_, C.Char16Const _) = ()
| useValueAsRefWrite (_, C.StringConst _) = ()
| useValueAsRefWrite (_, C.String16Const _) = ()
fun useContVarIndirect cenv (v : C.CVar) = (case C.CVarTable.find cenv v of
SOME r => let val { direct, indirect } = !r
in r := { direct = direct, indirect = oneMore indirect }
end
| NONE => ()
)
fun useContVarDirect cenv (v : C.CVar) = (case C.CVarTable.find cenv v of
SOME r => let val { direct, indirect } = !r
in r := { direct = oneMore direct, indirect = indirect }
end
| NONE => ()
)
local
fun add (env, v) = if TypedSyntax.VIdTable.inDomain env v then
raise Fail ("goCExp: duplicate name in AST: " ^ TypedSyntax.print_VId v)
else
TypedSyntax.VIdTable.insert env (v, ref neverUsed)
fun addC (cenv, v) = if C.CVarTable.inDomain cenv v then
raise Fail ("goCExp: duplicate continuation name in AST: " ^ Int.toString (C.CVar.toInt v))
else
C.CVarTable.insert cenv (v, ref neverUsedCont)
in
fun goSimpleExp (env, _, _, _, _, C.PrimOp { primOp = FSyntax.PrimCall Primitives.Ref_set, tyargs = _, args = [r, v] }) = (useValueAsRefWrite (env, r); useValue env v)
| goSimpleExp (env, _, _, _, _, C.PrimOp { primOp = FSyntax.PrimCall Primitives.Ref_read, tyargs = _, args = [r] }) = useValueAsRefRead (env, r)
| goSimpleExp (env, _, _, _, _, C.PrimOp { primOp = _, tyargs = _, args }) = List.app (useValue env) args
| goSimpleExp (env, _, _, _, _, C.Record fields) = Syntax.LabelMap.app (useValue env) fields
| goSimpleExp (_, _, _, _, _, C.ExnTag { name = _, payloadTy = _ }) = ()
| goSimpleExp (env, _, _, _, results, C.Projection { label, record, fieldTypes = _ }) = (case results of
[result] => useValueAsRecord (env, label, result, record)
| _ => () (* should not occur *)
)
| goSimpleExp (env, renv, cenv, crenv, _, C.Abs { contParam, params, body, attr = _ })
= ( List.app (fn p => add (env, p)) params
; addC (cenv, contParam)
; goCExp (env, renv, cenv, crenv, body)
)
and goDec (env, renv, cenv, crenv)
= fn C.ValDec { exp, results } =>
( goSimpleExp (env, renv, cenv, crenv, results, exp)
; List.app (fn SOME result => add (env, result)
| NONE => ()
) results
)
| C.RecDec defs =>
let val recursiveEnv = List.foldl (fn ({ name, ... }, m) => TypedSyntax.VIdMap.insert (m, name, ref neverUsed)) TypedSyntax.VIdMap.empty defs
in TypedSyntax.VIdMap.appi (fn (f, v) => TypedSyntax.VIdTable.insert env (f, v)) recursiveEnv
; List.app (fn { contParam, params, body, ... } =>
( addC (cenv, contParam)
; List.app (fn p => add (env, p)) params
; goCExp (env, renv, cenv, crenv, body)
)
) defs
; TypedSyntax.VIdMap.appi (fn (f, v) => TypedSyntax.VIdTable.insert renv (f, v)) recursiveEnv
; List.app (fn { name, ... } => TypedSyntax.VIdTable.insert env (name, ref neverUsed)) defs
end
| C.ContDec { name, params, body } =>
( List.app (Option.app (fn p => add (env, p))) params
; goCExp (env, renv, cenv, crenv, body)
; addC (cenv, name)
)
| C.RecContDec defs =>
let val recursiveCEnv = List.foldl (fn ((f, _, _), m) => C.CVarMap.insert (m, f, ref neverUsedCont)) C.CVarMap.empty defs
in C.CVarMap.appi (fn (f, v) => C.CVarTable.insert cenv (f, v)) recursiveCEnv
; List.app (fn (_, params, body) => ( List.app (Option.app (fn p => add (env, p))) params
; goCExp (env, renv, cenv, crenv, body)
)
) defs
; C.CVarMap.appi (fn (f, v) => C.CVarTable.insert crenv (f, v)) recursiveCEnv
; List.app (fn (f, _, _) => C.CVarTable.insert cenv (f, ref neverUsedCont)) defs
end
| C.ESImportDec { pure = _, specs, moduleName = _ } => List.app (fn (_, vid) => add (env, vid)) specs
and goCExp (env : (usage ref) TypedSyntax.VIdTable.hash_table, renv, cenv : (cont_usage ref) C.CVarTable.hash_table, crenv, cexp)
= case cexp of
C.Let { decs, cont } =>
( List.app (goDec (env, renv, cenv, crenv)) decs
; goCExp (env, renv, cenv, crenv, cont)
)
| C.App { applied, cont, args, attr = _ } =>
( useValueAsCallee (env, cont, applied)
; useContVarIndirect cenv cont
; List.app (useValue env) args
)
| C.AppCont { applied, args } =>
( useContVarDirect cenv applied
; List.app (useValue env) args
)
| C.If { cond, thenCont, elseCont } =>
( useValue env cond
; goCExp (env, renv, cenv, crenv, thenCont)
; goCExp (env, renv, cenv, crenv, elseCont)
)
| C.Handle { body, handler = (e, h), successfulExitIn, successfulExitOut } =>
( useContVarIndirect cenv successfulExitOut
; addC (cenv, successfulExitIn)
; goCExp (env, renv, cenv, crenv, body)
; add (env, e)
; goCExp (env, renv, cenv, crenv, h)
)
| C.Unreachable => ()
end (* local *)
fun analyze exp = let val dca = CpsDeadCodeAnalysis.analyze exp
val usage = TypedSyntax.VIdTable.mkTable (1, Fail "usage table lookup failed")
val rusage = TypedSyntax.VIdTable.mkTable (1, Fail "rusage table lookup failed")
val cusage = CSyntax.CVarTable.mkTable (1, Fail "cusage table lookup failed")
val crusage = CSyntax.CVarTable.mkTable (1, Fail "crusage table lookup failed")
in goCExp (usage, rusage, cusage, crusage, exp)
; { usage = usage, rec_usage = rusage, cont_usage = cusage, cont_rec_usage = crusage, dead_code_analysis = dca }
end
end (* local *)
end (* strucuture CpsUsageAnalysis *)

structure CpsSimplify :> sig
type Context = { nextVId : int ref
, simplificationOccurred : bool ref
Expand All @@ -946,7 +624,6 @@ structure CpsSimplify :> sig
end = struct
local structure F = FSyntax
structure C = CSyntax
datatype frequency = datatype CpsUsageAnalysis.frequency
in
type Context = { nextVId : int ref
, simplificationOccurred : bool ref
Expand Down
Loading

0 comments on commit e01609b

Please sign in to comment.