FFI.hs

module UHC.Light.Compiler.Core.FFI
( tyNmFFIBoxBasicAnnot
, tyNmGBMayLiveAsTaggedPtr, tyNmGBTagPtrBasicAnnot
, ffiMkArgUnpack
, ffiMkResPack
, ffiEvalAdapt
, ffiCoreEvalAdapt
, ffiCoreMk
, ffeCoreMk
, ffiMbIORes
, ffiIOAdapt
, ffiCoreIOAdapt )
where
import UHC.Light.Compiler.Base.HsName.Builtin
import UHC.Light.Compiler.CodeGen.BuiltinSizeInfo
import UHC.Light.Compiler.Opts
import UHC.Light.Compiler.Base.Target
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Base.TermLike
import qualified Data.Map as Map
import Data.List
import Data.Maybe
import UHC.Light.Compiler.CodeGen.BasicAnnot
import UHC.Light.Compiler.Ty
import UHC.Light.Compiler.Gam.DataGam
import UHC.Light.Compiler.AbstractCore
import UHC.Light.Compiler.Core
import UHC.Light.Compiler.Core.Utils
import qualified UHC.Light.Compiler.Core.SysF.AsTy as SysF
import UHC.Light.Compiler.Foreign.Extract
import UHC.Light.Compiler.Foreign.Boxing
import UHC.Light.Compiler.CodeGen.BuiltinPrims





