{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.StgToJS.Literal
( genLit
, genStaticLit
)
where
import GHC.Prelude
import GHC.JS.JStg.Syntax
import GHC.JS.Make
import GHC.JS.Ident
import GHC.StgToJS.Ids
import GHC.StgToJS.Monad
import GHC.StgToJS.Symbols
import GHC.StgToJS.Types
import GHC.StgToJS.Linker.Utils (decodeModifiedUTF8)
import GHC.Types.Literal
import GHC.Types.Basic
import GHC.Types.RepType
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Float
import Data.Bits as Bits
import Data.Char (ord)
genLit :: HasDebugCallStack => Literal -> G [JStgExpr]
genLit :: HasDebugCallStack => Literal -> G [JStgExpr]
genLit = \case
LitChar Char
c -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Char -> Int
ord Char
c) ]
LitString ByteString
str ->
G Ident
freshIdent G Ident -> (Ident -> G [JStgExpr]) -> G [JStgExpr]
forall a b.
StateT GenState IO a
-> (a -> StateT GenState IO b) -> StateT GenState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \strLit :: Ident
strLit@(Ident -> FastString
identFS -> FastString
strLitT) ->
G Ident
freshIdent G Ident -> (Ident -> G [JStgExpr]) -> G [JStgExpr]
forall a b.
StateT GenState IO a
-> (a -> StateT GenState IO b) -> StateT GenState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \strOff :: Ident
strOff@(Ident -> FastString
identFS -> FastString
strOffT) -> do
FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
strLitT (StaticUnboxed -> StaticVal
StaticUnboxed (ByteString -> StaticUnboxed
StaticUnboxedString ByteString
str)) Maybe Ident
forall a. Maybe a
Nothing
FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
strOffT (StaticUnboxed -> StaticVal
StaticUnboxed (ByteString -> StaticUnboxed
StaticUnboxedStringOffset ByteString
str)) Maybe Ident
forall a. Maybe a
Nothing
[JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Ident -> JStgExpr
Var Ident
strLit, Ident -> JStgExpr
Var Ident
strOff ]
Literal
LitNullAddr -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ JStgExpr
null_, JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0) ]
LitNumber LitNumType
nt Integer
v -> case LitNumType
nt of
LitNumType
LitNumInt -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Integer
v ]
LitNumType
LitNumInt8 -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Integer
v ]
LitNumType
LitNumInt16 -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Integer
v ]
LitNumType
LitNumInt32 -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Integer
v ]
LitNumType
LitNumInt64 -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
Bits.shiftR Integer
v Int
32), Integer -> JStgExpr
toU32Expr Integer
v ]
LitNumType
LitNumWord -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> JStgExpr
toU32Expr Integer
v ]
LitNumType
LitNumWord8 -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> JStgExpr
toU32Expr Integer
v ]
LitNumType
LitNumWord16 -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> JStgExpr
toU32Expr Integer
v ]
LitNumType
LitNumWord32 -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> JStgExpr
toU32Expr Integer
v ]
LitNumType
LitNumWord64 -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> JStgExpr
toU32Expr (Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
Bits.shiftR Integer
v Int
32), Integer -> JStgExpr
toU32Expr Integer
v ]
LitNumType
LitNumBigNat -> String -> G [JStgExpr]
forall a. HasCallStack => String -> a
panic String
"genLit: unexpected BigNat that should have been removed in CorePrep"
LitFloat Rational
r -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Double -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Rational -> Double
r2f Rational
r) ]
LitDouble Rational
r -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Double -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Rational -> Double
r2d Rational
r) ]
LitLabel FastString
name FunctionOrData
fod
| FunctionOrData
fod FunctionOrData -> FunctionOrData -> Bool
forall a. Eq a => a -> a -> Bool
== FunctionOrData
IsFunction -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr JStgExpr
hdMkFunctionPtr
[FastString -> JStgExpr
global (Bool -> FastString -> FastString
mkRawSymbol Bool
True FastString
name)]
, JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0)
]
| Bool
otherwise -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ JStgExpr -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (FastString -> JStgExpr
global (Bool -> FastString -> FastString
mkRawSymbol Bool
True FastString
name))
, JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0)
]
LitRubbish TypeOrConstraint
_ RuntimeRepType
rr_ty ->
let reps :: [PrimRep]
reps = HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep]
SDoc -> RuntimeRepType -> [PrimRep]
runtimeRepPrimRep (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"GHC.StgToJS.Literal.genLit") RuntimeRepType
rr_ty
rub :: PrimRep -> [JStgExpr]
rub = \case
BoxedRep Maybe Levity
_ -> [ JStgExpr
null_ ]
PrimRep
AddrRep -> [ JStgExpr
null_, JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0) ]
PrimRep
WordRep -> [ JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0) ]
PrimRep
Word8Rep -> [ JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0) ]
PrimRep
Word16Rep -> [ JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0) ]
PrimRep
Word32Rep -> [ JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0) ]
PrimRep
Word64Rep -> [ JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0), JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0) ]
PrimRep
IntRep -> [ JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0) ]
PrimRep
Int8Rep -> [ JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0) ]
PrimRep
Int16Rep -> [ JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0) ]
PrimRep
Int32Rep -> [ JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0) ]
PrimRep
Int64Rep -> [ JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0), JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0) ]
PrimRep
DoubleRep -> [ JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0) ]
PrimRep
FloatRep -> [ JVal -> JStgExpr
ValExpr (Integer -> JVal
JInt Integer
0) ]
VecRep Int
_ PrimElemRep
_ -> String -> [JStgExpr]
forall a. HasCallStack => String -> a
panic String
"GHC.StgToJS.Literal.genLit: VecRep unsupported"
in [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((PrimRep -> [JStgExpr]) -> [PrimRep] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PrimRep -> [JStgExpr]
rub [PrimRep]
reps)
genStaticLit :: Literal -> G [StaticLit]
genStaticLit :: Literal -> G [StaticLit]
genStaticLit = \case
LitChar Char
c -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
IntLit (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c) ]
LitString ByteString
str -> case ByteString -> Maybe FastString
decodeModifiedUTF8 ByteString
str of
Just FastString
t -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ FastString -> StaticLit
StringLit FastString
t, Integer -> StaticLit
IntLit Integer
0]
Maybe FastString
Nothing -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ ByteString -> StaticLit
BinLit ByteString
str, Integer -> StaticLit
IntLit Integer
0]
Literal
LitNullAddr -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ StaticLit
NullLit, Integer -> StaticLit
IntLit Integer
0 ]
LitNumber LitNumType
nt Integer
v -> case LitNumType
nt of
LitNumType
LitNumInt -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
IntLit Integer
v ]
LitNumType
LitNumInt8 -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
IntLit Integer
v ]
LitNumType
LitNumInt16 -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
IntLit Integer
v ]
LitNumType
LitNumInt32 -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
IntLit Integer
v ]
LitNumType
LitNumInt64 -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
IntLit (Integer
v Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`Bits.shiftR` Int
32), Integer -> StaticLit
toU32Lit Integer
v ]
LitNumType
LitNumWord -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
toU32Lit Integer
v ]
LitNumType
LitNumWord8 -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
toU32Lit Integer
v ]
LitNumType
LitNumWord16 -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
toU32Lit Integer
v ]
LitNumType
LitNumWord32 -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
toU32Lit Integer
v ]
LitNumType
LitNumWord64 -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
toU32Lit (Integer
v Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`Bits.shiftR` Int
32), Integer -> StaticLit
toU32Lit Integer
v ]
LitNumType
LitNumBigNat -> String -> G [StaticLit]
forall a. HasCallStack => String -> a
panic String
"genStaticLit: unexpected BigNat that should have been removed in CorePrep"
LitFloat Rational
r -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ SaneDouble -> StaticLit
DoubleLit (SaneDouble -> StaticLit)
-> (Rational -> SaneDouble) -> Rational -> StaticLit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> SaneDouble
SaneDouble (Double -> SaneDouble)
-> (Rational -> Double) -> Rational -> SaneDouble
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Double
r2f (Rational -> StaticLit) -> Rational -> StaticLit
forall a b. (a -> b) -> a -> b
$ Rational
r ]
LitDouble Rational
r -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ SaneDouble -> StaticLit
DoubleLit (SaneDouble -> StaticLit)
-> (Rational -> SaneDouble) -> Rational -> StaticLit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> SaneDouble
SaneDouble (Double -> SaneDouble)
-> (Rational -> Double) -> Rational -> SaneDouble
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Double
r2d (Rational -> StaticLit) -> Rational -> StaticLit
forall a b. (a -> b) -> a -> b
$ Rational
r ]
LitLabel FastString
name FunctionOrData
fod -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Bool -> FastString -> StaticLit
LabelLit (FunctionOrData
fod FunctionOrData -> FunctionOrData -> Bool
forall a. Eq a => a -> a -> Bool
== FunctionOrData
IsFunction) (Bool -> FastString -> FastString
mkRawSymbol Bool
True FastString
name)
, Integer -> StaticLit
IntLit Integer
0 ]
LitRubbish TypeOrConstraint
_ RuntimeRepType
rep ->
let prim_reps :: [PrimRep]
prim_reps = HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep]
SDoc -> RuntimeRepType -> [PrimRep]
runtimeRepPrimRep (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"GHC.StgToJS.Literal.genStaticLit") RuntimeRepType
rep
in case String -> [PrimRep] -> PrimRep
forall a. HasDebugCallStack => String -> [a] -> a
expectOnly String
"GHC.StgToJS.Literal.genStaticLit" [PrimRep]
prim_reps of
BoxedRep Maybe Levity
_ -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ StaticLit
NullLit ]
PrimRep
AddrRep -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ StaticLit
NullLit, Integer -> StaticLit
IntLit Integer
0 ]
PrimRep
IntRep -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Integer -> StaticLit
IntLit Integer
0 ]
PrimRep
Int8Rep -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Integer -> StaticLit
IntLit Integer
0 ]
PrimRep
Int16Rep -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Integer -> StaticLit
IntLit Integer
0 ]
PrimRep
Int32Rep -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Integer -> StaticLit
IntLit Integer
0 ]
PrimRep
Int64Rep -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Integer -> StaticLit
IntLit Integer
0, Integer -> StaticLit
IntLit Integer
0 ]
PrimRep
WordRep -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Integer -> StaticLit
IntLit Integer
0 ]
PrimRep
Word8Rep -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Integer -> StaticLit
IntLit Integer
0 ]
PrimRep
Word16Rep -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Integer -> StaticLit
IntLit Integer
0 ]
PrimRep
Word32Rep -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Integer -> StaticLit
IntLit Integer
0 ]
PrimRep
Word64Rep -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Integer -> StaticLit
IntLit Integer
0, Integer -> StaticLit
IntLit Integer
0 ]
PrimRep
FloatRep -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ SaneDouble -> StaticLit
DoubleLit (Double -> SaneDouble
SaneDouble Double
0) ]
PrimRep
DoubleRep -> [StaticLit] -> G [StaticLit]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ SaneDouble -> StaticLit
DoubleLit (Double -> SaneDouble
SaneDouble Double
0) ]
VecRep {} -> String -> SDoc -> G [StaticLit]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.StgToJS.Literal.genStaticLit: LitRubbish(VecRep) isn't supported" (RuntimeRepType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RuntimeRepType
rep)
toU32Expr :: Integer -> JStgExpr
toU32Expr :: Integer -> JStgExpr
toU32Expr Integer
i = Integer -> JStgExpr
Int (Integer
i Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
Bits..&. Integer
0xFFFFFFFF) JStgExpr -> JStgExpr -> JStgExpr
.>>>. JStgExpr
0
toU32Lit :: Integer -> StaticLit
toU32Lit :: Integer -> StaticLit
toU32Lit Integer
i = Integer -> StaticLit
IntLit (Integer
i Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
Bits..&. Integer
0xFFFFFFFF)
r2d :: Rational -> Double
r2d :: Rational -> Double
r2d = Rational -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
r2f :: Rational -> Double
r2f :: Rational -> Double
r2f = Float -> Double
float2Double (Float -> Double) -> (Rational -> Float) -> Rational -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac