1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
|
{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.JS.Opt.Expr
-- Copyright : (c) The University of Glasgow 2001
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io>
-- Luite Stegeman <luite.stegeman@iohk.io>
-- Sylvain Henry <sylvain.henry@iohk.io>
-- Josh Meredith <josh.meredith@iohk.io>
-- Stability : experimental
--
--
-- This module contains a simple expression optimizer that performs constant
-- folding and some boolean expression optimizations.
-----------------------------------------------------------------------------
module GHC.JS.Opt.Expr (optExprs) where
import GHC.Prelude hiding (shiftL, shiftR)
import GHC.JS.Syntax
import Data.Bifunctor (second)
import Data.Bits (shiftL, shiftR, (.^.))
import Data.Int (Int32)
{-
Optimize expressions in a statement.
This is best done after running the simple optimizer in GHC.JS.Opt.Simple,
which eliminates redundant assignments and produces expressions that can be
optimized more effectively.
-}
optExprs :: JStat -> JStat
optExprs s = go s
where
go (DeclStat v mb_e) = DeclStat v (fmap opt mb_e)
go (AssignStat lhs op rhs) = AssignStat (opt lhs) op (opt rhs)
go (ReturnStat e) = ReturnStat (opt e)
go (BlockStat ss) = BlockStat (map go ss)
go (IfStat e s1 s2) = IfStat (optCond e) (go s1) (go s2)
go (WhileStat b e s) = WhileStat b (optCond e) (go s)
go (ForStat s1 e s2 s3) = ForStat (go s1) (optCond e) (go s2) (go s3)
go (ForInStat b v e s) = ForInStat b v (opt e) (go s)
go (SwitchStat e cases s) = SwitchStat (opt e)
(map (second go) cases)
(go s)
go (TryStat s1 v s2 s3) = TryStat (go s1) v (go s2) (go s3)
go (ApplStat e es) = ApplStat (opt e) (map opt es)
go (UOpStat op e) = UOpStat op (opt e)
go (LabelStat lbl s) = LabelStat lbl (go s)
go s@(BreakStat{}) = s
go s@(ContinueStat{}) = s
go (FuncStat n vs s) = FuncStat n vs (go s)
-- remove double negation if we're using the expression in a loop/if condition
optCond :: JExpr -> JExpr
optCond e = let f (UOpExpr NotOp (UOpExpr NotOp e')) = f e'
f e' = e'
in f (opt e)
opt :: JExpr -> JExpr
opt (ValExpr v) = ValExpr v
opt (SelExpr e i) = SelExpr (opt e) i
opt (IdxExpr e1 e2) = IdxExpr (opt e1) (opt e2)
-- ((c_e ? 1 : 0) === 1) ==> !!c_e
-- ((c_e ? 1 : 0) === 0) ==> !c_e
opt(InfixExpr StrictEqOp (IfExpr c_e (opt -> t_e) (opt -> f_e)) (opt -> e))
| ValExpr t_v <- t_e
, ValExpr v <- e
, eqVal t_v v = UOpExpr NotOp (UOpExpr NotOp c_e)
| ValExpr f_v <- f_e
, ValExpr v <- e
, eqVal f_v v = UOpExpr NotOp (opt c_e)
| otherwise = InfixExpr StrictEqOp (IfExpr c_e t_e f_e) e
-- (1 === (c_e ? 1 : 0)) ==> !!c_e
-- (0 === (c_e ? 1 : 0)) ==> !c_e
opt(InfixExpr StrictEqOp (opt -> e) (IfExpr (opt -> c_e) (opt -> t_e) (opt -> f_e)))
| ValExpr t_v <- t_e
, ValExpr v <- e
, eqVal t_v v = UOpExpr NotOp (UOpExpr NotOp c_e)
| ValExpr f_v <- f_e
, ValExpr v <- e
, eqVal f_v v = UOpExpr NotOp c_e
| otherwise = InfixExpr StrictEqOp e (IfExpr c_e t_e f_e)
opt (InfixExpr op (opt -> e1) (opt -> e2))
| (ValExpr (JInt n1)) <- e1
, (ValExpr (JInt n2)) <- e2
, Just v <- optInt op n1 n2 = ValExpr v
| (ValExpr (JBool b1)) <- e1
, (ValExpr (JBool b2)) <- e2
, Just v <- optBool op b1 b2 = ValExpr v
| otherwise = InfixExpr op e1 e2
opt (UOpExpr op e) = UOpExpr op (opt e)
opt (IfExpr e1 e2 e3) = IfExpr (optCond e1) (opt e2) (opt e3)
opt (ApplExpr e es) = ApplExpr (opt e) (map opt es)
{-
Optimizations for operations on two known boolean values
-}
optBool :: Op -> Bool -> Bool -> Maybe JVal
optBool LAndOp x y = Just (JBool (x && y))
optBool LOrOp x y = Just (JBool (x || y))
optBool EqOp x y = Just (JBool (x == y))
optBool StrictEqOp x y = Just (JBool (x == y))
optBool NeqOp x y = Just (JBool (x /= y))
optBool StrictNeqOp x y = Just (JBool (x /= y))
optBool _ _ _ = Nothing
{-
Optimizations for operations on two known integer values
-}
optInt :: Op -> Integer -> Integer -> Maybe JVal
optInt ZRightShiftOp n m = Just $
JInt (toInteger $ (n .&. 0xffffffff) `shiftR` fromInteger (m .&. 0x1f))
optInt BOrOp n m = Just (truncOp (.|.) n m)
optInt BAndOp n m = Just (truncOp (.&.) n m)
optInt BXorOp n m = Just (truncOp (.^.) n m)
optInt RightShiftOp n m = Just (shiftOp shiftR n m)
optInt LeftShiftOp n m = Just (shiftOp shiftL n m)
optInt AddOp n m = smallIntOp (+) n m
optInt SubOp n m = smallIntOp (-) n m
optInt MulOp n m = smallIntOp (*) n m
optInt op n m
| Just cmp <- getCmpOp op, isSmall52 n && isSmall52 m
= Just (JBool (cmp n m))
optInt _ _ _ = Nothing
smallIntOp :: (Integer -> Integer -> Integer)
-> Integer -> Integer -> Maybe JVal
smallIntOp op n m
| isSmall52 n && isSmall52 m && isSmall52 r = Just (JInt r)
| otherwise = Nothing
where
r = op n m
getCmpOp :: Op -> Maybe (Integer -> Integer -> Bool)
getCmpOp EqOp = Just (==)
getCmpOp StrictEqOp = Just (==)
getCmpOp NeqOp = Just (/=)
getCmpOp StrictNeqOp = Just (/=)
getCmpOp GtOp = Just (>)
getCmpOp GeOp = Just (>=)
getCmpOp LtOp = Just (<)
getCmpOp LeOp = Just (<=)
getCmpOp _ = Nothing
shiftOp :: (Int32 -> Int -> Int32) -> Integer -> Integer -> JVal
shiftOp op n m = JInt $ toInteger
(fromInteger n `op` (fromInteger m .&. 0x1f))
{-
JavaScript bitwise operations truncate numbers to 32 bit signed integers.
Here we do the same when constant folding with this kind of operators.
-}
truncOp :: (Int32 -> Int32 -> Int32) -> Integer -> Integer -> JVal
truncOp op n m = JInt $ toInteger
(fromInteger n `op` fromInteger m)
{-
JavaScript numbers are IEEE 754 double precision floats, which have a
52-bit mantissa. This returns True if the given integer can definitely
be represented without loss of precision in a JavaScript number.
-}
isSmall52 :: Integer -> Bool
isSmall52 n = n >= -0x10000000000000 && n <= 0xfffffffffffff
{-
In JavaScript, e1 === e2 is not always true even if expressions e1 and e2
are syntactically equal, examples:
- NaN !== NaN (NaN is not equal to itself)
- [1] !== [1] (different arrays allocated)
- f() !== f()
This returns True if the values are definitely equal in JavaScript
-}
eqVal :: JVal -> JVal -> Bool
eqVal (JInt n1) (JInt n2) = n1 == n2
eqVal (JStr s1) (JStr s2) = s1 == s2
eqVal (JBool b1) (JBool b2) = b1 == b2
eqVal (JDouble (SaneDouble d1)) (JDouble (SaneDouble d2))
| not (isNaN d1) && not (isNaN d2) = d1 == d2
eqVal _ _ = False
|
