diff --git a/src/main/compile.mc b/src/main/compile.mc index e8a0b0377..75216c75d 100644 --- a/src/main/compile.mc +++ b/src/main/compile.mc @@ -15,6 +15,7 @@ include "mexpr/shallow-patterns.mc" include "mexpr/symbolize.mc" include "mexpr/type-check.mc" include "mexpr/utest-generate.mc" +include "mexpr/constant-fold.mc" include "ocaml/ast.mc" include "ocaml/external-includes.mc" include "ocaml/mcore.mc" @@ -35,6 +36,7 @@ lang MCoreCompile = MExprUtestGenerate + MExprRuntimeCheck + MExprProfileInstrument + MExprPrettyPrint + MExprLowerNestedPatterns + + MExprConstantFold + OCamlTryWithWrap + MCoreCompileLang + PhaseStats + SpecializeCompile + PprintTyAnnot + HtmlAnnotator @@ -92,6 +94,14 @@ let compileWithUtests = lam options : Options. lam sourcePath. lam ast. let ast = generateUtest options.runTests ast in endPhaseStats log "generate-utest" ast; + let ast = + if and (options.enableConstantFold) (not options.disableOptimizations) + then constantFold ast else ast + in + endPhaseStats log "constant folding" ast; + (if options.debugConstantFold then + printLn (expr2str ast) else ()); + let ast = lowerAll ast in endPhaseStats log "pattern-lowering" ast; (if options.debugShallow then diff --git a/src/main/options-config.mc b/src/main/options-config.mc index 2284e59da..18e4c80d0 100644 --- a/src/main/options-config.mc +++ b/src/main/options-config.mc @@ -31,6 +31,10 @@ let optionsConfig : ParseConfig Options = [ "Print the AST after lowering nested patterns to shallow ones", lam p: ArgPart Options. let o: Options = p.options in {o with debugShallow = true}), + ([("--debug-constant-fold", "", "")], + "Print the AST after constant folding and constant propagation", + lam p: ArgPart Options. + let o: Options = p.options in {o with debugConstantFold = true}), ([("--debug-phases", "", "")], "Show debug and profiling information about each pass", lam p: ArgPart Options. @@ -60,6 +64,10 @@ let optionsConfig : ParseConfig Options = [ "Disables optimizations to decrease compilation time", lam p: ArgPart Options. let o: Options = p.options in {o with disableOptimizations = true}), + ([("--enable-constant-fold", "", "")], + "Enables constant folding and constant propagation", + lam p: ArgPart Options. + let o: Options = p.options in {o with enableConstantFold = true}), ([("--tuned", "", "")], "Use tuned values when compiling, or as defaults when tuning", lam p: ArgPart Options. diff --git a/src/main/options-type.mc b/src/main/options-type.mc index 52e6fcbc9..29a8f97e3 100644 --- a/src/main/options-type.mc +++ b/src/main/options-type.mc @@ -9,6 +9,7 @@ type Options = { debugTypeCheck : Bool, debugProfile : Bool, debugShallow : Bool, + debugConstantFold : Bool, debugPhases : Bool, exitBefore : Bool, disablePruneExternalUtests : Bool, @@ -16,6 +17,7 @@ type Options = { runTests : Bool, runtimeChecks : Bool, disableOptimizations : Bool, + enableConstantFold : Bool, useTuned : Bool, compileAfterTune : Bool, accelerate : Bool, diff --git a/src/main/options.mc b/src/main/options.mc index b870e4725..7be139061 100644 --- a/src/main/options.mc +++ b/src/main/options.mc @@ -12,6 +12,7 @@ let optionsDefault : Options = { debugTypeCheck = false, debugProfile = false, debugShallow = false, + debugConstantFold = false, debugPhases = false, exitBefore = false, disablePruneExternalUtests = false, @@ -19,6 +20,7 @@ let optionsDefault : Options = { runTests = false, runtimeChecks = false, disableOptimizations = false, + enableConstantFold = false, useTuned = false, compileAfterTune = false, accelerate = false, diff --git a/stdlib/ad/dualnum-lift.mc b/stdlib/ad/dualnum-lift.mc index ff67f97e4..3dca01b2e 100644 --- a/stdlib/ad/dualnum-lift.mc +++ b/stdlib/ad/dualnum-lift.mc @@ -362,30 +362,32 @@ utest geqn _num2 (_dnum _e2 _dnum112 _num3) with true -- ARITHMETIC OPERATORS -- --------------------------- +let _eqfApprox = eqfApprox 1.e-6 + -- lifted addition -utest addn _num1 _num2 with _num3 using dualnumEq eqf -utest addn _dnum010 _num2 with _dnum0 _num3 _num0 using dualnumEq eqf -utest addn _dnum011 _num2 with _dnum031 using dualnumEq eqf -utest addn _dnum011 _dnum011 with _dnum022 using dualnumEq eqf -utest addn _dnum011 _dnum111 with _dnum1 _dnum021 _num1 using dualnumEq eqf +utest addn _num1 _num2 with _num3 using dualnumEq _eqfApprox +utest addn _dnum010 _num2 with _dnum0 _num3 _num0 using dualnumEq _eqfApprox +utest addn _dnum011 _num2 with _dnum031 using dualnumEq _eqfApprox +utest addn _dnum011 _dnum011 with _dnum022 using dualnumEq _eqfApprox +utest addn _dnum011 _dnum111 with _dnum1 _dnum021 _num1 using dualnumEq _eqfApprox -- lifted multiplication -utest muln _num1 _num2 with _num2 using dualnumEq eqf -utest muln _dnum010 _num2 with _dnum0 _num2 _num0 using dualnumEq eqf -utest muln _dnum011 _num2 with _dnum022 using dualnumEq eqf -utest muln _dnum012 _dnum034 with _dnum0 _num3 _num10 using dualnumEq eqf -utest muln _dnum012 _dnum134 with _dnum1 _dnum036 _dnum048 using dualnumEq eqf +utest muln _num1 _num2 with _num2 using dualnumEq _eqfApprox +utest muln _dnum010 _num2 with _dnum0 _num2 _num0 using dualnumEq _eqfApprox +utest muln _dnum011 _num2 with _dnum022 using dualnumEq _eqfApprox +utest muln _dnum012 _dnum034 with _dnum0 _num3 _num10 using dualnumEq _eqfApprox +utest muln _dnum012 _dnum134 with _dnum1 _dnum036 _dnum048 using dualnumEq _eqfApprox -- lifted negation let negn = lam p. _lift1 negf (lam. Primal (negf 1.)) p -utest negn _num1 with Primal (negf 1.) using dualnumEq eqf -utest negn _num0 with Primal (negf 0.) using dualnumEq eqf -utest negn _dnum010 with _dnum0 (Primal (negf 1.)) _num0 using dualnumEq eqf +utest negn _num1 with Primal (negf 1.) using dualnumEq _eqfApprox +utest negn _num0 with Primal (negf 0.) using dualnumEq _eqfApprox +utest negn _dnum010 with _dnum0 (Primal (negf 1.)) _num0 using dualnumEq _eqfApprox utest negn _dnum012 with _dnum0 (Primal (negf 1.)) (Primal (negf 2.)) -using dualnumEq eqf +using dualnumEq _eqfApprox -utest der negn _num1 with negn _num1 using dualnumEq eqf +utest der negn _num1 with negn _num1 using dualnumEq _eqfApprox -- lifted subtraction let subn = lam p1. lam p2. @@ -395,15 +397,15 @@ let subn = lam p1. lam p2. (lam. lam. negn (Primal 1.)) p1 p2 -utest subn _num2 _num1 with _num1 using dualnumEq eqf -utest subn _dnum020 _num1 with _dnum0 _num1 _num0 using dualnumEq eqf -utest subn _dnum021 _num1 with _dnum011 using dualnumEq eqf -utest subn _dnum022 _dnum011 with _dnum011 using dualnumEq eqf +utest subn _num2 _num1 with _num1 using dualnumEq _eqfApprox +utest subn _dnum020 _num1 with _dnum0 _num1 _num0 using dualnumEq _eqfApprox +utest subn _dnum021 _num1 with _dnum011 using dualnumEq _eqfApprox +utest subn _dnum022 _dnum011 with _dnum011 using dualnumEq _eqfApprox utest let r = subn _dnum122 _dnum011 in dualnumPrimal _e1 r -with _dnum0 _num1 (Primal (negf 1.)) using dualnumEq eqf +with _dnum0 _num1 (Primal (negf 1.)) using dualnumEq _eqfApprox -- lifted abs @@ -425,16 +427,16 @@ recursive p1 p2 end -utest divn _num4 _num2 with _num2 using dualnumEq eqf -utest divn _dnum040 _num2 with _dnum0 _num2 _num0 using dualnumEq eqf -utest divn _dnum044 _num2 with _dnum022 using dualnumEq eqf +utest divn _num4 _num2 with _num2 using dualnumEq _eqfApprox +utest divn _dnum040 _num2 with _dnum0 _num2 _num0 using dualnumEq _eqfApprox +utest divn _dnum044 _num2 with _dnum022 using dualnumEq _eqfApprox utest divn _dnum012 _dnum034 -with _dnum0 (Primal (divf 1. 3.)) (Primal (divf 2. 9.)) using dualnumEq eqf +with _dnum0 (Primal (divf 1. 3.)) (Primal (divf 2. 9.)) using dualnumEq _eqfApprox utest divn _dnum012 _dnum134 with _dnum1 (_dnum0 (Primal (divf 1. 3.)) (Primal (divf 2. 3.))) (_dnum0 (Primal (divf (negf 4.) 9.)) (Primal (divf (negf 8.) 9.))) -using dualnumEq eqf +using dualnumEq _eqfApprox diff --git a/stdlib/list.mc b/stdlib/list.mc index 96f77b475..cac961727 100644 --- a/stdlib/list.mc +++ b/stdlib/list.mc @@ -85,6 +85,23 @@ let listEq : all a. all b. (a -> b -> Bool) -> List a -> List b -> Bool = end in work +let listAll : all a. (a -> Bool) -> List a -> Bool = lam p. lam li. + recursive let forAll = lam li. + switch li + case Cons (x, li) then + if p x then forAll li else false + case Nil _ then true + end + in + forAll li + +let listFilter : all a. (a -> Bool) -> List a -> List a = lam p. lam li. + listReverse + (listFoldl (lam acc. lam x. if p x then Cons (x, acc) else acc) (Nil ()) li) + +let listConcat : all a. List a -> List a -> List a = lam lhs. lam rhs. + listFoldl (lam acc. lam x. listCons x acc) rhs (listReverse lhs) + mexpr let l1 = listEmpty in @@ -119,4 +136,24 @@ utest l6 with Cons (3, Cons (4, Cons (5, Nil ()))) in utest listFoldl addi 0 l4 with 9 in utest listFoldl addi 0 l6 with 12 in +utest listAll (lti 2) (listFromSeq [4, 4, 5, 3]) with true in +utest listAll (gti 3) (listFromSeq [4, 4, 5, 3]) with false in + +utest listFilter (lti 2) (listFromSeq [4, 3, 5, 3]) + with listFromSeq [4, 3, 5, 3] +in +utest listFilter (lti 3) (listFromSeq [4, 3, 5, 3]) + with listFromSeq [4, 5] +in + +utest listConcat (listFromSeq [1, 2, 3]) (listFromSeq [4, 5]) + with listFromSeq [1, 2, 3, 4, 5] +in +utest listConcat (listFromSeq []) (listFromSeq [4, 5]) + with listFromSeq [4, 5] +in +utest let l : [Int] = [] in listConcat (listFromSeq l) (listFromSeq l) + with listFromSeq [] +in + () diff --git a/stdlib/mexpr/constant-fold.mc b/stdlib/mexpr/constant-fold.mc index cd3c9ca5f..ee6a1bb12 100644 --- a/stdlib/mexpr/constant-fold.mc +++ b/stdlib/mexpr/constant-fold.mc @@ -1,720 +1,679 @@ -/- +include "utest.mc" - This file contains a naive implementation of constant folding. +include "side-effect.mc" +include "eval.mc" +include "boot-parser.mc" +include "eq.mc" +include "pprint.mc" +include "symbolize.mc" +include "type-check.mc" +include "ast-builder.mc" - OPT(oerikss, 2023-05-16): The time complexity if this implementation is bad. +/- + This file implements constant folding and constant propagation +-/ + +-- Size limit on constant nodes that we want to propagate +let constantFoldCountMax = 100 + +lang ConstantFold = Eval + Ast + -- Entry point for constant folding and constant propagation over a program + sem constantFold : Expr -> Expr + sem constantFold =| t -> + readback (constantFoldExpr (evalCtxEmpty ()) t) + + -- Language framents should extend this semantic function. Note that the + -- evaluation environment should, at all time, only contain values that are + -- constants. See `isConstant` for the definition of a constant. + sem constantFoldExpr : EvalCtx -> Expr -> Expr + sem constantFoldExpr ctx =| t -> smap_Expr_Expr (constantFoldExpr ctx) t + + -- This semantic function restricts what is considered constants. + sem isConstant : Expr -> Bool + sem isConstant =| _ -> false + + -- This semantic function restricts what we propagate. + sem doPropagate : Expr -> Bool + sem doPropagate =| t -> + and (isConstant t) (lti (countNodes t) constantFoldCountMax) + + -- Constant folding may produce additional evaluation terms such as partial + -- applications of constants. This semantic function reads those back to + -- standard terms. + sem readback : Expr -> Expr + sem readback =| t -> smap_Expr_Expr readback t + + -- Counts the number of expression nodes. + sem countNodes : Expr -> Int + sem countNodes =| t -> countNodesH 0 t + + sem countNodesH : Int -> Expr -> Int + sem countNodesH n =| t -> + let n = addi n 1 in sfold_Expr_Expr countNodesH n t +end - NOTE(oerikss, 2023-05-16): The implementation relies on side-effect.mc to - handle side-effects. That implementatio is not well - tested so be aware if folding code with - side-effects. +lang VarConstantFold = ConstantFold + VarAst + sem constantFoldExpr ctx = + | TmVar r -> + match evalEnvLookup r.ident ctx.env with Some t then t + else TmVar r +end - -/ +lang AppConstantFold = ConstantFold + AppEval + ConstSideEffect + ConstArity + + syn Expr = + -- Partial constant application where all arguments are constant + | PartialConstAppConsts { expr : Expr, arity : Int } + -- Partial constant application where some argument is NOT constant + | PartialConstApp { expr : Expr, arity : Int } + + -- This semantic function is only be called with an expression representing a + -- constant function without side-effects applied on constant arguments. + sem constantFoldConstAppConsts : Expr -> Expr + sem constantFoldConstAppConsts = + | t -> constantFoldConstApp t + + -- This semantic function is only called with an expression representing a + -- constant function without side-effects applied to arguments that may not be + -- constants. + sem constantFoldConstApp : Expr -> Expr + sem constantFoldConstApp = + | t -> t + + sem constantFoldExpr ctx = + | TmApp appr -> + let lhs = constantFoldExpr ctx appr.lhs in + let rhs = constantFoldExpr ctx appr.rhs in + let t = TmApp { appr with lhs = lhs, rhs = rhs } in + switch (lhs, isConstant rhs) + -- Constant application on constant arguments + case (TmConst constr, true) then + if eqi (constArity constr.val) 1 then + constantFoldConstAppConsts t + else + PartialConstAppConsts { expr = t, arity = pred (constArity constr.val) } + case (PartialConstAppConsts pappr, true) then + let expr = TmApp { appr with lhs = pappr.expr, rhs = rhs } in + if neqi pappr.arity 1 then + PartialConstAppConsts { expr = expr, arity = pred pappr.arity } + else constantFoldConstAppConsts expr + -- Constant application with some non-constant arguments + case (TmConst constr, false) then + if eqi (constArity constr.val) 1 then + constantFoldConstApp t + else + PartialConstApp { expr = t, arity = pred (constArity constr.val) } + case + (PartialConstAppConsts pappr | PartialConstApp pappr, false) + | (PartialConstAppConsts pappr, true) + | (PartialConstApp pappr, true) + then + let expr = TmApp { appr with lhs = pappr.expr, rhs = rhs } in + if neqi pappr.arity 1 then + PartialConstApp { expr = expr, arity = pred pappr.arity } + else constantFoldConstApp expr + case _ then t + end -include "log.mc" + sem isConstant = + | PartialConstAppConsts _ -> true + | PartialConstApp _ -> false -include "ast.mc" -include "eval.mc" -include "pprint.mc" -include "boot-parser.mc" -include "side-effect.mc" + sem readback = + | PartialConstAppConsts r | PartialConstApp r -> readback r.expr +end -lang ConstantFoldCtx = Ast + SideEffect - type VarCount = Map Name Int - type ConstantFoldCtx = { - _vars : VarCount, - _env : Map Name Expr, - sideEffectEnv : SideEffectEnv - } - - sem constantfoldCtxEmpty : () -> ConstantFoldCtx - sem constantfoldCtxEmpty =| _ -> - { - _vars = mapEmpty nameCmp, - _env = mapEmpty nameCmp, - sideEffectEnv = sideEffectEnvEmpty () - } +lang LamAppConstantFold = ConstantFold + AppAst + LamAst + sem constantFoldExpr ctx = + | TmApp (appr & {lhs = TmLam lamr}) -> + let rhs = constantFoldExpr ctx appr.rhs in + if doPropagate rhs then + let ctx = { ctx with env = evalEnvInsert lamr.ident rhs ctx.env } in + constantFoldExpr ctx lamr.body + else + TmApp { + appr with + lhs = smap_Expr_Expr (constantFoldExpr ctx) (TmLam lamr), + rhs = rhs + } +end - sem constantfoldCtxReset : ConstantFoldCtx -> ConstantFoldCtx - sem constantfoldCtxReset =| ctx -> - { ctx with _vars = mapEmpty nameCmp, _env = mapEmpty nameCmp } - - sem constantfoldVarCount : Name -> ConstantFoldCtx -> Int - sem constantfoldVarCount id =| ctx -> - match mapLookup id ctx._vars with Some n then n else 0 - - sem constantfoldVarCountIncr : Name -> ConstantFoldCtx -> ConstantFoldCtx - sem constantfoldVarCountIncr id =| ctx -> - let _vars = - if mapMem id ctx._vars then - mapInsert id (addi (mapFindExn id ctx._vars) 1) ctx._vars - else mapInsert id 1 ctx._vars - in - { ctx with _vars = _vars } - - sem constantfoldVarCountDecr : Name -> ConstantFoldCtx -> ConstantFoldCtx - sem constantfoldVarCountDecr id =| ctx -> - let _vars = - switch mapLookup id ctx._vars - case Some 1 then mapRemove id ctx._vars - case Some n then mapInsert id (subi n 1) ctx._vars - case None _ then ctx._vars - end - in - { ctx with _vars = _vars } - - sem constantfoldEnvInsert : Name -> Expr -> ConstantFoldCtx -> ConstantFoldCtx - sem constantfoldEnvInsert id t =| ctx -> - { ctx with _env = mapInsert id t ctx._env } - - sem constantfoldEnvLookup : Name -> ConstantFoldCtx -> Option Expr - sem constantfoldEnvLookup id =| ctx -> mapLookup id ctx._env - - sem constantfoldEnvIsEmpty : ConstantFoldCtx -> Bool - sem constantfoldEnvIsEmpty =| ctx -> mapIsEmpty ctx._env +lang LetConstantFold = ConstantFold + LetAst + sem constantFoldExpr ctx = + | TmLet r -> + let body = constantFoldExpr ctx r.body in + if doPropagate body then + let ctx = { ctx with env = evalEnvInsert r.ident body ctx.env } in + constantFoldExpr ctx r.inexpr + else + TmLet { + r with + body = body, + inexpr = constantFoldExpr ctx r.inexpr + } end -lang ConstantFold = ConstantFoldCtx + MExprSideEffect + MExprPrettyPrint - sem _constantfoldExpr : ConstantFoldCtx -> Expr -> Expr - sem _constantfoldExpr ctx =| t -> - let t = innermost (optimizeOnce ctx) t in - -- logMsg logLevel.debug (lam. join ["innermost:\n", expr2str t]); - let ctx = updateCtx (constantfoldCtxReset ctx) t in - if constantfoldEnvIsEmpty ctx then t - else _constantfoldExpr ctx t - - sem constantfoldExpr : ConstantFoldCtx -> Expr -> Expr - sem constantfoldExpr ctx =| t -> - let ctx = { ctx with sideEffectEnv = constructSideEffectEnv t } in - let ctx = updateCtx (constantfoldCtxReset ctx) t in - _constantfoldExpr ctx t - - sem constantfold : Expr -> Expr - sem constantfold =| t -> constantfoldExpr (constantfoldCtxEmpty ()) t - - sem constantfoldLets : Expr -> Expr - sem constantfoldLets =| t -> - let ctx = updateCtx (constantfoldCtxEmpty ()) t in - recursive let inner = lam t. - switch t - case TmVar r then - optionMapOr t inner (constantfoldEnvLookup r.ident ctx) - case TmLet r then - if optionIsSome (constantfoldEnvLookup r.ident ctx) then - inner r.inexpr - else smap_Expr_Expr inner t - case t then - smap_Expr_Expr inner t - end - in - inner t - - sem updateCtx : ConstantFoldCtx -> Expr -> ConstantFoldCtx - sem updateCtx ctx = - | t -> sfold_Expr_Expr updateCtx ctx t - - sem innermost : (Expr -> Option Expr) -> Expr -> Expr - sem innermost f =| t1 -> - let t2 = smap_Expr_Expr (innermost f) t1 in - switch f t2 - case Some t3 then innermost f t3 - case None _ then t2 - end +lang RecordConstantFold = ConstantFold + RecordAst + sem isConstant = + | TmRecord r -> mapAll isConstant r.bindings +end - sem optimizeOnce : ConstantFoldCtx -> Expr -> Option Expr - sem optimizeOnce ctx =| _ -> None () +lang ConstConstantFold = ConstantFold + ConstAst + sem isConstant = + | TmConst _ -> true end -lang VarConstantFold = ConstantFold + VarAst - sem optimizeOnce ctx = - | TmVar r -> optionMap (lam x. x) (constantfoldEnvLookup r.ident ctx) +lang DataConstantFold = ConstantFold + DataAst + sem isConstant = + | TmConApp r -> isConstant r.body +end - sem updateCtx ctx = - | TmVar r -> constantfoldVarCountIncr r.ident ctx +lang MatchConstantFold = ConstantFold + MatchEval + sem constantFoldExpr ctx = + | TmMatch r -> + let target = constantFoldExpr ctx r.target in + if isConstant target then + match tryMatch ctx.env target r.pat with Some newEnv then + constantFoldExpr { ctx with env = newEnv } r.thn + else + constantFoldExpr ctx r.els + else + let newEnv = + match tryMatch (evalEnvEmpty ()) target r.pat with Some newEnv then + evalEnvConcat (evalEnvFilter (lam x. isConstant x.1) newEnv) ctx.env + else ctx.env + in + TmMatch { + r with + target = target, + thn = constantFoldExpr { ctx with env = newEnv } r.thn, + els = constantFoldExpr ctx r.els + } end -lang LamAppConstantFold = ConstantFold + LamAst + AppAst + VarAst + LetAst - sem optimizeOnce ctx = - -- | TmLam (lamr & ({body = TmApp {lhs = lhs, rhs = TmVar varr}})) -> - -- if and - -- (nameEqSymUnsafe lamr.ident varr.ident) - -- (eqi (constantfoldVarCount lamr.ident ctx) 1) - -- then Some lhs - -- else None () - | TmApp (appr & {lhs = TmLam lamr}) -> - let tyBody = tyTm appr.rhs in - Some (TmLet { - ident = lamr.ident, - tyAnnot = tyBody, - tyBody = tyBody, - body = appr.rhs, - inexpr = lamr.body, - ty = appr.ty, - info = appr.info - }) +lang SeqConstantFold = ConstantFold + SeqAst + sem isConstant = + | TmSeq r -> forAll isConstant r.tms end -lang LetConstantFold = ConstantFold + LetAst + ConstAst + LamAst - sem optimizeOnce ctx = - | TmLet r -> - if optionIsSome (constantfoldEnvLookup r.ident ctx) then Some r.inexpr - else None () +lang ArithIntConstantFold = AppConstantFold + ArithIntAst + ArithIntArity + sem constantFoldConstAppConsts = + | TmApp (r & { + lhs = TmConst {val = const & (CNegi _)}, + rhs = TmConst {val = CInt {val = n}} + }) -> + TmConst { val = CInt { val = negi n }, info = r.info, ty = r.ty } + | TmApp (r & { + lhs = TmApp { + lhs = TmConst { + val = const & (CAddi _ | CSubi _ | CMuli _ | CDivi _ | CModi _)}, + rhs = TmConst {val = CInt {val = n1}}}, + rhs = TmConst {val = CInt {val = n2}} + }) -> + TmConst { + val = CInt { val = constantFoldConstAppInt2 const n1 n2 }, + info = r.info, + ty = r.ty + } - sem updateCtx ctx = - | TmLet r -> - let ctx = updateCtx (updateCtx ctx r.body) r.inexpr in - switch r.body - case TmVar _ then constantfoldEnvInsert r.ident r.body ctx - case TmConst c | TmLam {body = TmConst c} then - if exprHasSideEffect ctx.sideEffectEnv r.body then ctx - else constantfoldEnvInsert r.ident r.body ctx - case body then - if and - (not (exprHasSideEffect ctx.sideEffectEnv body)) - (lti (constantfoldVarCount r.ident ctx) 2) - then constantfoldEnvInsert r.ident body ctx - else ctx - end + sem constantFoldConstAppInt2 : Const -> (Int -> Int -> Int) + sem constantFoldConstAppInt2 = + | CAddi _ -> addi + | CSubi _ -> subi + | CMuli _ -> muli + | CDivi _ -> divi + | CModi _ -> modi end -lang ArithFloatConstantFold = ConstantFold + ArithFloatEval + AppAst - sem optimizeOnce ctx = - | TmApp { +lang ArithFloatConstantFold = AppConstantFold + ArithFloatAst + ArithFloatArity + sem constantFoldConstAppConsts = + | TmApp (r & { + lhs = TmConst {val = const & (CNegf _)}, + rhs = TmConst {val = CFloat {val = f}} + }) -> + TmConst { val = CFloat { val = negf f }, info = r.info, ty = r.ty } + | TmApp (r & { lhs = TmApp { - lhs = TmConst {val = c & CAddf _}, - rhs = a}, - rhs = b, - info = info - } -> - switch (a, b) - case (TmConst {val = CFloat f1}, TmConst {val = CFloat f2}) then - Some (delta info (c, [a, b])) - case (TmConst {val = CFloat f}, b) | (b, TmConst {val = CFloat f}) then - if eqf f.val 0. then Some b else None () - case (_, _) then None () - end - | TmApp (appr1 & { - lhs = TmApp (appr2 & { - lhs = TmConst {val = c & CMulf _}, - rhs = a}), - rhs = b, - info = info + lhs = TmConst { + val = const & (CAddf _ | CSubf _ | CMulf _ | CDivf _)}, + rhs = TmConst {val = CFloat {val = f1}}}, + rhs = TmConst {val = CFloat {val = f2}} }) -> - switch (a, b) - case (TmConst {val = CFloat f1}, TmConst {val = CFloat f2}) then - Some (delta info (c, [a, b])) - case (TmApp {lhs = TmConst {val = CNegf _}, rhs = a}, - TmApp {lhs = TmConst {val = CNegf _}, rhs = b}) - then - Some (TmApp { appr1 with lhs = TmApp { appr2 with rhs = a }, rhs = b }) - case - (TmApp (appr1 & { - lhs = TmApp (appr2 & { - lhs = TmConst {val = CMulf _}, - rhs = TmConst (constr & {val = CFloat f1}) - }) - }), - TmConst {val = CFloat f2}) - | (TmConst {val = CFloat f1}, - TmApp (appr1 & { - lhs = TmApp (appr2 & { - lhs = TmConst {val = CMulf _}, - rhs = TmConst (constr & {val = CFloat f2}) - }) - })) - then - Some - (TmApp { - appr1 with - lhs = TmApp { - appr2 with - rhs = TmConst { - constr with val = CFloat { val = mulf f1.val f2.val } - } - }}) - case - (TmApp (appr & { - lhs = TmApp { - lhs = TmConst {val = CMulf _} - }, - rhs = TmConst (constr & {val = CFloat f1}) - }), - TmConst {val = CFloat f2}) - | (TmConst {val = CFloat f1}, - TmApp (appr & { - lhs = TmApp { - lhs = TmConst {val = CMulf _} - }, - rhs = TmConst (constr & {val = CFloat f2}) - })) - then - Some - (TmApp { - appr with - rhs = TmConst { - constr with val = CFloat { val = mulf f1.val f2.val } - }}) - case - (a & TmConst {val = CFloat f}, b) | (b, a & TmConst {val = CFloat f}) - then - if eqf f.val 1. then Some b - else - if and (eqf f.val 0.) (not (hasSideEffect b)) then Some a - else None () - case (_, _) then None () - end + TmConst { + val = CFloat { val = constantFoldConstAppFloat2 const f1 f2 }, + info = r.info, + ty = r.ty + } + + sem constantFoldConstAppFloat2 : Const -> (Float -> Float -> Float) + sem constantFoldConstAppFloat2 = + | CAddf _ -> addf + | CSubf _ -> subf + | CMulf _ -> mulf + | CDivf _ -> divf +end + +lang SeqOpConstantFoldFirstOrder = + AppConstantFold + SeqOpAst + IntAst + BoolAst + SeqOpArity + + sem constantFoldConstAppConsts = + | TmApp {lhs = TmConst {val = CHead _}, rhs = TmSeq r} -> head r.tms + | TmApp {lhs = TmConst {val = CTail _}, rhs = TmSeq r} -> + TmSeq { r with tms = tail r.tms } | TmApp { - lhs = TmApp (appr & { - lhs = TmConst (constr & {val = c & CSubf _}), - rhs = a}), - rhs = b, - info = info + lhs = TmApp {lhs = TmConst {val = CGet _}, rhs = TmSeq r}, + rhs = TmConst {val = CInt {val = i}} } -> - switch (a, b) - case (TmConst {val = CFloat f1}, TmConst {val = CFloat f2}) then - Some (delta info (c, [a, b])) - case (TmConst {val = CFloat f}, b) then - if eqf f.val 0. then - Some (TmApp { - appr with lhs = TmConst { constr with val = CNegf () }, - rhs = b - }) - else None () - case (a, TmConst {val = CFloat f}) then - if eqf f.val 0. then Some a - else None () - case (_, _) then None () - end + get r.tms i | TmApp { lhs = TmApp { - lhs = TmConst {val = c & CDivf _}, - rhs = a}, - rhs = b, - info = info + lhs = TmApp {lhs = TmConst {val = CSet _}, rhs = TmSeq r}, + rhs = TmConst {val = CInt {val = i}}}, + rhs = val } -> - switch (a, b) - case (TmConst {val = CFloat f1}, TmConst {val = CFloat f2}) then - Some (delta info (c, [a, b])) - case (TmConst {val = CFloat f}, b) then - if and (eqf f.val 0.) (not (hasSideEffect b)) then Some a - else None () - case (a, TmConst {val = CFloat f}) then - if eqf f.val 0. then - errorSingle [info] "Division by zero" - else if eqf f.val 1. then Some a - else None () - case (_, _) then None () - end + TmSeq { r with tms = set r.tms i val } + | TmApp {lhs = TmConst {val = CReverse _}, rhs = TmSeq r} -> + TmSeq { r with tms = reverse r.tms } + | TmApp { + lhs = TmApp { + lhs = TmApp {lhs = TmConst {val = CSubsequence _}, rhs = TmSeq r}, + rhs = TmConst {val = CInt {val = ofs}}}, + rhs = TmConst {val = CInt {val = len}} + } -> + TmSeq { r with tms = subsequence r.tms ofs len } + + sem constantFoldConstApp = + | TmApp { + lhs = TmApp {lhs = TmConst {val = CCons _}, rhs = val}, + rhs = TmSeq r + } -> + TmSeq { r with tms = cons val r.tms } | TmApp { - lhs = TmConst {val = CNegf _}, - rhs = TmApp { - lhs = TmConst {val = CNegf _}, - rhs = a}, - info = info - } -> Some a + lhs = TmApp {lhs = TmConst {val = CSnoc _}, rhs = TmSeq r}, + rhs = val + } -> + TmSeq { r with tms = snoc r.tms val } | TmApp { - lhs = TmConst {val = c & CNegf _}, - rhs = (a & TmConst {val = CFloat _}), - info = info} -> - Some (delta info (c, [a])) + lhs = TmApp {lhs = TmConst {val = CConcat _}, rhs = TmSeq r1}, + rhs = TmSeq r2 + } -> + TmSeq { r1 with tms = concat r1.tms r2.tms } + | TmApp (appr & {lhs = TmConst {val = CLength _}, rhs = TmSeq seqr}) -> + TmConst { + val = CInt { val = length seqr.tms }, + ty = appr.ty, + info = appr.info + } + | TmApp (appr & { + lhs = TmApp {lhs = TmConst {val = CSplitAt _}, rhs = TmSeq seqr}, + rhs = TmConst {val = CInt {val = i}} + }) -> + let t = splitAt seqr.tms i in + tmTuple appr.info appr.ty + [TmSeq { seqr with tms = t.0 }, TmSeq { seqr with tms = t.1 }] end -lang MExprConstantFold = +lang MExprConstantFold = MExprAst + + -- Terms - VarConstantFold + LamAppConstantFold + LetConstantFold + + VarConstantFold + AppConstantFold + LamAppConstantFold + LetConstantFold + + RecordConstantFold + ConstConstantFold + MatchConstantFold + SeqConstantFold + - -- Constants - ArithFloatConstantFold + -- Constant operations + ArithIntConstantFold + ArithFloatConstantFold + SeqOpConstantFoldFirstOrder + + + -- Patterns + NamedPatEval + SeqTotPatEval + SeqEdgePatEval + RecordPatEval + DataPatEval + + IntPatEval + CharPatEval + BoolPatEval + AndPatEval + OrPatEval + NotPatEval end -lang TestLang = MExprConstantFold + MExprPrettyPrint + MExprEq + BootParser end +lang TestLang = MExprConstantFold + + MExprPrettyPrint + MExprEq + BootParser + MExprSym + MExprTypeCheck +end mexpr use TestLang in -let _test = lam expr. - logMsg logLevel.debug (lam. - strJoin "\n" [ - "Before constantfold", - expr2str expr - ]); - let expr = symbolizeAllowFree expr in - match constantfold expr with expr in - logMsg logLevel.debug (lam. - strJoin "\n" [ - "After constantfold", - expr2str expr - ]); - expr -in - -let _testFoldLets = lam expr. - logMsg logLevel.debug (lam. - strJoin "\n" [ - "Before constantfold", - expr2str expr - ]); - let expr = symbolizeAllowFree expr in - match constantfoldLets expr with expr in - logMsg logLevel.debug (lam. - strJoin "\n" [ - "After constantfold", - expr2str expr - ]); - expr +let _parse = lam prog. + typeCheck + (symbolize + (parseMExprString + { _defaultBootParserParseMExprStringArg () with allowFree = false } + prog)) in -let _parse = - parseMExprString - { _defaultBootParserParseMExprStringArg () with allowFree = true } -in +let _toString = utestDefaultToString expr2str expr2str in ------------------------ --- Test Let-bindings -- ------------------------ +------------------------------------------------- +-- Test constant folding of integer arithmetic -- +------------------------------------------------- -let prog = _parse "let x = y in x" in -utest _test prog with _parse "y" using eqExpr in +let prog = _parse "muli 3 2" in +let expected = _parse "6" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in -let prog = _parse "let x = y y in x x" in -utest _test prog with _parse "let x = y y in x x" using eqExpr in +let prog = _parse "divi 3 (negi (subi 4 (addi (muli 3 2) 1)))" in +let expected = _parse "1" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in -let prog = _parse "let x = let z = y in z in x" in -utest _test prog with _parse "y" using eqExpr in +----------------------------------------------- +-- Test constant folding of float arithmetic -- +----------------------------------------------- -let prog = _parse "let x = let z = y in z in x" in -utest _test prog with _parse "y" using eqExpr in +let prog = _parse "mulf 3. 2." in +let expected = _parse "6." in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in -let prog = _parse "let x = y in x x" in -utest _test prog with _parse "y y" using eqExpr in +let prog = _parse "divf 3. (negf (subf 4. (addf (mulf 3. 2.) 1.)))" in +let expected = _parse "1." in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in -let prog = _parse "let x = let y = z in y in x x" in -utest _test prog with _parse "z z" using eqExpr in +------------------------------------------ +-- Test constant propagation of integer -- +------------------------------------------ -let prog = _parse "let x = 1 in x x" in -utest _test prog with _parse "1 1" using eqExpr in +let prog = _parse "let x = 3 in let y = 2 in muli x y" in +let expected = _parse "6" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in -let prog = _parse "let f = lam. 1 in (f x) (f x)" in -utest _test prog with _parse "1 1" using eqExpr in +--------------------------------------------------------------- +-- Test constant propagation of partially applied intrinsics -- +--------------------------------------------------------------- -let prog = _parse "let f = print \"hello world\" in f" in -utest _test prog with _parse " -let f = - print - \"hello world\" +let prog = + _parse "let f = addi 3 in let g = subi 2 in lam x. muli (f 1) (g 1)" in -f - " - using eqExpr +let expected = _parse "lam x. 4" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +-------------------------------------- +-- Test constant folding of matches -- +-------------------------------------- + +let prog = + _parse " + if true then true else false + " in - -let prog = _parse "let f = print \"hello world\" in let g = f in g" in -utest _test prog with _parse " -let f = - print - \"hello world\" +let expected = _parse "true" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + if false then true else false + " in -f - " - using eqExpr +let expected = _parse "false" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + let x = 1 in let y = 2 in + match x with y then y else y + " in - ------------------- --- Test Lam App -- ------------------- - -let prog = _parse "(lam x. x x z) y" in -utest _test prog with _parse " -y - y - z - " - using eqExpr +let expected = _parse "1" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + let t = (0, 1) in t.1 + " in - -let prog = _parse "(lam. x x z) y" in -utest _test prog with _parse " -x - x - z - " - using eqExpr +let expected = _parse "1" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. let t = (x, 1) in t.1 + " in - -let prog = _parse "(lam x. x x z) (lam x. x z)" in -utest _test prog with _parse " -let x = - lam x1. - x1 - z +let expected = _parse "lam x. let t = (x, 1) in t.1" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. match [x, 1] with [_, x] in x + " in -x - x - z - " - using eqExpr +let expected = _parse "lam x. match [x, 1] with [_, x] in 1" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +----------------------------------------- +-- Test constant folding for sequences -- +----------------------------------------- + +let prog = + _parse " + lam x. + head [1, 2, 3] + " in - --------------- --- Test Lam -- --------------- - -let prog = _parse "lam x. x" in -utest _test prog with _parse "lam x. x" using eqExpr in - -let prog = _parse "lam x. let y = x in y" in -utest _test prog with _parse "lam x. x" using eqExpr in - -let prog = _parse "(lam x. x) y" in -utest _test prog with _parse "y" using eqExpr in - -------------------------------- --- Test Remove Eta-Expansion -- -------------------------------- - --- let prog = _parse "lam x. y x" in --- utest _test prog with _parse "y" using eqExpr in - -let prog = _parse "let g = lam x. addf (subf x 1.) x in g" in -utest _test prog with _parse "lam x. addf (subf x 1.) x" using eqExpr in - --- logSetLogLevel logLevel.debug; - --- let prog = _parse " --- let h = lam x. addf x x in --- let g = lam x. mulf x (subf x 1.) in --- lam x. addf (h x) (g x) --- " --- in --- utest _test prog with _parse "lam x. addf (subf x 1.) x" using eqExpr in - ---------------------------- --- Test Float Arithmetic -- ---------------------------- - -let prog = _parse " -let x = negf (subf (divf (mulf (addf 1. 2.) 2.) 2.) 4.) in -x - " in -utest _test prog with _parse "1." using eqExpr in - -let prog = _parse "addf x 0." in -utest _test prog with _parse "x" using eqExpr in - -let prog = _parse "addf 0. x" in -utest _test prog with _parse "x" using eqExpr in - -let prog = _parse "subf x 0." in -utest _test prog with _parse "x" using eqExpr in - -let prog = _parse "subf 0. x" in -utest _test prog with _parse "negf x" using eqExpr in - -let prog = _parse "mulf x 0." in -utest _test prog with _parse "0." using eqExpr in - -let prog = _parse "mulf 0. x" in -utest _test prog with _parse "0." using eqExpr in - -let prog = _parse "mulf (print \"hello\"; y) 0." in -utest _test prog with _parse " -mulf - (print \"hello\"; y) - 0. - " - using eqExpr +let expected = _parse "lam x. 1" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + head [1, 2, x] + " in - -let prog = _parse "mulf 0. (print \"hello\"; y)" in -utest _test prog with _parse " -mulf - 0. - (print \"hello\"; y) - " - using eqExpr +let expected = prog in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + tail [1, 2, 3] + " in - - -let prog = _parse "mulf x 1." in -utest _test prog with _parse "x" using eqExpr in - -let prog = _parse "mulf 1. x" in -utest _test prog with _parse "x" using eqExpr in - -let prog = _parse "mulf (mulf 3. x) 2." in -utest _test prog with _parse "mulf 6. x" using eqExpr in - -let prog = _parse "mulf 2. (mulf 3. x)" in -utest _test prog with _parse "mulf 6. x" using eqExpr in - -let prog = _parse "mulf (mulf x 3.) 2." in -utest _test prog with _parse "mulf x 6." using eqExpr in - -let prog = _parse "mulf 2. (mulf x 3.)" in -utest _test prog with _parse "mulf x 6." using eqExpr in - -let prog = _parse "mulf (negf x) (negf y)" in -utest _test prog with _parse "mulf x y" using eqExpr in - -let prog = _parse "divf x 1." in -utest _test prog with _parse "x" using eqExpr in - -let prog = _parse "divf 0. x" in -utest _test prog with _parse "0." using eqExpr in - -let prog = _parse "divf 0. (print \"hello\"; x)" in -utest _test prog with _parse " -divf - 0. - (print \"hello\"; x) - " - using eqExpr +let expected = _parse "lam x. [2, 3]" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + tail [1, 2, x] + " in - -let prog = _parse "negf (negf x)" in -utest _test prog with _parse "x" using eqExpr in - -let prog = _parse " -let h = - lam x6. - subf - x6 - 2. +let expected = prog in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + get [1, 2, 3] 0 + " in -let dh = - lam x5. - 1. +let expected = _parse "lam x. 1" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + get [1, 2, x] 0 + " in -let g = - lam x4. - mulf - x4 - (subf - x4 - 1.) +let expected = prog in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + set [1, 2, 3] 0 2 + " in -let dg = - lam x3. - addf - (subf - x3 - 1.) - x3 +let expected = _parse "lam x. [2, 2, 3]" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + set [1, 2, x] 0 2 + " in -let f = - lam x2. - addf - (addf - (g - x2) - (h - x2)) - (h - (mulf - 2. - x2)) +let expected = prog in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + cons 0 [1, 2, 3] + " in -let df = - lam x1. - addf - (addf - (dg - x1) - (dh - x1)) - (mulf - 2. - (dh - (mulf - 2. - x1))) +let expected = _parse "lam x. [0, 1, 2, 3]" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + cons 0 [1, 2, x] + " in -let df = - lam x. - df - x +let expected = _parse "lam x. [0, 1, 2, x]" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + snoc [1, 2, 3] 4 + " in -df - 1. - " in - -utest _test prog with _parse " -4. - " - using eqExpr +let expected = _parse "lam x. [1, 2, 3, 4]" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + snoc [1, 2, x] 4 + " in - --- logSetLogLevel logLevel.debug; - -let prog = _parse " -let h = - lam x4. - addf - x4 - x4 +let expected = _parse "lam x. [1, 2, x, 4]" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + concat [1, 2, 3] [4] + " in -let dh = - lam x3. - 2. +let expected = _parse "lam x. [1, 2, 3, 4]" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + concat [1, 2, x] [4] + " in -let g = - lam x2. - mulf - x2 - (subf - x2 - 1.) +let expected = _parse "lam x. [1, 2, x, 4]" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + length [1, 2, 3] + " in -let dh = - lam x1. - let t3 = - subf - x1 - 1. - in - let t4 = - addf - t3 - x1 - in - t4 +let expected = _parse "lam x. 3" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + length [1, 2, x] + " in -lam x. - let t = - dh - x - in - let t1 = - dh - x - in - let t2 = - addf - t - t1 - in - t2 - " +let expected = _parse "lam x. 3" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + reverse [1, 2, 3] + " in - -utest _testFoldLets prog with _parse " -let dh = - lam x1. - addf - (subf - x1 - 1.) - x1 +let expected = _parse "lam x. [3, 2, 1]" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + reverse [1, 2, x] + " +in +let expected = prog in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + subsequence [1, 2, 3] 1 2 + " +in +let expected = _parse "lam x. [2, 3]" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + subsequence [1, 2, x] 1 2 + " +in +let expected = prog in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + splitAt [1, 2, 3] 1 + " in -lam x. - addf - (dh - x) - (dh - x) - " - using eqExpr +let expected = _parse "lam x. ([1], [2, 3])" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in + +let prog = + _parse " + lam x. + splitAt [1, 2, x] 1 + " in +let expected = _parse "lam x. ([1], [2, x])" in +let actual = constantFold prog in +utest actual with expected using eqExpr else _toString in () diff --git a/stdlib/mexpr/eval.mc b/stdlib/mexpr/eval.mc index f6eec5a01..86795718b 100644 --- a/stdlib/mexpr/eval.mc +++ b/stdlib/mexpr/eval.mc @@ -51,6 +51,18 @@ lang Eval = Ast sem evalEnvInsert : Name -> Expr -> EvalEnv -> EvalEnv sem evalEnvInsert id e =| env -> listCons (id, e) env + sem evalEnvAll : ((Name, Expr) -> Bool) -> EvalEnv -> Bool + sem evalEnvAll p =| env -> listAll p env + + sem evalEnvFilter : ((Name, Expr) -> Bool) -> EvalEnv -> EvalEnv + sem evalEnvFilter p =| env -> listFilter p env + + sem evalEnvConcat : EvalEnv -> EvalEnv -> EvalEnv + sem evalEnvConcat lhs =| rhs -> listConcat lhs rhs + + sem evalEnvIsEmpty : EvalEnv -> Bool + sem evalEnvIsEmpty =| env -> listNil env + type EvalCtx = { env : EvalEnv } sem evalCtxEmpty : () -> EvalCtx sem evalCtxEmpty =| _ -> { env = evalEnvEmpty () } @@ -1112,7 +1124,7 @@ end lang SeqEdgePatEval = MatchEvalBase + SeqEdgePat + SeqAst + Eval sem tryMatch (env : EvalEnv) (t : Expr) = | PatSeqEdge {prefix = pre, middle = middle, postfix = post} -> - match t with TmSeq {tms = tms} then + match t with TmSeq (r & {tms = tms}) then if geqi (length tms) (addi (length pre) (length post)) then match splitAt tms (length pre) with (preTm, tms) then match splitAt tms (subi (length tms) (length post)) with (tms, postTm) @@ -1126,7 +1138,7 @@ lang SeqEdgePatEval = MatchEvalBase + SeqEdgePat + SeqAst + Eval paired in match middle with PName name then - optionMap (evalEnvInsert name (seq_ tms)) env + optionMap (evalEnvInsert name (TmSeq { r with tms = tms })) env else match middle with PWildcard () then env else never else never else never diff --git a/test-compile.mk b/test-compile.mk index 833bbb39a..b5bfc5b25 100644 --- a/test-compile.mk +++ b/test-compile.mk @@ -7,4 +7,4 @@ all: $(src_files_all) selected: $(compile_files) $(src_files_all): - @./make.sh compile-test $@ "build/mi compile --test --disable-optimizations --disable-prune-utests" + @./make.sh compile-test $@ "build/mi compile --test --enable-constant-fold --disable-prune-utests"