git.iko.soy/elk
on bbb2b2a help sign in
elk/compiler/Transform/Optimize.hs
141 lines 4.9 kB history raw
1module Optimize (optimize) where
3import Ast
4import Located
5import Control.Arrow (second, (***))
6import Data.Char (isAlpha)
7import Substitute
9optimize (Module name ims exs stmts) =
10 Module name ims exs (map optimizeStmt stmts)
12optimizeStmt stmt = if stmt == stmt' then stmt' else optimizeStmt stmt'
13 where stmt' = simp stmt
15class Simplify a where
16 simp :: a -> a
18instance Simplify Statement where
19 simp (Definition def) = Definition (simp def)
20 simp (ImportEvent js b elm t) = ImportEvent js (simp b) elm t
21 simp stmt = stmt
23instance Simplify Def where
24 simp (FnDef func args e) = FnDef func args (simp e)
25 simp (OpDef op a1 a2 e) = OpDef op a1 a2 (simp e)
26 simp x = x
28instance Simplify e => Simplify (Located e) where
29 simp (L t s e) = L t s (simp e)
31instance Simplify Expr where
32 simp expr =
33 let f = simp in
34 case expr of
35 Range e1 e2 -> Range (f e1) (f e2)
36 Binop op e1 e2 -> simp_binop op (f e1) (f e2)
37 Lambda x e -> Lambda x (f e)
38 Record fs -> Record (map (\(f,as,e) -> (f, as, simp e)) fs)
39 App (L t s (Lambda x e1)) e2 ->
40 if isValue e2' then subst x e2' e1' else App (L t s (Lambda x ce1')) ce2'
41 where ce1'@(L _ _ e1') = f e1
42 ce2'@(L _ _ e2') = f e2
43 App e1 e2 -> App (f e1) (f e2)
44 Let defs e -> Let (map simp defs) (f e)
45 Data name es -> Data name (map f es)
46 MultiIf es -> MultiIf . clipBranches $ map (f *** f) es
47 Case e cases -> Case (f e) (map (second f) cases)
48 _ -> expr
51clipBranches [] = []
52clipBranches (e:es) =
53 case e of
54 (L _ _ (Boolean True), _) -> [e]
55 _ -> e : clipBranches es
58isValue e =
59 case e of { IntNum _ -> True
60 ; FloatNum _ -> True
61 ; Chr _ -> True
62 ; Str _ -> True
63 ; Boolean _ -> True
64 ; Var _ -> True
65 ; Data _ _ -> True
66 ; _ -> False }
68simp_binop = binop
70binop op ce1@(L t1 s1 e1) ce2@(L t2 s2 e2) =
71 let c1 = L t1 s1 in
72 let c2 = L t2 s2 in
73 case (op, e1, e2) of
74 (_, IntNum n, IntNum m) -> case op of
75 { "+" -> IntNum $ (+) n m
76 ; "-" -> IntNum $ (-) n m
77 ; "*" -> IntNum $ (*) n m
78 ; "^" -> IntNum $ n ^ m
79 ; "div" -> IntNum $ div n m
80 ; "mod" -> IntNum $ mod n m
81 ; "<" -> Boolean $ n < m
82 ; ">" -> Boolean $ n < m
83 ; "<=" -> Boolean $ n <= m
84 ; ">=" -> Boolean $ n >= m
85 ; "==" -> Boolean $ n == m
86 ; "/=" -> Boolean $ n /= m
87 ; _ -> Binop op ce1 ce2 }
89 -- flip order to move lone integers to the left
90 ("+", _, IntNum n) -> binop "+" ce2 ce1
91 ("*", _, IntNum n) -> binop "*" ce2 ce1
93 ("+", IntNum 0, _) -> e2
94 ("+", IntNum n, Binop "+" (L _ _ (IntNum m)) ce) ->
95 binop "+" (c1 $ IntNum (n+m)) ce
96 ("+", Binop "+" (L _ _ (IntNum n)) ce1'
97 , Binop "+" (L _ _ (IntNum m)) ce2') ->
98 binop "+" (notLocated $ IntNum (n+m)) (notLocated $ Binop "+" ce1' ce2')
100 ("*", IntNum 0, _) -> e1
101 ("*", IntNum 1, _) -> e2
102 ("*", IntNum n, Binop "*" (L _ _ (IntNum m)) ce) ->
103 binop "*" (notLocated $ IntNum (n*m)) ce
104 ("*", Binop "*" (L _ _ (IntNum n)) ce1'
105 , Binop "*" (L _ _ (IntNum m)) ce2') ->
106 binop "*" (notLocated $ IntNum (n*m)) (notLocated $ Binop "*" ce1' ce2')
108 ("-", _, IntNum 0) -> e1
109 ("/", _, IntNum 1) -> e1
110 ("div", _, IntNum 1) -> e1
112 (_, Boolean n, Boolean m) -> case op of "&&" -> Boolean $ n && m
113 "||" -> Boolean $ n || m
114 _ -> Binop op ce1 ce2
116 ("&&", Boolean True, _) -> e2
117 ("&&", Boolean False, _) -> Boolean False
118 ("||", Boolean True, _) -> Boolean True
119 ("||", Boolean False, _) -> e2
121 ("::", _, _) -> let (L _ _ e) = cons ce1 ce2 in e
123 ("++", Str s1, Str s2) -> Str $ s1 ++ s2
124 ("++", Str s1, Binop "++" (L _ _ (Str s2)) ce) ->
125 Binop "++" (c1 $ Str $ s1 ++ s2) ce
126 ("++", Binop "++" e (L _ _ (Str s1)), Str s2) ->
127 Binop "++" e (c1 $ Str $ s1 ++ s2)
129 ("++", Data "Nil" [], _) -> e2
130 ("++", _, Data "Nil" []) -> e1
131 ("++", Data "Cons" [h,t], _) -> Data "Cons" [h, notLocated $ binop "++" t ce2]
133 ("|>", _, _) -> App ce2 ce1
134 ("<|", _, _) -> App ce1 ce2
135 (".", _, _) ->
136 Lambda "x" (notLocated $
137 App ce1 (notLocated $ App ce2 (notLocated $ Var "x")))
139 _ | isAlpha (head op) || '_' == head op ->
140 App (notLocated $ App (notLocated $ Var op) ce1) ce2
141 | otherwise -> Binop op ce1 ce2