path: root/compiler/GHC/StgToJS/Arg.hs

{-# LANGUAGE LambdaCase #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.StgToJS.Args
-- 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 application arguments
-----------------------------------------------------------------------------

module GHC.StgToJS.Arg
  ( genArg
  , genIdArg
  , genIdArgI
  , genIdStackArgI
  , allocConStatic
  , allocUnboxedConStatic
  , allocateStaticList
  , jsStaticArg
  , jsStaticArgs
  )
where

import GHC.Prelude

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

import GHC.StgToJS.DataCon
import GHC.StgToJS.Types
import GHC.StgToJS.Monad
import GHC.StgToJS.Literal
import GHC.StgToJS.CoreUtils
import GHC.StgToJS.Profiling
import GHC.StgToJS.Ids

import GHC.Builtin.Types
import GHC.Stg.Syntax
import GHC.Core.DataCon

import GHC.Types.CostCentre
import GHC.Types.Unique.FM
import GHC.Types.Id

import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import qualified Control.Monad.Trans.State.Strict as State

{-
Note [ Unboxable Literals Optimization ]
~~~~~~~~~~~~~~~~~~

Boxable types in the JS backend are represented as heap objects. See Note
[StgToJS design] in GHC.StgToJS.hs for more details. Some types, such as Int8
do not benefit from not being wrapped in an object in the JS runtime. This optimization
detects such types and changes the code generator to generate a more efficient
representation. The change is minor and saves one level on indirection. Instead
of generating a wrapper object with a field for the value's payload, such as:

// a JS object for an Int8
var anInt8 = { d1 = <Int8# payload>
             , f  : entry function which would scrutinize the payload
             }

we instead generate:

// notice, no wrapper object. This representation is essentially an Int8# in the JS backend
var anInt8 = <Int8# payload>

This optimization fires when the follow invariants hold:
  1. The value in question has a Type which has a single data constructor
  2. The data constructor holds a single field that is monomorphic
  3. The value in question is distinguishable from a THUNK using the JavaScript typeof operator.

From the haskell perspective this means that:
  1. An Int8# is always a JavaScript 'number', never a JavaScript object.
  2. An Int8 is either a JavaScript 'number' _or_ a JavaScript object depending on
     its use case and this optimization.

How is this sound?
~~~~~~~~~~~~~~~~~~

Normally this optimization would violate the guarantees of call-by-need, however
we are able to statically detect whether the type in question will be a THUNK or
not during code gen because the JS backend is consuming STG and we can check
during runtime with the typeof operator. Similarly we can check at runtime using
JavaScript's introspection operator `typeof`. Thus, when we know the value in
question will not be a THUNK we can safely elide the wrapping object, which
unboxes the value in the JS runtime. For example, an Int8 contains an Int8#
which has the JavaScript type 'number'. A THUNK of type Int8 would have a
JavaScript type 'object', so using 'typeof' allows us to check if we have
something that is definitely evaluated (i.e., a 'number') or something else. If
it is an 'object' then we may need to enter it to begin its evaluation. Consider
a type which has a 'ThreadId#' field; such as type would not be subject to this
optimization because it has to be represented as a JavaScript 'object' and thus
cannot be unboxed in this way. Another (edge) case is Int64#. Int64# is
similarly not unboxable in this way because Int64# does not fit in one
JavaScript variable and thus requires an 'object' for its representation in the
JavaScript runtime.

-}

-- | Generate JS code for static arguments
genStaticArg :: HasDebugCallStack => StgArg -> G [StaticArg]
genStaticArg a = case a of
  StgLitArg l -> map StaticLitArg <$> genStaticLit l
  StgVarArg i -> do
    unFloat <- State.gets gsUnfloated
    case lookupUFM unFloat i of
      Nothing -> reg
      Just expr -> unfloated expr
     where
       r = uTypeVt . stgArgType $ a
       reg
         | isVoid r            =
             return []
         | i == trueDataConId  =
             return [StaticLitArg (BoolLit True)]
         | i == falseDataConId =
             return [StaticLitArg (BoolLit False)]
         | isMultiVar r        =
             map (\(TxtI t) -> StaticObjArg t) <$> mapM (identForIdN i) [1..varSize r] -- this seems wrong, not an obj?
         | otherwise           = (\(TxtI it) -> [StaticObjArg it]) <$> identForId i

       unfloated :: CgStgExpr -> G [StaticArg]
       unfloated (StgLit l) = map StaticLitArg <$> genStaticLit l
       unfloated (StgConApp dc _n args _)
         | isBoolDataCon dc || isUnboxableCon dc =
             (:[]) . allocUnboxedConStatic dc . concat <$> mapM genStaticArg args -- fixme what is allocunboxedcon?
         | null args = (\(TxtI t) -> [StaticObjArg t]) <$> identForId (dataConWorkId dc)
         | otherwise = do
             as       <- concat <$> mapM genStaticArg args
             (TxtI e) <- identForDataConWorker dc
             return [StaticConArg e as]
       unfloated x = pprPanic "genArg: unexpected unfloated expression" (pprStgExpr panicStgPprOpts x)

-- | Generate JS code for an StgArg
genArg :: HasDebugCallStack => StgArg -> G [JExpr]
genArg a = case a of
  StgLitArg l -> genLit l
  StgVarArg i -> do
    unFloat <- State.gets gsUnfloated
    case lookupUFM unFloat i of
      Just expr -> unfloated expr
      Nothing
       | isVoid r            -> return []
       | i == trueDataConId  -> return [true_]
       | i == falseDataConId -> return [false_]
       | isMultiVar r        -> mapM (varForIdN i) [1..varSize r]
       | otherwise           -> (:[]) <$> varForId i

   where
     -- if our argument is a joinid, it can be an unboxed tuple
     r :: HasDebugCallStack => VarType
     r = uTypeVt . stgArgType $ a

     unfloated :: HasDebugCallStack => CgStgExpr -> G [JExpr]
     unfloated = \case
      StgLit l -> genLit l
      StgConApp dc _n args _
       | isBoolDataCon dc || isUnboxableCon dc
       -> (:[]) . allocUnboxedCon dc . concat <$> mapM genArg args
       | null args -> (:[]) <$> varForId (dataConWorkId dc)
       | otherwise -> do
           as <- concat <$> mapM genArg args
           e  <- varForDataConWorker dc
           inl_alloc <- csInlineAlloc <$> getSettings
           return [allocDynamicE inl_alloc e as Nothing]
      x -> pprPanic "genArg: unexpected unfloated expression" (pprStgExpr panicStgPprOpts x)

-- | Generate a Var as JExpr
genIdArg :: HasDebugCallStack => Id -> G [JExpr]
genIdArg i = genArg (StgVarArg i)

-- | Generate an Id as an Ident
genIdArgI :: HasDebugCallStack => Id -> G [Ident]
genIdArgI i
  | isVoid r     = return []
  | isMultiVar r = mapM (identForIdN i) [1..varSize r]
  | otherwise    = (:[]) <$> identForId i
  where
    r = uTypeVt . idType $ i

-- | Generate IDs for stack arguments. See 'StgToJS.Expr.loadRetArgs' for use case
genIdStackArgI :: HasDebugCallStack => Id -> G [(Ident,StackSlot)]
genIdStackArgI i = zipWith f [1..] <$> genIdArgI i
  where
    f :: Int -> Ident -> (Ident,StackSlot)
    f n ident = (ident, SlotId i n)

-- | Allocate Static Constructors
allocConStatic :: HasDebugCallStack => Ident -> CostCentreStack -> DataCon -> [StgArg] -> G ()
allocConStatic (TxtI to) cc con args = do
  as <- mapM genStaticArg args
  cc' <- costCentreStackLbl cc
  allocConStatic' cc' (concat as)
  where
    -- see Note [ Unboxable Literals Optimization ] for the purpose of these
    -- checks
    allocConStatic' :: HasDebugCallStack => Maybe Ident -> [StaticArg] -> G ()
    allocConStatic' cc' []
      | isBoolDataCon con && dataConTag con == 1 =
           emitStatic to (StaticUnboxed $ StaticUnboxedBool False) cc'
      | isBoolDataCon con && dataConTag con == 2 =
           emitStatic to (StaticUnboxed $ StaticUnboxedBool True) cc'
      | otherwise = do
           (TxtI e) <- identForDataConWorker con
           emitStatic to (StaticData e []) cc'
    allocConStatic' cc' [x]
      | isUnboxableCon con =
        case x of
          StaticLitArg (IntLit i)    ->
            emitStatic to (StaticUnboxed $ StaticUnboxedInt i) cc'
          StaticLitArg (BoolLit b)   ->
            emitStatic to (StaticUnboxed $ StaticUnboxedBool b) cc'
          StaticLitArg (DoubleLit d) ->
            emitStatic to (StaticUnboxed $ StaticUnboxedDouble d) cc'
          _                          ->
            pprPanic "allocConStatic: invalid unboxed literal" (ppr x)
    allocConStatic' cc' xs =
           if con == consDataCon
              then case args of
                (a0:a1:_) -> flip (emitStatic to) cc' =<< allocateStaticList [a0] a1
                _         -> panic "allocConStatic: invalid args for consDataCon"
              else do
                (TxtI e) <- identForDataConWorker con
                emitStatic to (StaticData e xs) cc'

-- | Allocate unboxed constructors
allocUnboxedConStatic :: DataCon -> [StaticArg] -> StaticArg
allocUnboxedConStatic con = \case
  []
    | isBoolDataCon con && dataConTag con == 1
    -> StaticLitArg (BoolLit False)
    | isBoolDataCon con && dataConTag con == 2
    -> StaticLitArg (BoolLit True)
  [a@(StaticLitArg (IntLit _i))]    -> a
  [a@(StaticLitArg (DoubleLit _d))] -> a
  _ -> pprPanic "allocUnboxedConStatic: not an unboxed constructor" (ppr con)


-- | Allocate Static list
allocateStaticList :: [StgArg] -> StgArg -> G StaticVal
allocateStaticList xs a@(StgVarArg i)
  | isDataConId_maybe i == Just nilDataCon = listAlloc xs Nothing
  | otherwise = do
      unFloat <- State.gets gsUnfloated
      case lookupUFM unFloat i of
        Just (StgConApp dc _n [h,t] _)
          | dc == consDataCon -> allocateStaticList (h:xs) t
        _ -> listAlloc xs (Just a)
  where
    listAlloc :: [StgArg] -> Maybe StgArg -> G StaticVal
    listAlloc xs Nothing  = do
      as <- concat . reverse <$> mapM genStaticArg xs
      return (StaticList as Nothing)
    listAlloc xs (Just r) = do
      as <- concat . reverse <$> mapM genStaticArg xs
      r' <- genStaticArg r
      case r' of
        [StaticObjArg ri] -> return (StaticList as (Just ri))
        _                 ->
          pprPanic "allocateStaticList: invalid argument (tail)" (ppr (xs, r))
allocateStaticList _ _ = panic "allocateStaticList: unexpected literal in list"

-- | Generate JS code corresponding to a static arg
jsStaticArg :: StaticArg -> JExpr
jsStaticArg = \case
  StaticLitArg l      -> toJExpr l
  StaticObjArg t      -> ValExpr (JVar (TxtI t))
  StaticConArg c args ->
    allocDynamicE False (ValExpr . JVar . TxtI $ c) (map jsStaticArg args) Nothing

-- | Generate JS code corresponding to a list of static args
jsStaticArgs :: [StaticArg] -> JExpr
jsStaticArgs = ValExpr . JList . map jsStaticArg