FFI.hs

{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}

module GHC.StgToJS.FFI
  ( genPrimCall
  , genForeignCall
  )
where

import GHC.Prelude

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

import GHC.StgToJS.Arg
import GHC.StgToJS.ExprCtx
import GHC.StgToJS.Ids
import GHC.StgToJS.Literal
import GHC.StgToJS.Monad
import GHC.StgToJS.Regs
import GHC.StgToJS.Symbols
import GHC.StgToJS.Types
import GHC.StgToJS.Utils

import GHC.Types.RepType
import GHC.Types.ForeignCall
import GHC.Types.Unique.Map

import GHC.Stg.Syntax

import GHC.Builtin.PrimOps
import GHC.Builtin.Types.Prim

import GHC.Core.Type hiding (typeSize)

import GHC.Utils.Misc
import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr)
import GHC.Data.FastString

import Data.Char
import Data.Monoid
import qualified Data.List as L

genPrimCall :: ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStgStat, ExprResult)
genPrimCall ctx (PrimCall lbl _) args t = do
  j <- parseFFIPattern False False False (unpackFS hdStr ++ unpackFS lbl) t (concatMap typex_expr $ ctxTarget ctx) args
  return (j, ExprInline)

-- | generate the actual call
{-
  parse FFI patterns:
   "&value         -> value
  1. "function"      -> ret = function(...)
  2. "$r = $1.f($2)  -> r1 = a1.f(a2)

  arguments, $1, $2, $3 unary arguments
     $1_1, $1_2, for a binary argument

  return type examples
  1. $r                      unary return
  2. $r1, $r2                binary return
  3. $r1, $r2, $r3_1, $r3_2  unboxed tuple return
 -}
parseFFIPattern :: Bool  -- ^ catch exception and convert them to haskell exceptions
                -> Bool  -- ^ async (only valid with javascript calling conv)
                -> Bool  -- ^ using javascript calling convention
                -> String
                -> Type
                -> [JStgExpr]
                -> [StgArg]
                -> G JStgStat
parseFFIPattern catchExcep async jscc pat t es as
  | catchExcep = do
      c <- parseFFIPatternA async jscc pat t es as
      -- Generate:
      --  try {
      --    `c`;
      --  } catch(except) {
      --    return h$throwJSException(except);
      --  }
      return (TryStat c exceptStr (ReturnStat (ApplExpr hdThrowJSException [except])) mempty)
  | otherwise  = parseFFIPatternA async jscc pat t es as

parseFFIPatternA :: Bool  -- ^ async
                 -> Bool  -- ^ using JavaScript calling conv
                 -> String
                 -> Type
                 -> [JStgExpr]
                 -> [StgArg]
                 -> G JStgStat
-- async calls get an extra callback argument
-- call it with the result
parseFFIPatternA True True pat t es as  = do
  cb <- freshIdent
  x  <- freshIdent
  d  <- freshIdent
  stat <- parseFFIPattern' (Just (toJExpr cb)) True pat t es as
  return $ mconcat
    [ x  ||= (toJExpr (jhFromList [(mv, null_)]))
    , cb ||= ApplExpr hdMkForeignCallback [toJExpr x]
    , stat
    , IfStat (InfixExpr StrictEqOp (toJExpr x .^ mv) null_)
          (mconcat
            [ toJExpr x .^ mv |= UOpExpr NewOp (ApplExpr hdMVar [])
            , sp |= Add sp one_
            , (IdxExpr stack sp) |= hdUnboxFFIResult
            , ReturnStat $ ApplExpr hdTakeMVar [toJExpr x .^ mv]
            ])
          (mconcat
            [ d ||= toJExpr x .^ mv
            , copyResult (toJExpr d)
            ])
    ]
    where nrst = typeSize t
          copyResult d = assignAllEqual es (map (IdxExpr d . toJExpr) [0..nrst-1])
parseFFIPatternA _async javascriptCc pat t es as =
  parseFFIPattern' Nothing javascriptCc pat t es as

-- parseFFIPatternA _ _ _ _ _ _ = error "parseFFIPattern: non-JavaScript pattern must be synchronous"

parseFFIPattern' :: Maybe JStgExpr -- ^ Nothing for sync, Just callback for async
                 -> Bool           -- ^ javascript calling convention used
                 -> String         -- ^ pattern called
                 -> Type           -- ^ return type
                 -> [JStgExpr]     -- ^ expressions to return in (may be more than necessary)
                 -> [StgArg]       -- ^ arguments
                 -> G JStgStat
parseFFIPattern' callback javascriptCc pat t ret args
  | not javascriptCc = mkApply pat
  | otherwise = mkApply pat
  where
    tgt = take (typeSize t) ret
    -- automatic apply, build call and result copy
    mkApply f
      | Just cb <- callback = do
         (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args
         cs <- getSettings
         return $ traceCall cs as <> mconcat stats <> ApplStat f' (concat as++[cb])
      | {-ts@-}
        (t:ts') <- tgt = do
         (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args
         cs <- getSettings
         return $ traceCall cs as
                <> mconcat stats
                <> (t |= ApplExpr f' (concat as) )
                <> copyResult ts'
           -- _ -> error "mkApply: empty list"
      | otherwise = do
         (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args
         cs <- getSettings
         return $ traceCall cs as <> mconcat stats <> ApplStat f' (concat as)
        where f' = toJExpr (global $ mkFastString f)
    copyResult rs = mconcat $ zipWith (\t r -> toJExpr r |= toJExpr t) (enumFrom Ret1) rs

    traceCall cs as
        | csTraceForeign cs = ApplStat hdTraceForeign [toJExpr pat, toJExpr as]
        | otherwise         = mempty

-- generate arg to be passed to FFI call, with marshalling JStgStat to be run
-- before the call
genFFIArg :: Bool -> StgArg -> G (JStgStat, [JStgExpr])
genFFIArg _isJavaScriptCc (StgLitArg l) = (mempty,) <$> genLit l
genFFIArg isJavaScriptCc a@(StgVarArg i)
    | not isJavaScriptCc &&
      (tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon) =
        (\x -> (mempty,[x, zero_])) <$> varForId i
    | isVoid r                  = return (mempty, [])
--    | Just x <- marshalFFIArg a = x
    | isMultiVar r              = (mempty,) <$> mapM (varForIdN i) [1..varSize r]
    | otherwise                 = (\x -> (mempty,[x])) <$> varForId i
   where
     tycon  = tyConAppTyCon (unwrapType arg_ty)
     arg_ty = stgArgType a
     r      = unaryTypeJSRep arg_ty

genForeignCall :: HasDebugCallStack
               => ExprCtx
               -> ForeignCall
               -> Type
               -> [JStgExpr]
               -> [StgArg]
               -> G (JStgStat, ExprResult)
genForeignCall _ctx
               (CCall (CCallSpec (StaticTarget _ tgt Nothing True)
                                   JavaScriptCallConv
                                   PlayRisky))
               _t
               [obj]
               args
  | tgt == hdBuildObjectStr
  , Just pairs <- getObjectKeyValuePairs args = do
      pairs' <- mapM (\(k,v) -> genArg v >>= \vs -> return (k, head vs)) pairs
      return ( (|=) obj (ValExpr (JHash $ listToUniqMap pairs'))
             , ExprInline
             )

genForeignCall ctx (CCall (CCallSpec ccTarget cconv safety)) t tgt args = do
  emitForeign (ctxSrcSpan ctx) lbl safety cconv (map showArgType args) (showType t)
  (,exprResult) <$> parseFFIPattern catchExcep async isJsCc (unpackFS lbl) t tgt' args
  where
    isJsCc = cconv == JavaScriptCallConv

    lbl | (StaticTarget _ clbl _mpkg _isFunPtr) <- ccTarget
            = let clbl'    = unpackFS clbl
                  hDollarS = unpackFS hdStr
              in  if | isJsCc -> clbl
                     | wrapperPrefix `L.isPrefixOf` clbl' ->
                         mkFastString (hDollarS ++ (drop 2 $ dropWhile isDigit $ drop (length wrapperPrefix) clbl'))
                     | otherwise -> mkFastString $ hDollarS ++ clbl'
        | otherwise = hdCallDynamicStr

    exprResult | async     = ExprCont
               | otherwise = ExprInline

    catchExcep = (cconv == JavaScriptCallConv) &&
                 playSafe safety || playInterruptible safety

    async | isJsCc    = playInterruptible safety
          | otherwise = playInterruptible safety || playSafe safety

    tgt'  | async     = take (length tgt) jsRegsFromR1
          | otherwise = tgt

    wrapperPrefix = unpackFS wrapperColonStr

getObjectKeyValuePairs :: [StgArg] -> Maybe [(FastString, StgArg)]
getObjectKeyValuePairs [] = Just []
getObjectKeyValuePairs (k:v:xs)
  | Just t <- argJSStringLitUnfolding k =
      fmap ((t,v):) (getObjectKeyValuePairs xs)
getObjectKeyValuePairs _ = Nothing

argJSStringLitUnfolding :: StgArg -> Maybe FastString
argJSStringLitUnfolding (StgVarArg _v) = Nothing -- fixme
argJSStringLitUnfolding _              = Nothing

showArgType :: StgArg -> FastString
showArgType a = showType (stgArgType a)

showType :: Type -> FastString
showType t
  | Just tc <- tyConAppTyCon_maybe (unwrapType t) =
      mkFastString (renderWithContext defaultSDocContext (ppr tc))
  | otherwise = unknown