{-# 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.JStg.Syntax
import GHC.JS.Ident
import GHC.JS.Make
import GHC.JS.Transform

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

import GHC.Core.DataCon

import GHC.Types.CostCentre

import GHC.Utils.Outputable
import GHC.Utils.Panic

import Data.Maybe

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

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

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

-- | Allocate a data constructor. Allocate in this context means bind the data
-- constructor to 'to'
allocCon :: Ident -> DataCon -> CostCentreStack -> [JStgExpr] -> G JStgStat
allocCon :: Ident -> DataCon -> CostCentreStack -> [JStgExpr] -> G JStgStat
allocCon Ident
to DataCon
con CostCentreStack
cc [JStgExpr]
xs
  | DataCon -> Bool
isBoolDataCon DataCon
con Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxableCon DataCon
con =
      JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ JStgExpr -> AOp -> JStgExpr -> JStgStat
AssignStat (Ident -> JStgExpr
Var Ident
to) AOp
AssignOp (DataCon -> [JStgExpr] -> JStgExpr
allocUnboxedCon DataCon
con [JStgExpr]
xs)
{-  | null xs = do
      i <- varForId (dataConWorkId con)
      return (assignj to i) -}
  | Bool
otherwise = do
      e <- DataCon -> G JStgExpr
varForDataConWorker DataCon
con
      cs <- getSettings
      prof <- profiling
      ccsJ <- if prof then ccsVarJ cc else return Nothing
      return $ allocDynamic cs False to e xs 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 -> [JStgExpr] -> JStgExpr
allocUnboxedCon :: DataCon -> [JStgExpr] -> JStgExpr
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 -> JStgExpr
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 -> JStgExpr
true_
  [JStgExpr
x]
    | DataCon -> Bool
isUnboxableCon DataCon
con -> JStgExpr
x
  [JStgExpr]
xs -> String -> SDoc -> JStgExpr
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, (JStgExpr -> JExpr) -> [JStgExpr] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map JStgExpr -> JExpr
jStgExprToJS [JStgExpr]
xs))

-- | Allocate an entry function. See 'GHC.StgToJS.hs' for the object layout.
allocDynamicE :: Bool          -- ^ csInlineAlloc from StgToJSConfig
              -> JStgExpr
              -> [JStgExpr]
              -> Maybe JStgExpr
              -> JStgExpr
allocDynamicE :: Bool -> JStgExpr -> [JStgExpr] -> Maybe JStgExpr -> JStgExpr
allocDynamicE  Bool
inline_alloc JStgExpr
entry [JStgExpr]
free Maybe JStgExpr
cc
  | Bool
inline_alloc Bool -> Bool -> Bool
|| [JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
free Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
jsClosureCount
    = Closure -> JStgExpr
newClosure (Closure -> JStgExpr) -> Closure -> JStgExpr
forall a b. (a -> b) -> a -> b
$ JStgExpr -> [JStgExpr] -> JStgExpr -> Maybe JStgExpr -> Closure
mkClosure JStgExpr
entry [JStgExpr]
free JStgExpr
zero_ Maybe JStgExpr
cc
  | Bool
otherwise = JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr JStgExpr
allocFun (JStgExpr
entry JStgExpr -> [JStgExpr] -> [JStgExpr]
forall a. a -> [a] -> [a]
: [JStgExpr]
free [JStgExpr] -> [JStgExpr] -> [JStgExpr]
forall a. [a] -> [a] -> [a]
++ Maybe JStgExpr -> [JStgExpr]
forall a. Maybe a -> [a]
maybeToList Maybe JStgExpr
cc)
  where
    allocFun :: JStgExpr
allocFun = Int -> JStgExpr
allocClsA ([JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
free)

-- | Allocate a dynamic object
allocDynamic :: StgToJSConfig -> Bool -> Ident -> JStgExpr -> [JStgExpr] -> Maybe JStgExpr -> JStgStat
allocDynamic :: StgToJSConfig
-> Bool
-> Ident
-> JStgExpr
-> [JStgExpr]
-> Maybe JStgExpr
-> JStgStat
allocDynamic StgToJSConfig
s Bool
need_decl Ident
to JStgExpr
entry [JStgExpr]
free Maybe JStgExpr
cc
  | Bool
need_decl = Ident -> Maybe JStgExpr -> JStgStat
DeclStat Ident
to (JStgExpr -> Maybe JStgExpr
forall a. a -> Maybe a
Just JStgExpr
value)
  | Bool
otherwise = JStgExpr -> AOp -> JStgExpr -> JStgStat
AssignStat (Ident -> JStgExpr
Var Ident
to) AOp
AssignOp JStgExpr
value
    where
      value :: JStgExpr
value = Bool -> JStgExpr -> [JStgExpr] -> Maybe JStgExpr -> JStgExpr
allocDynamicE (StgToJSConfig -> Bool
csInlineAlloc StgToJSConfig
s) JStgExpr
entry [JStgExpr]
free Maybe JStgExpr
cc