git.iko.soy/elk
on ca8441f help sign in
elk/compiler/Transform/Optimize.hs
144 lines 4.6 kB history raw
1module Transform.Optimize (optimize) where
3import SourceSyntax.Everything
4import Control.Arrow (second, (***))
5import Data.Char (isAlpha)
6import Transform.Substitute
8optimize (Module name ims exs stmts) =
9 Module name ims exs (map optimizeStmt stmts)
11optimizeStmt stmt = if stmt == stmt' then stmt' else optimizeStmt stmt'
12 where stmt' = simp stmt
14class Simplify a where
15 simp :: a -> a
17instance Simplify (Declaration t v) where
18 simp (Definition def) = Definition (simp def)
19 simp (ImportEvent js b elm t) = ImportEvent js (simp b) elm t
20 simp stmt = stmt
22instance Simplify (Def t v) where
23 simp (FnDef func args e) = FnDef func args (simp e)
24 simp (OpDef op a1 a2 e) = OpDef op a1 a2 (simp e)
25 simp x = x
27instance Simplify e => Simplify (Located e) where
28 simp (L t s e) = L t s (simp e)
30instance Simplify (Expr t v) where
31 simp expr =
32 let f = simp in
33 case expr of
34 Range e1 e2 -> Range (f e1) (f e2)
35 Binop op e1 e2 -> binop op (f e1) (f e2)
36 Lambda x e -> Lambda x (f e)
37 Record fs -> Record (map (\(f,as,e) -> (f, as, simp e)) fs)
38 App (L t s (Lambda x e1)) e2 ->
39 if isValue e2' then subst x e2' e1' else App (L t s (Lambda x ce1')) ce2'
40 where ce1'@(L _ _ e1') = f e1
41 ce2'@(L _ _ e2') = f e2
42 App e1 e2 -> App (f e1) (f e2)
43 Let defs e -> Let (map simp defs) (f e)
44 Data name es -> Data name (map f es)
45 MultiIf es -> MultiIf . clipBranches $ map (f *** f) es
46 Case e cases -> Case (f e) (map (second f) cases)
47 _ -> expr
50clipBranches [] = []
51clipBranches (e:es) =
52 case e of
53 (L _ _ (Literal (Boolean True)), _) -> [e]
54 _ -> e : clipBranches es
57isValue e =
58 case e of
59 Literal _ -> True
60 Var _ -> True
61 Data _ _ -> True
62 _ -> False
65binop op ce1@(L t1 s1 e1) ce2@(L t2 s2 e2) =
66 let c1 = L t1 s1
67 c2 = L t2 s2
68 int = Literal . IntNum
69 str = Literal . Str
70 bool = Literal . Boolean
71 in
72 case (op, e1, e2) of
73 (_, Literal (IntNum n), Literal (IntNum m)) ->
74 case op of
75 { "+" -> int $ (+) n m
76 ; "-" -> int $ (-) n m
77 ; "*" -> int $ (*) n m
78 ; "^" -> int $ n ^ m
79 ; "div" -> int $ div n m
80 ; "mod" -> int $ mod n m
81 ; "rem" -> int $ rem n m
82 ; "<" -> bool $ n < m
83 ; ">" -> bool $ n > m
84 ; "<=" -> bool $ n <= m
85 ; ">=" -> bool $ n >= m
86 ; "==" -> bool $ n == m
87 ; "/=" -> bool $ n /= m
88 ; _ -> Binop op ce1 ce2 }
89 {--
90 -- flip order to move lone integers to the left
91 ("+", _, IntNum n) -> binop "+" ce2 ce1
92 ("*", _, IntNum n) -> binop "*" ce2 ce1
94 ("+", IntNum 0, _) -> e2
95 ("+", IntNum n, Binop "+" (L _ _ (IntNum m)) ce) ->
96 binop "+" (c1 $ IntNum (n+m)) ce
97 ("+", Binop "+" (L _ _ (IntNum n)) ce1'
98 , Binop "+" (L _ _ (IntNum m)) ce2') ->
99 binop "+" (none $ IntNum (n+m)) (none $ Binop "+" ce1' ce2')
101 ("*", IntNum 0, _) -> e1
102 ("*", IntNum 1, _) -> e2
103 ("*", IntNum n, Binop "*" (L _ _ (IntNum m)) ce) ->
104 binop "*" (none $ IntNum (n*m)) ce
105 ("*", Binop "*" (L _ _ (IntNum n)) ce1'
106 , Binop "*" (L _ _ (IntNum m)) ce2') ->
107 binop "*" (none $ IntNum (n*m)) (none $ Binop "*" ce1' ce2')
109 ("-", _, IntNum 0) -> e1
110 ("/", _, IntNum 1) -> e1
111 ("div", _, IntNum 1) -> e1
112--}
113 (_, Literal (Boolean n), Literal (Boolean m)) ->
114 case op of
115 "&&" -> bool $ n && m
116 "||" -> bool $ n || m
117 _ -> Binop op ce1 ce2
119 ("&&", Literal (Boolean True), _) -> e2
120 ("&&", Literal (Boolean False), _) -> bool False
121 ("||", Literal (Boolean True), _) -> bool True
122 ("||", Literal (Boolean False), _) -> e2
124 ("::", _, _) -> Data "::" [ce1, ce2]
126 ("++", Literal (Str s1), Literal (Str s2)) -> str $ s1 ++ s2
127 ("++", Literal (Str s1), Binop "++" (L _ _ (Literal (Str s2))) ce) ->
128 Binop "++" (c1 . str $ s1 ++ s2) ce
129 ("++", Binop "++" e (L _ _ (Literal (Str s1))), Literal (Str s2)) ->
130 Binop "++" e (c1 . str $ s1 ++ s2)
132 ("++", Data "[]" [], _) -> e2
133 ("++", _, Data "[]" []) -> e1
134 ("++", Data "::" [h,t], _) -> Data "::" [h, none $ binop "++" t ce2]
136 ("|>", _, _) -> App ce2 ce1
137 ("<|", _, _) -> App ce1 ce2
138 (".", _, _) ->
139 Lambda "x" (none $
140 App ce1 (none $ App ce2 (none $ Var "x")))
142 _ | isAlpha (head op) || '_' == head op ->
143 App (none $ App (none $ Var op) ce1) ce2
144 | otherwise -> Binop op ce1 ce2