module DDC.Core.Tetra.Convert.Exp.PrimCall (convertPrimCall) where import DDC.Core.Tetra.Transform.Curry.Callable import DDC.Core.Tetra.Convert.Exp.Arg import DDC.Core.Tetra.Convert.Exp.Base import DDC.Core.Tetra.Convert.Type import DDC.Core.Tetra.Convert.Error import DDC.Type.Transform.Instantiate import DDC.Core.Exp.Annot import DDC.Core.Check (AnTEC(..)) import qualified Data.Map as Map import qualified DDC.Core.Call as Call import qualified DDC.Core.Tetra.Prim as E import qualified DDC.Core.Salt.Runtime as A import qualified DDC.Core.Salt.Name as A import qualified DDC.Core.Salt.Compounds as A import Data.Maybe -- | Convert a Tetra function call primitive to Salt. convertPrimCall :: ExpContext -- ^ The surrounding expression context. -> Context a -- ^ Types and values in the environment. -> Exp (AnTEC a E.Name) E.Name -- ^ Expression to convert. -> Maybe (ConvertM a (Exp a A.Name)) convertPrimCall _ectx ctx xx = let convertX = contextConvertExp ctx downArgX = convertX ExpArg ctx in case xx of --------------------------------------------------- -- Reify a top-level super. XApp (AnTEC _t _ _ a) xa xb | (xR, [XType _ _, XType _ _, xF]) <- takeXApps1 xa xb , XVar _ (UPrim nR _tPrim) <- xR , E.NameOpFun E.OpFunCReify <- nR -- Given the expression defining the super, retrieve its -- value arity and any extra type arguments we need to apply. , Just (xF_super, tSuper, csCall, atsArg) <- case xF of XVar aF (UName nF) -- This variable was let-bound to the application of a super -- name to some type arguments, like f = g [t1] [t2]. -- The value arity and extra type arguments we need to add are -- are stashed in the ConvertM state monad. -- See [Note: Binding top-level supers] -- -- ISSUE #350: Tetra to Salt conversion of let-bound type -- applications is incomplete. -- -- The following process won't work with code like: -- like f = g1 [t1] [t2] -- g1 = g2 [t3] [t4] [t5] -- as we don't look through the intermediate g1 binding -- to see the other type args. These should really be -- inlined in a pre-process. -- | Just (nSuper, atsArgs) <- Map.lookup nF (contextSuperBinds ctx) -> let uSuper = UName nSuper xF' = XVar aF uSuper -- Lookup the call pattern of the super. -- If this fails then the super name is in-scope, but -- we can't see its definition in this module, or -- salt-level import to get the arity. Just callable = Map.lookup nSuper (contextCallable ctx) tSuper = typeOfCallable callable csSuper = consOfCallable callable in Just (xF', tSuper, csSuper, atsArgs) -- The name is that of an existing top-level super, either -- defined in this module or imported from somewhere else. | otherwise -> let -- Lookup the call pattern of the super. -- If this fails then the super name is in-scope, but -- we can't see its definition in this module, or -- salt-level import to get the arity. Just callable = Map.lookup nF (contextCallable ctx) tSuper = typeOfCallable callable csSuper = consOfCallable callable in Just (xF, tSuper, csSuper, []) _ -> Nothing -> Just $ do -- Apply any outer type arguments to the functional expression. xF_super' <- downArgX xF_super xsArgs' <- fmap catMaybes $ mapM (convertOrDiscardSuperArgX ctx) $ [XType aArg tArg | (aArg, tArg) <- atsArg] let xF' = xApps a xF_super' xsArgs' -- Type of the super with its type args applied. let Just tSuper' = instantiateTs tSuper $ map snd atsArg -- Discharge type abstractions with type args that are applied -- directly to the super. let (csCall', []) = Call.dischargeConsWithElims csCall $ [Call.ElimType a a t | t <- map snd atsArg] let Just (_csType, csValue, csBoxes) = Call.splitStdCallCons csCall -- Get the Sea-level type of the super. -- We need to use the call pattern here to detect the case -- where the super returns a functional value. We can't do -- this directly from the Tetra-level type. tF' <- convertSuperConsT (typeContext ctx) csCall' tSuper' return $ A.xAllocThunk a A.rTop (xConvert a A.tAddr tF' xF') (A.xNat a $ fromIntegral $ length csValue) (A.xNat a $ fromIntegral $ length csBoxes) (A.xNat a 0) -- args (A.xNat a 0) -- runs --------------------------------------------------- -- Curry arguments onto a reified function. -- This works for both the 'curryN#' and 'extendN#' primops, -- as they differ only in the Tetra-level closure type. XApp (AnTEC _t _ _ a) xa xb | (x1, xs) <- takeXApps1 xa xb , XVar _ (UPrim nPrim _tPrim) <- x1 , Just nArgs <- case nPrim of E.NameOpFun (E.OpFunCurry nArgs) -> Just nArgs E.NameOpFun (E.OpFunCCurry nArgs) -> Just nArgs E.NameOpFun (E.OpFunCExtend nArgs) -> Just nArgs _ -> Nothing , tsArg <- [tArg | XType _ tArg <- take nArgs xs] , (xThunk : xsArg) <- drop (nArgs + 1) xs , nArgs == length xsArg -> Just $ do xThunk' <- downArgX xThunk xsArg' <- mapM downArgX xsArg tsArg' <- mapM (convertDataT (typeContext ctx)) tsArg let bObject = BAnon (A.tPtr A.rTop A.tObj) let bArgs = BAnon A.tNat return $ XLet a (LLet bObject (A.xExtendThunk a A.rTop A.rTop xThunk' (A.xNat a $ fromIntegral nArgs))) $ XLet a (LLet bArgs (A.xArgsOfThunk a A.rTop xThunk')) $ xLets a [LLet (BNone A.tVoid) (A.xSetFieldOfThunk a A.rTop -- region containing thunk. tPrime -- region containing new child. (XVar a (UIx 1)) -- new thunk. (XVar a (UIx 0)) -- base index (A.xNat a ix) -- offset (xArg)) | ix <- [0..] | xArg <- xsArg' | tArg <- tsArg' , let tPrime = fromMaybe A.rTop $ takePrimeRegion tArg ] $ XVar a (UIx 1) --------------------------------------------------- -- Apply a thunk. XApp (AnTEC _t _ _ a) xa xb | (x1, xs) <- takeXApps1 xa xb , XVar _ (UPrim nPrim _tPrim) <- x1 , Just nArgs <- case nPrim of E.NameOpFun (E.OpFunApply nArgs) -> Just nArgs E.NameOpFun (E.OpFunCApply nArgs) -> Just nArgs _ -> Nothing , tsArg <- [tArg | XType _ tArg <- take nArgs xs] , xF : xsArgs <- drop (nArgs + 1) xs -> Just $ do -- Functional expression. xF' <- downArgX xF -- Arguments and their ypes. xsArg' <- mapM downArgX xsArgs tsArg' <- mapM (convertDataT (typeContext ctx)) tsArg -- Evaluate a thunk, returning the resulting Addr#, -- then cast it back to a pointer of the appropriate type return $ A.xApplyThunk a nArgs $ [ XType a A.rTop ] ++ [ XType a $ fromMaybe A.rTop $ takePrimeRegion tArg' | tArg' <- tsArg'] ++ [ XType a A.rTop ] ++ [ xF' ] ++ xsArg' --------------------------------------------------- -- This isn't a call primitive. _ -> Nothing