git.iko.soy/elk
on a268421 help sign in
elk/compiler/Transform/Optimize.hs
132 lines 4.0 kB history raw
1module Transform.Optimize (optimize) where
3import SourceSyntax.Everything
4import Control.Arrow (second, (***))
5import Data.Char (isAlpha)
7optimize (Module name ims exs stmts) =
8 Module name ims exs (map optimizeStmt stmts)
10optimizeStmt stmt = if stmt == stmt' then stmt' else optimizeStmt stmt'
11 where stmt' = simp stmt
13class Simplify a where
14 simp :: a -> a
16instance Simplify (Declaration t v) where
17 simp (Definition def) = Definition (simp def)
18 simp (ImportEvent js b elm t) = ImportEvent js (simp b) elm t
19 simp stmt = stmt
21instance Simplify (Def t v) where
22 simp (Def name e) = Def name (simp e)
23 simp x = x
25instance Simplify e => Simplify (Located e) where
26 simp (L s e) = L s (simp e)
28instance Simplify (Expr t v) where
29 simp expr =
30 let f = simp in
31 case expr of
32 Range e1 e2 -> Range (f e1) (f e2)
33 Binop op e1 e2 -> binop op (f e1) (f e2)
34 Lambda x e -> Lambda x (f e)
35 Record fs -> Record (map (second simp) fs)
36 App e1 e2 -> App (f e1) (f e2)
37 Let defs e -> Let (map simp defs) (f e)
38 Data name es -> Data name (map f es)
39 MultiIf es -> MultiIf . clipBranches $ map (f *** f) es
40 Case e cases -> Case (f e) (map (second f) cases)
41 _ -> expr
44clipBranches [] = []
45clipBranches (e:es) =
46 case e of
47 (L _ (Literal (Boolean True)), _) -> [e]
48 _ -> e : clipBranches es
51isValue e =
52 case e of
53 Literal _ -> True
54 Var _ -> True
55 Data _ _ -> True
56 _ -> False
59binop op ce1@(L s1 e1) ce2@(L s2 e2) =
60 let c1 = L s1
61 c2 = L s2
62 int = Literal . IntNum
63 str = Literal . Str
64 bool = Literal . Boolean
65 in
66 case (op, e1, e2) of
67 (_, Literal (IntNum n), Literal (IntNum m)) ->
68 case op of
69 { "+" -> int $ (+) n m
70 ; "-" -> int $ (-) n m
71 ; "*" -> int $ (*) n m
72 ; "^" -> int $ n ^ m
73 ; "div" -> int $ div n m
74 ; "mod" -> int $ mod n m
75 ; "rem" -> int $ rem n m
76 ; "<" -> bool $ n < m
77 ; ">" -> bool $ n > m
78 ; "<=" -> bool $ n <= m
79 ; ">=" -> bool $ n >= m
80 ; "==" -> bool $ n == m
81 ; "/=" -> bool $ n /= m
82 ; _ -> Binop op ce1 ce2 }
83 {--
84 -- flip order to move lone integers to the left
85 ("+", _, IntNum n) -> binop "+" ce2 ce1
86 ("*", _, IntNum n) -> binop "*" ce2 ce1
88 ("+", IntNum 0, _) -> e2
89 ("+", IntNum n, Binop "+" (L _ (IntNum m)) ce) ->
90 binop "+" (c1 $ IntNum (n+m)) ce
91 ("+", Binop "+" (L _ (IntNum n)) ce1'
92 , Binop "+" (L _ (IntNum m)) ce2') ->
93 binop "+" (none $ IntNum (n+m)) (none $ Binop "+" ce1' ce2')
95 ("*", IntNum 0, _) -> e1
96 ("*", IntNum 1, _) -> e2
97 ("*", IntNum n, Binop "*" (L _ (IntNum m)) ce) ->
98 binop "*" (none $ IntNum (n*m)) ce
99 ("*", Binop "*" (L _ (IntNum n)) ce1'
100 , Binop "*" (L _ (IntNum m)) ce2') ->
101 binop "*" (none $ IntNum (n*m)) (none $ Binop "*" ce1' ce2')
103 ("-", _, IntNum 0) -> e1
104 ("/", _, IntNum 1) -> e1
105 ("div", _, IntNum 1) -> e1
106--}
107 (_, Literal (Boolean n), Literal (Boolean m)) ->
108 case op of
109 "&&" -> bool $ n && m
110 "||" -> bool $ n || m
111 _ -> Binop op ce1 ce2
113 ("&&", Literal (Boolean True), _) -> e2
114 ("&&", Literal (Boolean False), _) -> bool False
115 ("||", Literal (Boolean True), _) -> bool True
116 ("||", Literal (Boolean False), _) -> e2
118 ("::", _, _) -> Data "::" [ce1, ce2]
120 ("++", Literal (Str s1), Literal (Str s2)) -> str $ s1 ++ s2
121 ("++", Literal (Str s1), Binop "++" (L _ (Literal (Str s2))) ce) ->
122 Binop "++" (c1 . str $ s1 ++ s2) ce
123 ("++", Binop "++" e (L _ (Literal (Str s1))), Literal (Str s2)) ->
124 Binop "++" e (c1 . str $ s1 ++ s2)
126 ("++", Data "[]" [], _) -> e2
127 ("++", _, Data "[]" []) -> e1
128 ("++", Data "::" [h,t], _) -> Data "::" [h, none $ binop "++" t ce2]
130 _ | isAlpha (head op) || '_' == head op ->
131 App (none $ App (none $ Var op) ce1) ce2
132 | otherwise -> Binop op ce1 ce2