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