{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.StgToJS.DataCon
-- 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
--
--  Code generation of data constructors
-----------------------------------------------------------------------------

module GHC.StgToJS.DataCon
  ( genCon
  , allocCon
  , allocUnboxedCon
  , allocDynamicE
  , allocDynamic
  )
where

import GHC.Prelude

import GHC.JS.Syntax
import GHC.JS.Make

import GHC.StgToJS.Closure
import GHC.StgToJS.ExprCtx
import GHC.StgToJS.Types
import GHC.StgToJS.Monad
import GHC.StgToJS.CoreUtils
import GHC.StgToJS.Profiling
import GHC.StgToJS.Utils
import GHC.StgToJS.Ids

import GHC.Core.DataCon

import GHC.Types.CostCentre
import GHC.Types.Unique.Map

import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString

import Data.Maybe

-- | Generate a data constructor. Special handling for unboxed tuples
genCon :: ExprCtx -> DataCon -> [JExpr] -> G JStat
genCon :: ExprCtx -> DataCon -> [JExpr] -> G JStat
genCon ExprCtx
ctx DataCon
con [JExpr]
args
  | DataCon -> Bool
isUnboxedTupleDataCon DataCon
con
  = JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => ExprCtx -> [JExpr] -> JStat
ExprCtx -> [JExpr] -> JStat
assignToExprCtx ExprCtx
ctx [JExpr]
args

  | [ValExpr (JVar Ident
ctxi)] <- (TypedExpr -> [JExpr]) -> [TypedExpr] -> [JExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
  = Ident -> DataCon -> CostCentreStack -> [JExpr] -> G JStat
allocCon Ident
ctxi DataCon
con CostCentreStack
currentCCS [JExpr]
args

  | [JExpr]
xs <- (TypedExpr -> [JExpr]) -> [TypedExpr] -> [JExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
  = String -> SDoc -> G JStat
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genCon: unhandled DataCon" ((DataCon, [JExpr], [JExpr]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DataCon
con, [JExpr]
args, [JExpr]
xs))

-- | Allocate a data constructor. Allocate in this context means bind the data
-- constructor to 'to'
allocCon :: Ident -> DataCon -> CostCentreStack -> [JExpr] -> G JStat
allocCon :: Ident -> DataCon -> CostCentreStack -> [JExpr] -> G JStat
allocCon Ident
to DataCon
con CostCentreStack
cc [JExpr]
xs
  | DataCon -> Bool
isBoolDataCon DataCon
con Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxableCon DataCon
con =
      JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
to JExpr -> JExpr -> JStat
|= DataCon -> [JExpr] -> JExpr
allocUnboxedCon DataCon
con [JExpr]
xs)
{-  | null xs = do
      i <- varForId (dataConWorkId con)
      return (assignj to i) -}
  | Bool
otherwise = do
      JExpr
e <- DataCon -> G JExpr
varForDataConWorker DataCon
con
      StgToJSConfig
cs <- G StgToJSConfig
getSettings
      Bool
prof <- G Bool
profiling
      Maybe JExpr
ccsJ <- if Bool
prof then CostCentreStack -> G (Maybe JExpr)
ccsVarJ CostCentreStack
cc else Maybe JExpr -> G (Maybe JExpr)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe JExpr
forall a. Maybe a
Nothing
      JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ StgToJSConfig
-> Bool -> Ident -> JExpr -> [JExpr] -> Maybe JExpr -> JStat
allocDynamic StgToJSConfig
cs Bool
False Ident
to JExpr
e [JExpr]
xs Maybe JExpr
ccsJ

-- | Allocate an unboxed data constructor. If we have a bool we calculate the
-- right value. If not then we expect a singleton list and unbox by converting
-- ''C x' to 'x'. NB. This function may panic.
allocUnboxedCon :: DataCon -> [JExpr] -> JExpr
allocUnboxedCon :: DataCon -> [JExpr] -> JExpr
allocUnboxedCon DataCon
con = \case
  []
    | DataCon -> Bool
isBoolDataCon DataCon
con Bool -> Bool -> Bool
&& DataCon -> Int
dataConTag DataCon
con Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> JExpr
false_
    | DataCon -> Bool
