{-# 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 :: JStat -> JStat
optExprs JStat
s = JStat -> JStat
go JStat
s
  where
    go :: JStat -> JStat
go (DeclStat Ident
v Maybe JExpr
mb_e) = Ident -> Maybe JExpr -> JStat
DeclStat Ident
v ((JExpr -> JExpr) -> Maybe JExpr -> Maybe JExpr
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JExpr -> JExpr
opt Maybe JExpr
mb_e)
    go (AssignStat JExpr
lhs AOp
op JExpr
rhs) = JExpr -> AOp -> JExpr -> JStat
AssignStat (JExpr -> JExpr
opt JExpr
lhs) AOp
op (JExpr -> JExpr
opt JExpr
rhs)
    go (ReturnStat JExpr
e) = JExpr -> JStat
ReturnStat (JExpr -> JExpr
opt JExpr
e)
    go (BlockStat [JStat]
ss) = [JStat] -> JStat
BlockStat ((JStat -> JStat) -> [JStat] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map JStat -> JStat
go [JStat]
ss)
    go (IfStat JExpr
e JStat
s1 JStat
s2) = JExpr -> JStat -> JStat -> JStat
IfStat (JExpr -> JExpr
optCond JExpr
e) (JStat -> JStat
go JStat
s1) (JStat -> JStat
go JStat
s2)
    go (WhileStat Bool
b JExpr
e JStat
s) = Bool -> JExpr -> JStat -> JStat
WhileStat Bool
b (JExpr -> JExpr
optCond JExpr
e) (JStat -> JStat
go JStat
s)
    go (ForStat JStat
s1 JExpr
e JStat
s2 JStat
s3) = JStat -> JExpr -> JStat -> JStat -> JStat
ForStat (JStat -> JStat
go JStat
s1) (JExpr -> JExpr
optCond JExpr
e) (JStat -> JStat
go JStat
s2) (JStat -> JStat
go JStat
s3)
    go (ForInStat Bool
b Ident
v JExpr
e JStat
s) = Bool -> Ident -> JExpr -> JStat -> JStat
ForInStat Bool
b Ident
v (JExpr -> JExpr
opt JExpr
e) (JStat -> JStat
go JStat
s)
    go (SwitchStat JExpr
e [(JExpr, JStat)]
cases JStat
s) = JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat (JExpr -> JExpr
opt JExpr
e)
                                           (((JExpr, JStat) -> (JExpr, JStat))
-> [(JExpr, JStat)] -> [(JExpr, JStat)]
forall a b. (a -> b) -> [a] -> [b]
map ((JStat -> JStat) -> (JExpr, JStat) -> (JExpr, JStat)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second JStat -> JStat
go) [(JExpr, JStat)]
cases)
                                           (JStat -> JStat
go JStat
s)
    go (TryStat JStat
s1 Ident
v JStat
s2 JStat
s3) = JStat -> Ident -> JStat -> JStat -> JStat
TryStat (JStat -> JStat
go JStat
s1) Ident
v (JStat -> JStat
go JStat
s2) (JStat -> JStat
go JStat
s3)
    go (ApplStat JExpr
e [JExpr]
es) = JExpr -> [JExpr] -> JStat
ApplStat (JExpr -> JExpr
opt JExpr
e) ((JExpr -> JExpr) -> [JExpr] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map JExpr -> JExpr
opt [JExpr]
es)
    go (UOpStat UOp
op JExpr
e) = UOp -> JExpr -> JStat
UOpStat UOp
op (JExpr -> JExpr
opt JExpr
e)
    go (LabelStat JLabel
lbl JStat
s) = JLabel -> JStat -> JStat
LabelStat JLabel
lbl (JStat -> JStat
go JStat
s)
    go s :: JStat
s@(BreakStat{}) = JStat
s
    go s :: JStat
s@(ContinueStat{}) = JStat
s
    go (FuncStat Ident
n [Ident]
vs JStat
s) = Ident -> [Ident] -> JStat -> JStat
FuncStat Ident
n [Ident]
vs (JStat -> JStat
go JStat
s)

 -- remove double negation if we're using the expression in a loop/if condition
optCond :: JExpr -> JExpr
optCond :: JExpr -> JExpr
optCond JExpr
e = let f :: JExpr -> JExpr
f (UOpExpr UOp
NotOp (UOpExpr UOp
NotOp JExpr
e')) = JExpr -> JExpr
f JExpr
e'
                f JExpr
e' = JExpr
e'
            in JExpr -> JExpr
f (JExpr -> JExpr
opt JExpr
e)

opt :: JExpr -> JExpr
opt :: JExpr -> JExpr
opt (ValExpr JVal
v)          = JVal -> JExpr
ValExpr JVal
v
opt (SelExpr JExpr
e Ident
i)        = JExpr -> Ident -> JExpr
SelExpr (JExpr -> JExpr
opt JExpr
e) Ident
i
opt (IdxExpr JExpr
e1 JExpr
e2)      = JExpr -> JExpr -> JExpr
IdxExpr (JExpr -> JExpr
opt JExpr
e1) (JExpr -> JExpr
opt JExpr
e2)
-- ((c_e ? 1 : 0) === 1)   ==> !!c_e
-- ((c_e ? 1 : 0) === 0)   ==> !c_e
opt(InfixExpr Op
StrictEqOp (IfExpr JExpr
c_e (JExpr -> JExpr
opt -> JExpr
t_e) (JExpr -> JExpr
opt -> JExpr
f_e)) (JExpr -> JExpr
opt -> JExpr
e))
    | ValExpr JVal
t_v <- JExpr
t_e
    , ValExpr JVal
v <- JExpr
e
    , JVal -> JVal -> Bool
eqVal JVal
t_v JVal
v = UOp -> JExpr -> JExpr
UOpExpr UOp
NotOp (UOp -> JExpr -> JExpr
UOpExpr UOp
NotOp JExpr
c_e)
    | ValExpr JVal
f_v <- JExpr
f_e
    , ValExpr JVal
v <- JExpr
e
    , JVal -> JVal -> Bool
eqVal JVal
f_v JVal
v = UOp -> JExpr -> JExpr
UOpExpr UOp
NotOp (JExpr -> JExpr
opt JExpr
c_e)
    | Bool
otherwise = Op -> JExpr -> JExpr -> JExpr
InfixExpr Op
StrictEqOp (JExpr -> JExpr -> JExpr -> JExpr
IfExpr JExpr
c_e JExpr
t_e JExpr
f_e) JExpr
e
-- (1 === (c_e ? 1 : 0))   ==> !!c_e
-- (0 === (c_e ? 1 : 0))   ==> !c_e
opt(InfixExpr Op
StrictEqOp (JExpr -> JExpr
opt -> JExpr
e) (IfExpr (JExpr -> JExpr
opt -> JExpr
c_e) (JExpr -> JExpr
opt -> JExpr
t_e) (JExpr -> JExpr
opt -> JExpr
f_e)))
    | ValExpr JVal
t_v <- JExpr
t_e
    , ValExpr JVal
v <- JExpr
e
    , JVal -> JVal -> Bool
eqVal JVal
t_v JVal
v = UOp -> JExpr -> JExpr
UOpExpr UOp
NotOp (UOp -> JExpr -> JExpr
UOpExpr UOp
NotOp JExpr
c_e)
    | ValExpr JVal
f_v <- JExpr
f_e
    , ValExpr JVal
v <- JExpr
e
    , JVal -> JVal -> Bool
eqVal JVal
f_v JVal
v = UOp -> JExpr -> JExpr
UOpExpr UOp
NotOp JExpr
c_e
    | Bool
otherwise = Op -> JExpr -> JExpr -> JExpr
InfixExpr Op
StrictEqOp JExpr
e (JExpr -> JExpr -> JExpr -> JExpr
IfExpr JExpr
c_e JExpr
t_e JExpr
f_e)
opt (InfixExpr Op
op (JExpr -> JExpr
opt -> JExpr
e1) (JExpr -> JExpr
opt -> JExpr
e2))
  | (ValExpr (JInt Integer
n1)) <- JExpr
e1
  , (ValExpr (JInt Integer
n2)) <- JExpr
e2
  , Just JVal
v <- Op -> Integer -> Integer -> Maybe JVal
optInt Op
op Integer
n1 Integer
n2 = JVal -> JExpr
ValExpr JVal
v
  | (ValExpr (JBool Bool
b1)) <- JExpr
e1
  , (ValExpr (JBool Bool
b2)) <- JExpr
e2
  , Just JVal
v <- Op -> Bool -> Bool -> Maybe JVal
optBool Op
op Bool
b1 Bool
b2 = JVal -> JExpr
ValExpr JVal
v
  | Bool
otherwise = Op -> JExpr -> JExpr -> JExpr
InfixExpr Op
op JExpr
e1 JExpr
e2
opt (UOpExpr UOp
op JExpr
e)       = UOp -> JExpr -> JExpr
UOpExpr UOp
op (JExpr -> JExpr
opt JExpr
e)
opt (IfExpr JExpr
e1 JExpr
e2 JExpr
e3)    = JExpr -> JExpr -> JExpr -> JExpr
IfExpr (JExpr -> JExpr
optCond JExpr
e1) (JExpr -> JExpr
opt JExpr
e2) (JExpr -> JExpr
opt JExpr
e3)
opt (ApplExpr JExpr
e [JExpr]
es)      = JExpr -> [JExpr] -> JExpr
ApplExpr (JExpr -> JExpr
opt JExpr
e) ((JExpr -> JExpr) -> [JExpr] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map JExpr -> JExpr
opt [JExpr]
es)

{-
  Optimizations for operations on two known boolean values
 -}
optBool :: Op -> Bool -> Bool -> Maybe JVal
optBool :: Op -> Bool -> Bool -> Maybe JVal
optBool Op
LAndOp Bool
x Bool
y = JVal -> Maybe JVal
forall a. a -> Maybe a
Just (Bool -> JVal
JBool (Bool
x Bool -> Bool -> Bool
&& Bool
y))
optBool Op
LOrOp Bool
x Bool
y = JVal -> Maybe JVal
forall a. a -> Maybe a
Just (Bool -> JVal
JBool (Bool
x Bool -> Bool -> Bool
|| Bool
y))
optBool Op
EqOp Bool
x Bool
y = JVal -> Maybe JVal
forall a. a -> Maybe a
Just (Bool -> JVal
JBool (Bool
x Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
y))
optBool Op
StrictEqOp Bool
x Bool
y = JVal -> Maybe JVal
forall a. a -> Maybe a
Just (Bool -> JVal
JBool (Bool
x Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
y))
optBool Op
NeqOp Bool
x Bool
y = JVal -> Maybe JVal
forall a. a -> Maybe a
Just (Bool -> JVal
JBool (Bool
x Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
y))
optBool Op
StrictNeqOp Bool
x Bool
y = JVal -> Maybe JVal
forall a. a -> Maybe a
Just (Bool -> JVal
JBool (Bool
x Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
y))
optBool Op
_ Bool
_ Bool
_ = Maybe JVal
forall a. Maybe a
Nothing

{-
  Optimizations for operations on two known integer values
 -}
optInt :: Op -> Integer -> Integer -> Maybe JVal
optInt :: Op -> Integer -> Integer -> Maybe JVal
optInt Op
ZRightShiftOp Integer
n Integer
m = JVal -> Maybe JVal
forall a. a -> Maybe a
Just (JVal -> Maybe JVal) -> JVal -> Maybe JVal
forall a b. (a -> b) -> a -> b
$
  Integer -> JVal
JInt (Integer -> Integer
forall a. Integral a => a -> Integer
toInteger (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ (Integer
n Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
0xffffffff) Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer
m Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
0x1f))
optInt Op
BOrOp Integer
n Integer
m = JVal -> Maybe JVal
forall a. a -> Maybe a
Just ((Int32 -> Int32 -> Int32) -> Integer -> Integer -> JVal
truncOp Int32 -> Int32 -> Int32
forall a. Bits a => a -> a -> a
(.|.) Integer
n Integer
m)
optInt Op
BAndOp Integer
n Integer
m = JVal -> Maybe JVal
forall a. a -> Maybe a
Just ((Int32 -> Int32 -> Int32) -> Integer -> Integer -> JVal
truncOp Int32 -> Int32 -> Int32
forall a. Bits a => a -> a -> a
(.&.) Integer
n Integer
m)
optInt Op
BXorOp Integer
n Integer
m = JVal -> Maybe JVal
forall a. a -> Maybe a
Just ((Int32 -> Int32 -> Int32) -> Integer -> Integer -> JVal
truncOp Int32 -> Int32 -> Int32
forall a. Bits a => a -> a -> a
(.^.) Integer
n Integer
m)
optInt Op
RightShiftOp Integer
n Integer
m = JVal -> Maybe JVal
forall a. a -> Maybe a
Just ((Int32 -> Int -> Int32) -> Integer -> Integer -> JVal
shiftOp Int32 -> Int -> Int32
forall a. Bits a => a -> Int -> a
shiftR Integer
n Integer
m)
optInt Op
LeftShiftOp Integer
n Integer
m = JVal -> Maybe JVal
forall a. a -> Maybe a
Just ((Int32 -> Int -> Int32) -> Integer -> Integer -> JVal
shiftOp Int32 -> Int -> Int32
forall a. Bits a => a -> Int -> a
shiftL Integer
n Integer
m)
optInt Op
AddOp Integer
n Integer
m = (Integer -> Integer -> Integer) -> Integer -> Integer -> Maybe JVal
smallIntOp Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+) Integer
n Integer
m
optInt Op
SubOp Integer
n Integer
m = (Integer -> Integer -> Integer) -> Integer -> Integer -> Maybe JVal
smallIntOp (-) Integer
n Integer
m
optInt Op
MulOp Integer
n Integer
m = (Integer -> Integer -> Integer) -> Integer -> Integer -> Maybe JVal
smallIntOp Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*) Integer
n Integer
m
optInt Op
op Integer
n Integer
m
  | Just Integer -> Integer -> Bool
cmp <- Op -> Maybe (Integer -> Integer -> Bool)
getCmpOp Op
op, Integer -> Bool
isSmall52 Integer
n Bool -> Bool -> Bool
&& Integer -> Bool
isSmall52 Integer
m
  = JVal -> Maybe JVal
forall a. a -> Maybe a
Just (Bool -> JVal
JBool (Integer -> Integer -> Bool
cmp Integer
n Integer
m))
optInt Op
_ Integer
_ Integer
_ = Maybe JVal
forall a. Maybe a
Nothing

smallIntOp :: (Integer -> Integer -> Integer)
           -> Integer -> Integer -> Maybe JVal
smallIntOp :: (Integer -> Integer -> Integer) -> Integer -> Integer -> Maybe JVal
smallIntOp Integer -> Integer -> Integer
op Integer
n Integer
m
  | Integer -> Bool
isSmall52 Integer
n Bool -> Bool -> Bool
&& Integer -> Bool
isSmall52 Integer
m Bool -> Bool -> Bool
&& Integer -> Bool
isSmall52 Integer
r = JVal -> Maybe JVal
forall a. a -> Maybe a
Just (Integer -> JVal
JInt Integer
r)
  | Bool
otherwise                                 = Maybe JVal
forall a. Maybe a
Nothing
  where
    r :: Integer
r = Integer -> Integer -> Integer
op Integer
n Integer
m

getCmpOp :: Op -> Maybe (Integer -> Integer -> Bool)
getCmpOp :: Op -> Maybe (Integer -> Integer -> Bool)
getCmpOp Op
EqOp = (Integer -> Integer -> Bool) -> Maybe (Integer -> Integer -> Bool)
forall a. a -> Maybe a
Just Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
(==)
getCmpOp Op
StrictEqOp = (Integer -> Integer -> Bool) -> Maybe (Integer -> Integer -> Bool)
forall a. a -> Maybe a
Just Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
(==)
getCmpOp Op
NeqOp = (Integer -> Integer -> Bool) -> Maybe (Integer -> Integer -> Bool)
forall a. a -> Maybe a
Just Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
(/=)
getCmpOp Op
StrictNeqOp = (Integer -> Integer -> Bool) -> Maybe (Integer -> Integer -> Bool)
forall a. a -> Maybe a
Just Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
(/=)
getCmpOp Op
GtOp = (Integer -> Integer -> Bool) -> Maybe (Integer -> Integer -> Bool)
forall a. a -> Maybe a
Just Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>)
getCmpOp Op
GeOp = (Integer -> Integer -> Bool) -> Maybe (Integer -> Integer -> Bool)
forall a. a -> Maybe a
Just Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>=)
getCmpOp Op
LtOp = (Integer -> Integer -> Bool) -> Maybe (Integer -> Integer -> Bool)
forall a. a -> Maybe a
Just Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(<)
getCmpOp Op
LeOp = (Integer -> Integer -> Bool) -> Maybe (Integer -> Integer -> Bool)
forall a. a -> Maybe a
Just Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(<=)
getCmpOp Op
_ = Maybe (Integer -> Integer -> Bool)
forall a. Maybe a
Nothing

shiftOp :: (Int32 -> Int -> Int32) -> Integer -> Integer -> JVal
shiftOp :: (Int32 -> Int -> Int32) -> Integer -> Integer -> JVal
shiftOp Int32 -> Int -> Int32
op Integer
n Integer
m = Integer -> JVal
JInt (Integer -> JVal) -> Integer -> JVal
forall a b. (a -> b) -> a -> b
$ Int32 -> Integer
forall a. Integral a => a -> Integer
toInteger
   (Integer -> Int32
forall a. Num a => Integer -> a
fromInteger Integer
n Int32 -> Int -> Int32
`op` (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
m Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
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 :: (Int32 -> Int32 -> Int32) -> Integer -> Integer -> JVal
truncOp Int32 -> Int32 -> Int32
op Integer
n Integer
m = Integer -> JVal
JInt (Integer -> JVal) -> Integer -> JVal
forall a b. (a -> b) -> a -> b
$ Int32 -> Integer
forall a. Integral a => a -> Integer
toInteger
   (Integer -> Int32
forall a. Num a => Integer -> a
fromInteger Integer
n Int32 -> Int32 -> Int32
`op` Integer -> Int32
forall a. Num a => Integer -> a
fromInteger Integer
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 :: Integer -> Bool
isSmall52 Integer
n = Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= -Integer
0x10000000000000 Bool -> Bool -> Bool
&& Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
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 :: JVal -> JVal -> Bool
eqVal (JInt Integer
n1) (JInt Integer
n2)   = Integer
n1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
n2
eqVal (JStr FastString
s1) (JStr FastString
s2)   = FastString
s1 FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
s2
eqVal (JBool Bool
b1) (JBool Bool
b2) = Bool
b1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b2
eqVal (JDouble (SaneDouble Double
d1)) (JDouble (SaneDouble Double
d2))
  | Bool -> Bool
not (Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
d1) Bool -> Bool -> Bool
&& Bool -> Bool
not (Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
d2) = Double
d1 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
d2
eqVal JVal
_ JVal
_ = Bool
False