git.iko.soy/elk
on 202aace help sign in
elk/compiler/src/Optimize.hs
134 lines 4.8 kB history raw
1module Optimize (optimize) where
3import Ast
4import Context
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)
27instance Simplify e => Simplify (Context e) where
28 simp (C t s e) = C t s (simp e)
30instance Simplify Expr 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 -> simp_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 (C t s (Lambda x e1)) e2 ->
39 if isValue e2' then subst x e2' e1' else App (C t s (Lambda x ce1')) ce2'
40 where ce1'@(C _ _ e1') = f e1
41 ce2'@(C _ _ e2') = f e2
42 App e1 e2 -> App (f e1) (f e2)
43 If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)
44 Let defs e -> Let (map simp defs) (f e)
45 Data name es -> Data name (map f es)
46 Case e cases -> Case (f e) (map (second f) cases)
47 _ -> expr
49simp_if (C _ _ (Boolean b)) (C _ _ e2) (C _ _ e3) = if b then e2 else e3
50simp_if a b c = If a b c
52isValue e =
53 case e of { IntNum _ -> True
54 ; FloatNum _ -> True
55 ; Chr _ -> True
56 ; Str _ -> True
57 ; Boolean _ -> True
58 ; Var _ -> True
59 ; Data _ _ -> True
60 ; _ -> False }
62simp_binop = binop
64binop op ce1@(C t1 s1 e1) ce2@(C t2 s2 e2) =
65 let c1 = C t1 s1 in
66 let c2 = C t2 s2 in
67 case (op, e1, e2) of
68 (_, IntNum n, IntNum m) -> case op of
69 { "+" -> IntNum $ (+) n m
70 ; "-" -> IntNum $ (-) n m
71 ; "*" -> IntNum $ (*) n m
72 ; "^" -> IntNum $ n ^ m
73 ; "div" -> IntNum $ div n m
74 ; "mod" -> IntNum $ mod n m
75 ; "<" -> Boolean $ n < m
76 ; ">" -> Boolean $ n < m
77 ; "<=" -> Boolean $ n <= m
78 ; ">=" -> Boolean $ n >= m
79 ; "==" -> Boolean $ n == m
80 ; "/=" -> Boolean $ n /= m
81 ; _ -> Binop op ce1 ce2 }
83 -- flip order to move lone integers to the left
84 ("+", _, IntNum n) -> binop "+" ce2 ce1
85 ("*", _, IntNum n) -> binop "*" ce2 ce1
87 ("+", IntNum 0, _) -> e2
88 ("+", IntNum n, Binop "+" (C _ _ (IntNum m)) ce) ->
89 binop "+" (c1 $ IntNum (n+m)) ce
90 ("+", Binop "+" (C _ _ (IntNum n)) ce1'
91 , Binop "+" (C _ _ (IntNum m)) ce2') ->
92 binop "+" (noContext $ IntNum (n+m)) (noContext $ Binop "+" ce1' ce2')
94 ("*", IntNum 0, _) -> e1
95 ("*", IntNum 1, _) -> e2
96 ("*", IntNum n, Binop "*" (C _ _ (IntNum m)) ce) ->
97 binop "*" (noContext $ IntNum (n*m)) ce
98 ("*", Binop "*" (C _ _ (IntNum n)) ce1'
99 , Binop "*" (C _ _ (IntNum m)) ce2') ->
100 binop "*" (noContext $ IntNum (n*m)) (noContext $ Binop "*" ce1' ce2')
102 ("-", _, IntNum 0) -> e1
103 ("/", _, IntNum 1) -> e1
104 ("div", _, IntNum 1) -> e1
106 (_, Boolean n, Boolean m) -> case op of "&&" -> Boolean $ n && m
107 "||" -> Boolean $ n || m
108 _ -> Binop op ce1 ce2
110 ("&&", Boolean True, _) -> e2
111 ("&&", Boolean False, _) -> Boolean False
112 ("||", Boolean True, _) -> Boolean True
113 ("||", Boolean False, _) -> e2
115 (":", _, _) -> let (C _ _ e) = cons ce1 ce2 in e
117 ("++", Str s1, Str s2) -> Str $ s1 ++ s2
118 ("++", Str s1, Binop "++" (C _ _ (Str s2)) ce) ->
119 Binop "++" (c1 $ Str $ s1 ++ s2) ce
120 ("++", Binop "++" e (C _ _ (Str s1)), Str s2) ->
121 Binop "++" e (c1 $ Str $ s1 ++ s2)
123 ("++", Data "Nil" [], _) -> e2
124 ("++", _, Data "Nil" []) -> e1
125 ("++", Data "Cons" [h,t], _) -> Data "Cons" [h, noContext $ binop "++" t ce2]
127 ("$", _, _) -> App ce1 ce2
128 (".", _, _) ->
129 Lambda "x" (noContext $
130 App ce1 (noContext $ App ce2 (noContext $ Var "x")))
132 _ | isAlpha (head op) || '_' == head op ->
133 App (noContext $ App (noContext $ Var op) ce1) ce2
134 | otherwise -> Binop op ce1 ce2