{-# LINE 39 "src/ehc/Core/FFI.chs" #-}
-- | is ty going to be passed unboxed to ffi, return info about it if so?
tyNmFFIBoxBasicAnnot :: EHCOpts -> HsName -> Maybe BasicAnnot
tyNmFFIBoxBasicAnnot opts
  = const Nothing

{-# LINE 55 "src/ehc/Core/FFI.chs" #-}
-- | is ty living as a tagged pointer?
tyNmGBMayLiveAsTaggedPtr :: EHCOpts -> HsName -> Maybe BuiltinInfo
tyNmGBMayLiveAsTaggedPtr opts
  | otherwise                                = const Nothing

-- | BasicAnnot when unboxing also means living as tagged pointer
tyNmGBTagPtrBasicAnnot :: EHCOpts -> Bool -> HsName -> BasicAnnot -> BasicAnnot
tyNmGBTagPtrBasicAnnot opts box t annot
  = case tyNmGBMayLiveAsTaggedPtr opts t of
      Just x
        | otherwise             -> annot
      Nothing -> annot

{-# LINE 80 "src/ehc/Core/FFI.chs" #-}
-- | make argument, i.e. wrap given argument name in proper introduction with annotation about what it is
ffiMkArgUnpack
  :: EHCOpts
     -> DataGam
     -> (HsName -> BasicAnnot -> HsName -> intro)     -- make intro: node around basic type
     -> (HsName -> HsName -> intro)             -- make intro: enum
     -> (HsName -> HsName -> intro)             -- make intro: var
     -> (HsName -> HsName -> intro)             -- make intro: opaque
     -> (HsName -> HsName -> intro)             -- make intro: pointer
     -> HsName                              -- arg name
     -> Ty                                  -- its type
     -> intro
ffiMkArgUnpack
     opts dataGam
     mkNodeI mkEnumI mkVarI mkOpaqI mkPtrI
     argNm ty
  = mk
  where tyNm  = tyAppFunConNm ty
        mbAnn = tyNmFFIBoxBasicAnnot opts tyNm
        mk | isJust mbAnn                   = mkNodeI tyNm (tyNmGBTagPtrBasicAnnot opts False tyNm (fromJust mbAnn)) argNm
           | tyNmIsFFIEnumable dataGam tyNm = mkEnumI tyNm argNm
           | isJust (recMbRecRow ty)        = mkVarI  tyNm argNm
           | tyNmIsFFIOpaque dataGam tyNm   = mkOpaqI tyNm argNm
           | otherwise                      = mkPtrI  tyNm argNm

{-# LINE 131 "src/ehc/Core/FFI.chs" #-}
-- | make result, i.e. wrap given argument name in proper adaption with annotation about what it is
-- Note: 0-tuple is assumed to be Enumerable (change this here, and in the RTS, if the 0-tuple is to be regarded as a basis for extensible rows)
ffiMkResPack
  :: EHCOpts
     -> DataGam
     -> (BasicAnnot -> HsName -> intro)     -- make intro: node around basic type
     -> (HsName -> HsName -> intro)         -- make intro: enum
     -> (HsName -> intro)                   -- make intro: opaque
     -> (HsName -> HsName -> intro)         -- make intro: pointer
     -> (e -> intro -> e -> e)              -- make bind: let .. in
     -> (Ty -> HsName -> HsName -> e)       -- make expr: node
     -> (Ty -> HsName -> HsName -> e)       -- make expr: enum
     -> (Ty -> HsName -> HsName -> e)       -- make expr: opaq
     -> (Ty -> HsName -> HsName -> e)       -- make expr: ptr
     -> HsName                              -- arg name
     -> Ty                                  -- its type
     -> e                                   -- res value
     -> e
ffiMkResPack
     opts dataGam
     mkNodeI mkEnumI mkOpaqI mkPtrI
     mkBindE
     mkNodeE mkEnumE mkOpaqE mkPtrE
     resNm resTy res
  = mk
  where resTyNm  = tyAppFunConNm resTy
        mbAnn = tyNmFFIBoxBasicAnnot opts resTyNm
        mkE e = e resTy resTyNm resNm
        mk | isJust mbAnn                   	= mkBindE res (mkNodeI (tyNmGBTagPtrBasicAnnot opts True resTyNm (fromJust mbAnn)) resNm) (mkE mkNodeE)
           | tyNmIsFFIEnumable dataGam resTyNm	= mkBindE res (mkEnumI resTyNm                                                     resNm) (mkE mkEnumE)
           | isRec && arity == 0            	= mkBindE res (mkEnumI recNm                                                       resNm) (mkE mkEnumE)
           | isRec                          	= mkBindE res (mkPtrI  recNm                                                       resNm) (mkE mkPtrE )
           | tyNmIsFFIOpaque dataGam resTyNm    = mkBindE res (mkOpaqI                                                             resNm) (mkE mkOpaqE)
           | otherwise                      	= mkBindE res (mkPtrI  resTyNm                                                     resNm) (mkE mkPtrE )
           where isRec = isJust $ recMbRecRow resTy
                 arity = length $ snd $ tyRecExts resTy
                 recNm = builtinRecNm arity

{-# LINE 273 "src/ehc/Core/FFI.chs" #-}
-- | is type an IO type, if so return the IO type argument (result returned by IO)
ffiMbIORes :: EHCOpts -> Ty -> Maybe Ty
ffiMbIORes opts resTy
  = case appMbConApp resTy of
      Just (n,[a]) | ehcOptBuiltin opts ehbnIO == n
        -> Just a
      _ -> Nothing

{-# LINE 287 "src/ehc/Core/FFI.chs" #-}
-- | adapt type etc for IO ffi call
ffiIOAdapt
  :: EHCOpts
     -> (UID -> HsName)				-- make unique name (if needed so)
     -> (HsName -> Ty -> e -> e)              -- handle unit result
     -> (HsName -> Ty -> HsName -> Ty -> e -> e)    -- make tupled result, for state representation
     -> UID
     -> Ty								-- IO result type
     -> ( [Ty]							-- type of additional arguments
        , [HsName]						-- names of additional arguments
        , e -> e						-- wrapping/adaption of result
        )
ffiIOAdapt
     opts
     mkUniqNm
     mkUnitRes
     mkTupledRes
     uniq iores
  = ([tyState],[nmState],wrapRes)
  where tyState = appCon $ ehcOptBuiltin opts ehbnRealWorld
        [nmState,nmRes,nmIgnoreRes] = take 3 (map (mkUniqNm) (iterate uidNext uniq))
        wrapRes = mkTupledRes nmState (appDbg "ffiIOAdapt.mkTupledRes.state") nmRes (appDbg "ffiIOAdapt.mkTupledRes.res") . dealWithUnitRes
                where dealWithUnitRes
                        = case tyMbRecExts iores of
                            Just (_,[]) -> mkUnitRes nmIgnoreRes (appDbg "ffiIOAdapt.mkUnitRes")
                            _           -> id

{-# LINE 338 "src/ehc/Core/FFI.chs" #-}
-- | adapt type etc for IO ffi call, specialized for Core
ffiCoreIOAdapt
  :: EHCOpts
     -> UID
     -> Ty								-- IO result type
     -> ([Ty],[HsName],CExpr -> CExpr)
ffiCoreIOAdapt
     opts
     uniq iores
  = ffiIOAdapt
      opts
      mkHNm
      (\          nmIgnoreRes ty r -> acoreLet1StrictTy nmIgnoreRes (SysF.ty2TyCforFFI opts ty) r $ acoreTup []                               )
      (\nmState _ nmRes       ty r -> acoreLet1StrictTy nmRes       (SysF.ty2TyCforFFI opts ty) r $ acoreTup [acoreVar nmState,acoreVar nmRes])
      uniq iores

{-# LINE 360 "src/ehc/Core/FFI.chs" #-}
-- | evaluate value etc for ffi call
ffiEvalAdapt
  :: ((HsName,Ty,intro,Bool) -> e -> e)		-- construct arg w.r.t. eval need, and bind to intro
     -> ((HsName,Ty,e,Bool) -> e)				-- construct result w.r.t. eval need
     -> [(HsName,Ty,intro,Bool)]				-- arg name + introduction + eval need
     -> (HsName,Ty,e,Bool)						-- result
     -> e
ffiEvalAdapt
     evalBindArg
     evalRes
     args
     res
  = foldr evalBindArg (evalRes res) args

{-# LINE 390 "src/ehc/Core/FFI.chs" #-}
-- | evaluate value etc for ffi call, specialized for Core
ffiCoreEvalAdapt
  :: EHCOpts
     -> [(HsName,Ty,HsName,Bool)]			-- arg name + introduction + eval need
     -> (HsName,Ty,CExpr,Bool)				-- result
     -> CExpr
ffiCoreEvalAdapt opts
  = ffiEvalAdapt
      (\(n,ty,i,ev) e -> (if ev then acoreLet1StrictTy                                              else acoreLet1PlainTy) i (SysF.ty2TyCforFFI opts ty) (acoreVar n) e)
      (\(n,ty,e,ev)   ->  if ev then acoreLet1StrictTy n (SysF.ty2TyCforFFI opts ty) e (acoreVar n) else e               )


{-# LINE 408 "src/ehc/Core/FFI.chs" #-}
-- | Construct Core code for FFI
ffiCoreMk
  :: EHCOpts
     -> ( Ty -> CExpr			-- make FFI call
        )
     -> UID
     -> RCEEnv
     -> ForeignExtraction		-- the ffi info
     -> Ty						-- original type signature of FFI
     -> CExpr
ffiCoreMk
     opts
     (mkFFI)
     uniq rceEnv
     foreignEntInfo
     tyFFI
  = acoreLamTy (zip nmArgL (map (SysF.ty2TyCforFFI opts) argTyL) ++ zip nmArgLExtra (repeat $ acoreTyErr "ffiCoreMk.nmArgLExtra.TBD"))
    $ ffiCoreEvalAdapt opts
        ( zip4 nmArgL argTyL nmArgPatL primArgNeedsEvalL )
        ( nmEvalRes
        , resTyAdapted
        , wrapRes
          $ acoreApp (mkFFI $ argTyL `appArr` resTyAdapted)
          $ map acoreVar nmArgPatL
        , primResNeedsEval
        )
  where (argTyL,resTy) = appUnArr tyFFI
        argLen = length argTyL
        (_,u1,u2) = mkNewLevUID2 uniq
        (nmRes:nmEvalRes:nmArgL) = take (argLen + 2) (map mkHNm (iterate uidNext u1))
        nmArgPatL = map (hsnUniqify HsNameUniqifier_FFIArg) nmArgL
        (resTyAdapted,argTyLExtra,nmArgLExtra,wrapRes)
           =
               case ffiMbIORes opts resTy of
                 Just iores
                   -> (iores,a,n,w)
                   where (a,n,w) = ffiCoreIOAdapt opts u2 iores
                 _ ->
                      (resTy,[],[],id)
        mbPrimNeedEval  =   maybe Nothing lookupPrimNeedsEval $ forextractMbEnt foreignEntInfo
        primArgNeedsEvalL
                        =   take argLen $ maybe (repeat True) (\p -> primArgNeedEval p ++ repeat True) mbPrimNeedEval
        primResNeedsEval
                        =   maybe False primResNeedEval mbPrimNeedEval

{-# LINE 464 "src/ehc/Core/FFI.chs" #-}
-- | Construct Core code for FFE
ffeCoreMk
  :: EHCOpts
     -> UID
     -> RCEEnv
     -> Ty						-- original type signature of FFE
     -> ( CExpr -> CExpr		-- ffe wrapper
        , Ty					-- corresponding type
        )
ffeCoreMk
     opts uniq rceEnv
     tyFFE
  = ( \e ->
          acoreLamTy (zipWith (\a t -> (a, SysF.ty2TyCforFFI opts t)) nmArgL argTyL)
          $ acoreLet1StrictTy nmEvalRes (SysF.ty2TyCforFFI opts resTyAdapted)
              (wrapRes $ acoreApp e $ map acoreVar nmArgL ++ argLExtra)
              (acoreVar nmEvalRes)
	, argTyL `appArr` resTyAdapted
	)
  where (argTyL,resTy) = appUnArr tyFFE
        argLen = length argTyL
        (nmRes:nmEvalRes:nmIOEvalRes:nmArgL) = map mkHNm $ mkNewLevUIDL (argLen+3) uniq
        (resTyAdapted,argLExtra,wrapRes)
           =
               case ffiMbIORes opts resTy of
                 Just iores
                   -> ( iores
                      , [acoreTup []]       -- (), unit, the world
                      , \e -> acoreExprSatSelCaseTy rceEnv (Just (nmIOEvalRes,acoreTyErr "ffeCoreMk.wrapRes")) e CTagRec nmIOEvalRes 1 Nothing
                      )
                 _ ->
                      (resTy,[],id)