isBoolDataCon DataCon
con Bool -> Bool -> Bool
&& DataCon -> Int
dataConTag DataCon
con Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 -> JExpr
true_
  [JExpr
x]
    | DataCon -> Bool
isUnboxableCon DataCon
con -> JExpr
x
  [JExpr]
xs -> String -> SDoc -> JExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocUnboxedCon: not an unboxed constructor" ((DataCon, [JExpr]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DataCon
con,[JExpr]
xs))

-- | Allocate an entry function. See 'GHC.StgToJS.hs' for the object layout.
allocDynamicE :: Bool          -- ^ csInlineAlloc from StgToJSConfig
              -> JExpr
              -> [JExpr]
              -> Maybe JExpr
              -> JExpr
allocDynamicE :: Bool -> JExpr -> [JExpr] -> Maybe JExpr -> JExpr
allocDynamicE  Bool
inline_alloc JExpr
entry [JExpr]
free Maybe JExpr
cc
  | Bool
inline_alloc Bool -> Bool -> Bool
|| [JExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
free Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
24 = Closure -> JExpr
newClosure (Closure -> JExpr) -> Closure -> JExpr
forall a b. (a -> b) -> a -> b
$ Closure
      { clEntry :: JExpr
clEntry  = JExpr
entry
      , clField1 :: JExpr
clField1 = JExpr
fillObj1
      , clField2 :: JExpr
clField2 = JExpr
fillObj2
      , clMeta :: JExpr
clMeta   = JVal -> JExpr
ValExpr (Integer -> JVal
JInt Integer
0)
      , clCC :: Maybe JExpr
clCC     = Maybe JExpr
cc
      }
  | Bool
otherwise = JExpr -> [JExpr] -> JExpr
ApplExpr JExpr
allocFun (JExpr -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
entry JExpr -> [JExpr] -> [JExpr]
forall a. a -> [a] -> [a]
: [JExpr]
free [JExpr] -> [JExpr] -> [JExpr]
forall a. [a] -> [a] -> [a]
++ Maybe JExpr -> [JExpr]
forall a. Maybe a -> [a]
maybeToList Maybe JExpr
cc)
  where
    allocFun :: JExpr
allocFun = Int -> JExpr
allocClsA ([JExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
free)
    (JExpr
fillObj1,JExpr
fillObj2)
       = case [JExpr]
free of
                []  -> (JExpr
null_, JExpr
null_)
                [JExpr
x] -> (JExpr
x,JExpr
null_)
                [JExpr
x,JExpr
y] -> (JExpr
x,JExpr
y)
                (JExpr
x:[JExpr]
xs) -> (JExpr
x,JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (UniqMap FastString JExpr -> JVal
JHash (UniqMap FastString JExpr -> JVal)
-> UniqMap FastString JExpr -> JVal
forall a b. (a -> b) -> a -> b
$ [(FastString, JExpr)] -> UniqMap FastString JExpr
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap ([FastString] -> [JExpr] -> [(FastString, JExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FastString]
dataFields [JExpr]
xs)))
    dataFields :: [FastString]
dataFields = (Int -> FastString) -> [Int] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map (String -> FastString
mkFastString (String -> FastString) -> (Int -> String) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'd'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [(Int
1::Int)..]

-- | Allocate a dynamic object
allocDynamic :: StgToJSConfig -> Bool -> Ident -> JExpr -> [JExpr] -> Maybe JExpr -> JStat
allocDynamic :: StgToJSConfig
-> Bool -> Ident -> JExpr -> [JExpr] -> Maybe JExpr -> JStat
allocDynamic StgToJSConfig
s Bool
need_decl Ident
to JExpr
entry [JExpr]
free Maybe JExpr
cc
  | Bool
need_decl = Ident -> Maybe JExpr -> JStat
DeclStat Ident
to (JExpr -> Maybe JExpr
forall a. a -> Maybe a
Just JExpr
value)
  | Bool
otherwise = Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
to JExpr -> JExpr -> JStat
|= JExpr
value
    where
      value :: JExpr
value = Bool -> JExpr -> [JExpr] -> Maybe JExpr -> JExpr
allocDynamicE (StgToJSConfig -> Bool
csInlineAlloc StgToJSConfig
s) JExpr
entry [JExpr]
free Maybe JExpr
cc