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)