Mercurial > urweb

comparison src/reduce.sml @ 1016:065ce3252090

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Inlining threshold for Reduce
author Adam Chlipala <adamc@hcoop.net>
date Sun, 25 Oct 2009 12:08:21 -0400
parents 01a4d936395a
children 68ba074e260f
comparison
equal deleted inserted replaced
1015:e47303e5d73d 1016:065ce3252090
29 29
30 structure Reduce :> REDUCE = struct 30 structure Reduce :> REDUCE = struct
31 31
32 open Core 32 open Core
33 33
34 structure IS = IntBinarySet
34 structure IM = IntBinaryMap 35 structure IM = IntBinaryMap
35 36
36 structure E = CoreEnv 37 structure E = CoreEnv
37 38
38 fun multiLiftExpInExp n e = 39 fun multiLiftExpInExp n e =
812 fun con namedC env c = #con (kindConAndExp (namedC, IM.empty)) env c 813 fun con namedC env c = #con (kindConAndExp (namedC, IM.empty)) env c
813 fun exp (namedC, namedE) env e = #exp (kindConAndExp (namedC, namedE)) env e 814 fun exp (namedC, namedE) env e = #exp (kindConAndExp (namedC, namedE)) env e
814 815
815 fun reduce file = 816 fun reduce file =
816 let 817 let
817 fun doDecl (d as (_, loc), st as (namedC, namedE)) = 818 val uses = CoreUtil.File.fold {kind = fn (_, m) => m,
819 con = fn (_, m) => m,
820 exp = fn (e, m) =>
821 case e of
822 ENamed n => IM.insert (m, n, 1 + Option.getOpt (IM.find (m, n), 0))
823 | _ => m,
824 decl = fn (_, m) => m}
825 IM.empty file
826
827 fun isPoly names = CoreUtil.Con.exists {kind = fn _ => false,
828 con = fn TCFun _ => true
829 | TKFun _ => true
830 | CNamed n => IS.member (names, n)
831 | _ => false}
832
833 val size = CoreUtil.Exp.fold {kind = fn (_, n) => n,
834 con = fn (_, n) => n,
835 exp = fn (_, n) => n + 1} 0
836
837 fun mayInline (polyC, n, t, e) =
838 case IM.find (uses, n) of
839 NONE => false
840 | SOME count => count <= 1
841 orelse isPoly polyC t
842 orelse size e <= Settings.getCoreInline ()
843
844 fun doDecl (d as (_, loc), st as (polyC, namedC, namedE)) =
818 case #1 d of 845 case #1 d of
819 DCon (x, n, k, c) => 846 DCon (x, n, k, c) =>
820 let 847 let
821 val k = kind namedC [] k 848 val k = kind namedC [] k
822 val c = con namedC [] c 849 val c = con namedC [] c
823 in 850 in
824 ((DCon (x, n, k, c), loc), 851 ((DCon (x, n, k, c), loc),
825 (IM.insert (namedC, n, c), namedE)) 852 (if isPoly polyC c then
853 IS.add (polyC, n)
854 else
855 polyC,
856 IM.insert (namedC, n, c),
857 namedE))
826 end 858 end
827 | DDatatype dts => 859 | DDatatype dts =>
828 ((DDatatype (map (fn (x, n, ps, cs) => 860 ((DDatatype (map (fn (x, n, ps, cs) =>
829 let 861 let
830 val env = map (fn _ => UnknownC) ps 862 val env = map (fn _ => UnknownC) ps
831 in 863 in
832 (x, n, ps, map (fn (x, n, co) => (x, n, Option.map (con namedC env) co)) cs) 864 (x, n, ps, map (fn (x, n, co) => (x, n, Option.map (con namedC env) co)) cs)
833 end) dts), loc), 865 end) dts), loc),
834 st) 866 (if List.exists (fn (_, _, _, cs) => List.exists (fn (_, _, co) => case co of
867 NONE => false
868 | SOME c => isPoly polyC c) cs)
869 dts then
870 foldl (fn ((_, n, _, _), polyC) => IS.add (polyC, n)) polyC dts
871 else
872 polyC,
873 namedC,
874 namedE))
835 | DVal (x, n, t, e, s) => 875 | DVal (x, n, t, e, s) =>
836 let 876 let
837 val t = con namedC [] t 877 val t = con namedC [] t
838 val e = exp (namedC, namedE) [] e 878 val e = exp (namedC, namedE) [] e
839 in 879 in
840 ((DVal (x, n, t, e, s), loc), 880 ((DVal (x, n, t, e, s), loc),
841 (namedC, IM.insert (namedE, n, e))) 881 (polyC,
882 namedC,
883 if mayInline (polyC, n, t, e) then
884 IM.insert (namedE, n, e)
885 else
886 namedE))
842 end 887 end
843 | DValRec vis => 888 | DValRec vis =>
844 ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t, 889 ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t,
845 exp (namedC, namedE) [] e, s)) vis), loc), 890 exp (namedC, namedE) [] e, s)) vis), loc),
846 st) 891 st)
854 | DView (s, n, s', e, c) => ((DView (s, n, s', exp (namedC, namedE) [] e, con namedC [] c), loc), st) 899 | DView (s, n, s', e, c) => ((DView (s, n, s', exp (namedC, namedE) [] e, con namedC [] c), loc), st)
855 | DDatabase _ => (d, st) 900 | DDatabase _ => (d, st)
856 | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st) 901 | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st)
857 | DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st) 902 | DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st)
858 903
859 val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file 904 val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file
860 in 905 in
861 file 906 file
862 end 907 end
863 908
864 end 909 end