diff --git a/DDC/Core/Tetra.hs b/DDC/Core/Tetra.hs --- a/DDC/Core/Tetra.hs +++ b/DDC/Core/Tetra.hs @@ -17,17 +17,21 @@ , Name (..) , TyConTetra (..) , DaConTetra (..) - , OpStore (..) - , PrimTyCon (..) + , OpFun (..) + , OpVector (..) + , OpError (..) + , PrimTyCon (..), pprPrimTyConStem , PrimArith (..) -- * Name Parsing , readName , readTyConTetra , readDaConTetra - , readOpStore - , readPrimTyCon - , readPrimArith + , readOpFun + , readOpVectorFlag + , readOpErrorFlag + , readPrimTyCon, readPrimTyConStem + , readPrimArithFlag -- * Name Generation , freshT diff --git a/DDC/Core/Tetra/Compounds.hs b/DDC/Core/Tetra/Compounds.hs --- a/DDC/Core/Tetra/Compounds.hs +++ b/DDC/Core/Tetra/Compounds.hs @@ -1,33 +1,98 @@ module DDC.Core.Tetra.Compounds - ( module DDC.Core.Compounds.Annot + ( module DDC.Core.Exp.Annot.Compounds - -- * Types - , tBool - , tNat - , tInt - , tWord + -- * Primitive + , tBool, tNat, tInt, tSize, tWord, tFloat + , tPtr - , tBoxed + -- * Tetra types. + , tTupleN , tUnboxed + , tFunValue, tCloValue + , tTextLit -- * Expressions + , xFunCReify, xFunCCurry, xFunApply, xFunCurry , xCastConvert) where import DDC.Core.Tetra.Prim.TyConTetra import DDC.Core.Tetra.Prim.TyConPrim -import DDC.Core.Tetra.Prim -import DDC.Core.Compounds.Annot -import DDC.Core.Exp +import DDC.Core.Tetra.Prim.OpCast +import DDC.Core.Tetra.Prim.OpFun +import DDC.Core.Tetra.Prim.Base +import DDC.Core.Exp.Annot.Compounds +import DDC.Core.Exp.Annot.Exp +-- | Reify a super or foreign function into a closure. +xFunCReify + :: a + -> Type Name -- ^ Parameter type. + -> Type Name -- ^ Result type. + -> Exp a Name -- ^ Input closure. + -> Exp a Name -- ^ Resulting closure. +xFunCReify a tParam tResult xF + = xApps a + (XVar a (UPrim (NameOpFun OpFunCReify) + (typeOpFun OpFunCReify))) + [XType a tParam, XType a tResult, xF] + + +-- | Construct a closure consisting of a top-level super and some arguments. +xFunCCurry + :: a + -> [Type Name] -- ^ Parameter types. + -> Type Name -- ^ Result type. + -> Exp a Name -- ^ Input closure. + -> Exp a Name -- ^ Resulting closure. + +xFunCCurry a tsParam tResult xF + = xApps a + (XVar a (UPrim (NameOpFun (OpFunCCurry (length tsParam))) + (typeOpFun (OpFunCCurry (length tsParam))))) + ((map (XType a) tsParam) ++ [XType a tResult] ++ [xF]) + + +-- | Construct a closure consisting of a top-level super and some arguments. +xFunCurry + :: a + -> [Type Name] -- ^ Parameter types. + -> Type Name -- ^ Result type. + -> Exp a Name -- ^ Input closure. + -> Exp a Name -- ^ Resulting closure. + +xFunCurry a tsParam tResult xF + = xApps a + (XVar a (UPrim (NameOpFun (OpFunCurry (length tsParam))) + (typeOpFun (OpFunCurry (length tsParam))))) + ((map (XType a) tsParam) ++ [XType a tResult] ++ [xF]) + + + +-- | Apply a closure to more arguments. +xFunApply + :: a + -> [Type Name] -- ^ Argument types. + -> Type Name -- ^ Result type. + -> Exp a Name -- ^ Functional expression. + -> [Exp a Name] -- ^ Argument expressions. + -> Exp a Name + +xFunApply a tsArg tResult xF xsArg + = xApps a + (XVar a (UPrim (NameOpFun (OpFunApply (length xsArg))) + (typeOpFun (OpFunApply (length xsArg))))) + ((map (XType a) tsArg) ++ [XType a tResult] ++ [xF] ++ xsArg) + + xCastConvert :: a -> Type Name -> Type Name -> Exp a Name -> Exp a Name xCastConvert a tTo tFrom x - = xApps a - (XVar a (UPrim (NamePrimCast PrimCastConvert) - (typePrimCast PrimCastConvert))) - [ XType a tTo - , XType a tFrom - , x ] + = xApps a + (XVar a (UPrim (NamePrimCast PrimCastConvert) + (typePrimCast PrimCastConvert))) + [ XType a tTo + , XType a tFrom + , x ] diff --git a/DDC/Core/Tetra/Convert.hs b/DDC/Core/Tetra/Convert.hs --- a/DDC/Core/Tetra/Convert.hs +++ b/DDC/Core/Tetra/Convert.hs @@ -1,29 +1,36 @@ --- | Conversion of Disciple Lite to Disciple Salt. --- + +-- | Conversion of Disciple Core Tetra to Disciple Core Salt. module DDC.Core.Tetra.Convert ( saltOfTetraModule , Error(..)) where +import DDC.Core.Tetra.Transform.Curry.Callable +import DDC.Core.Tetra.Convert.Exp.Lets +import DDC.Core.Tetra.Convert.Exp.Alt +import DDC.Core.Tetra.Convert.Exp.Base import DDC.Core.Tetra.Convert.Exp import DDC.Core.Tetra.Convert.Type -import DDC.Core.Tetra.Convert.Base -import DDC.Core.Salt.Convert (initRuntime) +import DDC.Core.Tetra.Convert.Error +import qualified DDC.Core.Tetra.Convert.Type.Base as T + +import DDC.Core.Salt.Convert (initRuntime) import DDC.Core.Salt.Platform +import DDC.Core.Exp.Annot import DDC.Core.Module -import DDC.Core.Compounds -import DDC.Core.Exp -import DDC.Core.Check (AnTEC(..)) -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 DDC.Core.Call +import DDC.Core.Check (AnTEC(..)) +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 DDC.Type.DataDef -import DDC.Type.Env (KindEnv, TypeEnv) -import qualified DDC.Type.Env as Env +import DDC.Type.Env (KindEnv, TypeEnv) +import qualified DDC.Type.Env as Env -import DDC.Control.Monad.Check (throw, evalCheck) -import qualified Data.Map as Map -import qualified Data.Set as Set +import DDC.Control.Monad.Check (throw, evalCheck) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set --------------------------------------------------------------------------------------------------- @@ -36,7 +43,8 @@ -- have type annotations on every bound variable and constructor, -- be a-normalised, -- have saturated function applications, --- not have over-applied function applications. +-- not have over-applied function applications, +-- have all supers in prenex form, with type parameters before value parameters. -- If not then `Error`. -- -- The output code contains: @@ -51,7 +59,7 @@ -> DataDefs E.Name -- ^ Data type definitions. -> KindEnv E.Name -- ^ Kind environment. -> TypeEnv E.Name -- ^ Type environment. - -> Module (AnTEC a E.Name) E.Name -- ^ Lite module to convert. + -> Module (AnTEC a E.Name) E.Name -- ^ Tetra module to convert. -> Either (Error a) (Module a A.Name) -- ^ Salt module. saltOfTetraModule platform runConfig defs kenv tenv mm @@ -72,58 +80,97 @@ convertM pp runConfig defs kenv tenv mm = do - -- Convert signatures of exported functions. - tsExports' <- mapM (convertExportM defs) $ moduleExportValues mm + -- Data Type definitions -------------------------- + -- All the data type definitions visible in the module. + let defs' = unionDataDefs defs + $ fromListDataDefs + $ moduleImportDataDefs mm ++ moduleDataDefsLocal mm - -- Convert signatures of imported functions. - tsImports' <- mapM (convertImportM defs) $ moduleImportValues mm + let nsForeignBoxedTypes + = [n | (n, ImportTypeBoxed _) <- moduleImportTypes mm ] - -- Convert the body of the module to Salt. + let tctx' = T.Context + { T.contextDataDefs = defs' + , T.contextForeignBoxedTypeCtors + = Set.fromList nsForeignBoxedTypes + , T.contextKindEnv = Env.empty } + + -- Module body ------------------------------------ let ntsImports - = [BName n (typeOfImportSource src) - | (n, src) <- moduleImportValues mm] + = [BName n (typeOfImportValue src) + | (n, src) <- moduleImportValues mm] + let tenv' = Env.extends ntsImports tenv - - let defs' = unionDataDefs defs - $ fromListDataDefs (moduleDataDefsLocal mm) - -- Top-level context for the conversion. - let penv = TopEnv - { topEnvPlatform = pp - , topEnvDataDefs = defs' - , topEnvSupers = moduleTopBinds mm - , topEnvImportValues = Set.fromList $ map fst $ moduleImportValues mm } + -- Get the call patterns of the callable things + -- defined in this module. + callables <- either (throw . ErrorCurry) return + $ takeCallablesOfModule mm - -- Conver the body of the module itself. - x1 <- convertExpX penv kenv tenv' ExpTop - $ moduleBody mm + -- Starting context for the conversion. + let ctx = Context + { contextPlatform = pp + , contextDataDefs = defs' + , contextForeignBoxedTypeCtors = Set.fromList $ nsForeignBoxedTypes + , contextCallable = callables + , contextKindEnv = kenv + , contextTypeEnv = tenv' + , contextSuperBinds = Map.empty + , contextConvertExp = convertExp + , contextConvertLets = convertLets + , contextConvertAlt = convertAlt } - -- Converting the body will also expand out code to construct, - -- the place-holder '()' inside the top-level lets. - -- We don't want that, so just replace that code with a fresh unit. + -- Convert the body of the module itself. + x1 <- convertExp ExpTop ctx + $ moduleBody mm + + -- Running the Tetra -> Salt converted on the module body will also + -- expand out code to construct the place holder expression '()' + -- that is the body of the top-level letrec. We don't want that, + -- so just replace it with a fresh unit. let a = annotOfExp x1 let (lts', _) = splitXLets x1 let x2 = xLets a lts' (xUnit a) + + -- Imports and Exports ---------------------------- + -- Convert signatures of imported functions. + ntsImports' <- mapM (convertNameImportValueM tctx') + $ moduleImportValues mm + + -- Convert signatures of exported functions. + -- Locally defined values can be exported, + -- and imported values can be re-exported. + let ntsImport' = [(n, typeOfImportValue iv) | (n, iv) <- ntsImports'] + let ntsSuper' = [(n, t) | BName n t <- concat $ map snd $ map bindsOfLets lts'] + let ntsAvail = Map.fromList $ ntsSuper' ++ ntsImport' + + ntsExports' <- mapM (convertExportM tctx' ntsAvail) + $ moduleExportValues mm + + -- Build the output module. let mm_salt = ModuleCore - { moduleName = moduleName mm + { moduleName = moduleName mm + , moduleIsHeader = moduleIsHeader mm - -- None of the types imported by Lite modules are relevant + -- None of the types imported by Tetra modules are relevant -- to the Salt language. - , moduleExportTypes = [] - , moduleExportValues = tsExports' + , moduleExportTypes = [] + , moduleExportValues = ntsExports' - , moduleImportTypes = Map.toList $ A.runtimeImportKinds - , moduleImportValues = (Map.toList A.runtimeImportTypes) ++ tsImports' + , moduleImportTypes = Map.toList $ A.runtimeImportKinds + , moduleImportCaps = [] + , moduleImportValues = (Map.toList A.runtimeImportTypes) ++ ntsImports' + , moduleImportDataDefs = [] -- Data constructors and pattern matches should have been - -- flattenedinto primops, so we don't need the data type + -- flattened into primops, so we don't need the data type -- definitions. - , moduleDataDefsLocal = [] + , moduleDataDefsLocal = [] - , moduleBody = x2 } + , moduleBody = x2 } -- If this is the 'Main' module then add code to initialise the -- runtime system. This will fail if given a Main module with no @@ -138,29 +185,46 @@ --------------------------------------------------------------------------------------------------- -- | Convert an export spec. convertExportM - :: DataDefs E.Name - -> (E.Name, ExportSource E.Name) + :: T.Context -- ^ Context of the conversion. + -> Map A.Name (Type A.Name) -- ^ Salt types of top-level values. + -> (E.Name, ExportSource E.Name) -- ^ Name and export def to convert. -> ConvertM a (A.Name, ExportSource A.Name) -convertExportM defs (n, esrc) +convertExportM tctx tsSalt (n, esrc) = do n' <- convertBindNameM n - esrc' <- convertExportSourceM defs esrc + esrc' <- convertExportSourceM tctx tsSalt esrc return (n', esrc') -- Convert an export source. +-- +-- We can't just convert the Tetra type of an exported thing to the +-- corresponding Salt type as the form of the Salt type depends on +-- the arity of the underlying value. Instead, we lookup the Salt type +-- of each export from the list of previously known Salt types. +-- convertExportSourceM - :: DataDefs E.Name - -> ExportSource E.Name + :: T.Context -- ^ Context of the conversion. + -> Map A.Name (Type A.Name) -- ^ Salt types of top-level values. + -> ExportSource E.Name -- ^ Export source to convert. -> ConvertM a (ExportSource A.Name) -convertExportSourceM defs esrc +convertExportSourceM tctx tsSalt esrc = case esrc of ExportSourceLocal n t -> do n' <- convertBindNameM n - t' <- convertRepableT defs Env.empty t - return $ ExportSourceLocal n' t' + case Map.lookup n' tsSalt of + -- We have a Salt type for this exported value. + Just t' -> return $ ExportSourceLocal n' t' + + -- If a type has been foreign imported from Salt land + -- then it won't be in the map, and we can just convert + -- its Tetra type to get the Salt version. + Nothing + -> do t' <- convertCtorT tctx t + return $ ExportSourceLocal n' t' + ExportSourceLocalNoType n -> do n' <- convertBindNameM n return $ ExportSourceLocalNoType n' @@ -168,14 +232,13 @@ --------------------------------------------------------------------------------------------------- -- | Convert an import spec. -convertImportM - :: DataDefs E.Name - -> (E.Name, ImportSource E.Name) - -> ConvertM a (A.Name, ImportSource A.Name) +convertNameImportValueM + :: T.Context -> (E.Name, ImportValue E.Name) + -> ConvertM a (A.Name, ImportValue A.Name) -convertImportM defs (n, isrc) +convertNameImportValueM tctx (n, isrc) = do n' <- convertImportNameM n - isrc' <- convertImportSourceM defs isrc + isrc' <- convertImportValueM tctx isrc return (n', isrc') @@ -190,25 +253,36 @@ _ -> throw $ ErrorInvalidBinder n --- | Convert an import source. -convertImportSourceM - :: DataDefs E.Name - -> ImportSource E.Name - -> ConvertM a (ImportSource A.Name) +-- | Convert an import source to Salt. +convertImportValueM + :: T.Context -> ImportValue E.Name + -> ConvertM a (ImportValue A.Name) -convertImportSourceM defs isrc +convertImportValueM tctx isrc = case isrc of - ImportSourceAbstract t - -> do t' <- convertRepableT defs Env.empty t - return $ ImportSourceAbstract t' - - ImportSourceModule mn n t - -> do n' <- convertBindNameM n - t' <- convertRepableT defs Env.empty t - return $ ImportSourceModule mn n' t' + -- We have no arity information for some reason. + -- Just convert the type assuming it's a standard call. + -- If this is wrong then the Salt type checker will + -- catch the problem. + ImportValueModule mn n t Nothing + -> do let cs = takeCallConsFromType t + n' <- convertBindNameM n + t' <- convertSuperConsT tctx cs t + return $ ImportValueModule mn n' t' Nothing - ImportSourceSea str t - -> do t' <- convertRepableT defs Env.empty t - return $ ImportSourceSea str t' + -- We have arity information for this thing from + -- from the imported interface file. + ImportValueModule mn n t (Just (nType, nValue, nBox)) + -> do let Just cs = takeStdCallConsFromTypeArity t nType nValue nBox + n' <- convertBindNameM n + t' <- convertSuperConsT tctx cs t + return $ ImportValueModule mn n' t' Nothing + -- We convert the types of Sea things directly. + -- We assume that they don't return thunks, + -- so we don't need any extra arity information to produce + -- the Salt level type. + ImportValueSea str t + -> do t' <- convertCtorT tctx t + return $ ImportValueSea str t' diff --git a/DDC/Core/Tetra/Convert/Base.hs b/DDC/Core/Tetra/Convert/Base.hs deleted file mode 100644 --- a/DDC/Core/Tetra/Convert/Base.hs +++ /dev/null @@ -1,87 +0,0 @@ - -module DDC.Core.Tetra.Convert.Base - ( ConvertM - , Error (..)) -where -import DDC.Core.Exp -import DDC.Base.Pretty -import DDC.Core.Check (AnTEC(..)) -import DDC.Core.Tetra.Prim as E -import qualified DDC.Control.Monad.Check as G - - --- | Conversion Monad -type ConvertM a x = G.CheckM () (Error a) x - - --- | Things that can go wrong during the conversion. -data Error a - -- | The 'Main' module has no 'main' function. - = ErrorMainHasNoMain - - -- | Found unexpected AST node, like `LWithRegion`. - | ErrorMalformed String - - -- | The program is definately not well typed. - | ErrorMistyped (Exp (AnTEC a E.Name) E.Name) - - -- | The program wasn't normalised, or we don't support the feature. - | ErrorUnsupported (Exp (AnTEC a E.Name) E.Name) Doc - - -- | The program has bottom (missing) type annotations. - | ErrorBotAnnot - - -- | Found an unexpected type sum. - | ErrorUnexpectedSum - - -- | An invalid name used in a binding position - | ErrorInvalidBinder E.Name - - -- | An invalid name used in a bound position - | ErrorInvalidBound (Bound E.Name) - - -- | An invalid data constructor name. - | ErrorInvalidDaCon (DaCon E.Name) - - -- | An invalid name used for the constructor of an alternative. - | ErrorInvalidAlt - - -instance Show a => Pretty (Error a) where - ppr err - = case err of - ErrorMalformed str - -> vcat [ text "Module is malformed." - , text str ] - - ErrorMistyped xx - -> vcat [ text "Module is mistyped." <> (text $ show xx) ] - - ErrorUnsupported xx doc - -> vcat [ text "Cannot convert expression." - , indent 2 $ doc - , empty - , indent 2 $ text "with:" <+> ppr xx ] - - ErrorBotAnnot - -> vcat [ text "Found bottom type annotation." - , text "Program should be type-checked before conversion." ] - - ErrorUnexpectedSum - -> vcat [ text "Unexpected type sum."] - - ErrorInvalidBinder n - -> vcat [ text "Invalid name used in binder '" <> ppr n <> text "'."] - - ErrorInvalidBound n - -> vcat [ text "Invalid name used in bound occurrence " <> ppr n <> text "."] - - ErrorInvalidDaCon n - -> vcat [ text "Invalid data constructor name " <> ppr n <> text "." ] - - ErrorInvalidAlt - -> vcat [ text "Invalid alternative." ] - - ErrorMainHasNoMain - -> vcat [ text "Main module has no 'main' function." ] - diff --git a/DDC/Core/Tetra/Convert/Boxing.hs b/DDC/Core/Tetra/Convert/Boxing.hs --- a/DDC/Core/Tetra/Convert/Boxing.hs +++ b/DDC/Core/Tetra/Convert/Boxing.hs @@ -17,10 +17,11 @@ ( isSomeRepType , isBoxedRepType , isUnboxedRepType - , isBoxableIndexType - , takeIndexOfBoxedRepType - , makeDataTypeForBoxableIndexType - , makeDataCtorForBoxableIndexType) + , isNumericType + , isVectorType + , isTextLitType + , makeBoxedPrimDataType + , makeBoxedPrimDataCtor) where import DDC.Core.Tetra.Prim import DDC.Core.Tetra.Compounds @@ -47,7 +48,6 @@ -- 1) 'a' -- polymorphic types. -- 2) 'forall ...' -- abstract types. -- 3) 'Unit' -- the unit data type. --- 4) 'B# T' -- boxed numeric types, where T is a boxable type. -- 5) User defined data types. -- isBoxedRepType :: Type Name -> Bool @@ -59,19 +59,21 @@ | TForall{} <- tt = True -- Unit data type. - | Just (TyConSpec TcConUnit, _) <- takeTyConApps tt + | Just (TyConSpec TcConUnit, _) <- takeTyConApps tt = True -- User defined data types. - | Just (TyConBound (UName _) _, _) <- takeTyConApps tt + | Just (TyConBound (UName _) _, _) <- takeTyConApps tt = True -- Boxed numeric types - | Just ( NameTyConTetra TyConTetraB - , [ti]) <- takePrimTyConApps tt - , isBoxableIndexType ti + | isNumericType tt = True + -- The primitive vector type. + | isVectorType tt + = True + | otherwise = False @@ -87,62 +89,59 @@ -- isUnboxedRepType :: Type Name -> Bool isUnboxedRepType tt - -- Unboxed numeric types. | Just ( NameTyConTetra TyConTetraU , [ti]) <- takePrimTyConApps tt - , isBoxableIndexType ti + , isNumericType ti || isTextLitType ti = True | otherwise = False --- | Check if some type is a boxable index type. --- --- These are: --- Nat#, Int#, WordN# and so on. --- --- In the representational view of Core Tetra these are neither boxed or --- unboxed, but can appear in both forms. --- --- We write (B# Nat#) and (U# Nat#) to distinguish between the boxed and --- unboxed versions. --- -isBoxableIndexType :: Type Name -> Bool -isBoxableIndexType tt - | Just (NamePrimTyCon n, []) <- takePrimTyConApps tt - = case n of - PrimTyConBool -> True - PrimTyConNat -> True - PrimTyConInt -> True - PrimTyConWord _ -> True - PrimTyConFloat _ -> True - _ -> False +-- | Check if some type is a numeric or other primtitype. +isNumericType :: Type Name -> Bool +isNumericType tt + | Just (NamePrimTyCon n, []) <- takePrimTyConApps tt + = case n of + PrimTyConBool -> True + PrimTyConNat -> True + PrimTyConInt -> True + PrimTyConSize -> True + PrimTyConWord _ -> True + PrimTyConFloat _ -> True + PrimTyConTextLit -> True + _ -> False - | otherwise - = False + | otherwise = False --- Conversions ---------------------------------------------------------------- --- | Given a boxed representation like '(B# T)', --- where 'T' is a boxable index type, yield the 'T' part, otherwise Nothing. --- -takeIndexOfBoxedRepType :: Type Name -> Maybe (Type Name) -takeIndexOfBoxedRepType tt - | Just ( NameTyConTetra TyConTetraB - , [ti]) <- takePrimTyConApps tt - , isBoxableIndexType ti - = Just ti +-- | Check if some type is the boxed vector type. +isVectorType :: Type Name -> Bool +isVectorType tt + | Just (NameTyConTetra n, _) <- takePrimTyConApps tt + = case n of + TyConTetraVector -> True + _ -> False - | otherwise - = Nothing + | otherwise = False +-- | Check if this is the string type. +isTextLitType :: Type Name -> Bool +isTextLitType tt + | Just (NamePrimTyCon n, []) <- takePrimTyConApps tt + = case n of + PrimTyConTextLit -> True + _ -> False + + | otherwise = False + + -- Punned Defs ---------------------------------------------------------------- -- | Generic data type definition for a primitive numeric type. -makeDataTypeForBoxableIndexType :: Type Name -> Maybe (DataType Name) -makeDataTypeForBoxableIndexType tt - | Just (n@NamePrimTyCon{}, []) <- takePrimTyConApps tt +makeBoxedPrimDataType :: Type Name -> Maybe (DataType Name) +makeBoxedPrimDataType tt + | Just (n@NamePrimTyCon{}, []) <- takePrimTyConApps tt = Just $ DataType { dataTypeName = n , dataTypeParams = [] @@ -154,14 +153,14 @@ -- | Generic data constructor definition for a primtive numeric type. -makeDataCtorForBoxableIndexType :: Type Name -> Maybe (DataCtor Name) -makeDataCtorForBoxableIndexType tt - | Just (n@NamePrimTyCon{}, []) <- takePrimTyConApps tt +makeBoxedPrimDataCtor :: Type Name -> Maybe (DataCtor Name) +makeBoxedPrimDataCtor tt + | Just (n@NamePrimTyCon{}, []) <- takePrimTyConApps tt = Just $ DataCtor { dataCtorName = n , dataCtorTag = 0 , dataCtorFieldTypes = [tUnboxed tt] - , dataCtorResultType = tBoxed tt + , dataCtorResultType = tt , dataCtorTypeName = n , dataCtorTypeParams = [] } diff --git a/DDC/Core/Tetra/Convert/Data.hs b/DDC/Core/Tetra/Convert/Data.hs --- a/DDC/Core/Tetra/Convert/Data.hs +++ b/DDC/Core/Tetra/Convert/Data.hs @@ -3,16 +3,15 @@ ( constructData , destructData) where -import DDC.Core.Tetra.Convert.Base +import DDC.Core.Tetra.Convert.Error import DDC.Core.Tetra.Convert.Layout import DDC.Core.Salt.Platform -import DDC.Core.Transform.LiftX +import DDC.Core.Transform.BoundX import DDC.Core.Exp import DDC.Type.Env import DDC.Type.Compounds import DDC.Type.Predicates import DDC.Type.DataDef -import DDC.Control.Monad.Check (throw) import qualified DDC.Core.Tetra.Prim as E import qualified DDC.Core.Salt.Runtime as A import qualified DDC.Core.Salt.Name as A @@ -52,7 +51,7 @@ rPrime trField xObject' ix (liftX 1 xField)) | ix <- [0..] | xField <- xsFields - | trField <- tsFields ] + | trField <- repeat A.rTop ] return $ XLet a (LLet bObject xAlloc) $ foldr (XLet a) xObject' lsFields @@ -63,12 +62,12 @@ = do -- Allocate the object. let bObject = BAnon (A.tPtr rPrime A.tObj) - let xAlloc = A.xAllocRawSmall a rPrime (dataCtorTag ctorDef) + let xAlloc = A.xAllocSmall a rPrime (dataCtorTag ctorDef) $ A.xNat a size -- Take a pointer to its payload. let bPayload = BAnon (A.tPtr rPrime (A.tWord 8)) - let xPayload = A.xPayloadOfRawSmall a rPrime + let xPayload = A.xPayloadOfSmall a rPrime $ XVar a (UIx 0) -- Get the offset of each field. @@ -78,8 +77,10 @@ let xObject' = XVar a $ UIx 1 let xPayload' = XVar a $ UIx 0 let lsFields = [ LLet (BNone A.tVoid) - (A.xPokeBuffer a rPrime tField xPayload' - offset (liftX 2 xField)) + (A.xPoke a rPrime tField + (A.xCastPtr a A.rTop tField (A.tWord 8) xPayload') + (A.xNat a offset) + (liftX 2 xField)) | tField <- tsFields | offset <- offsets | xField <- xsFields] @@ -123,10 +124,10 @@ $ [ if isBNone bField then Nothing else Just $ LLet bField - (A.xGetFieldOfBoxed a trPrime tField + (A.xGetFieldOfBoxed a trPrime rField (XVar a uScrut) ix) | bField <- bsFields - | tField <- map typeOfBind bsFields + | rField <- repeat A.rTop | ix <- [0..] ] return $ foldr (XLet a) xBody lsFields @@ -136,7 +137,7 @@ = do -- Get the address of the payload. let bPayload = BAnon (A.tPtr trPrime (A.tWord 8)) - let xPayload = A.xPayloadOfRawSmall a trPrime (XVar a uScrut) + let xPayload = A.xPayloadOfSmall a trPrime (XVar a uScrut) -- Bind pattern variables to the fields. let uPayload = UIx 0 @@ -145,8 +146,10 @@ $ [ if isBNone bField then Nothing else Just $ LLet bField - (A.xPeekBuffer a trPrime tField - (XVar a uPayload) offset) + (A.xPeek a trPrime tField + (A.xCastPtr a A.rTop tField (A.tWord 8) + (XVar a uPayload)) + (A.xNat a offset)) | bField <- bsFields | tField <- map typeOfBind bsFields | offset <- offsets ] @@ -155,4 +158,9 @@ $ LLet bPayload xPayload : lsFields | otherwise - = throw ErrorInvalidAlt + = error $ unlines + [ "destructData: don't know how to destruct a " + ++ (show $ dataCtorName ctorDef) + , " heapObject = " ++ (show $ heapObjectOfDataCtor pp ctorDef) + , " fields = " ++ (show $ dataCtorFieldTypes ctorDef) + , " size = " ++ (show $ payloadSizeOfDataCtor pp ctorDef) ] diff --git a/DDC/Core/Tetra/Convert/Error.hs b/DDC/Core/Tetra/Convert/Error.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Error.hs @@ -0,0 +1,115 @@ + +module DDC.Core.Tetra.Convert.Error + ( ConvertM + , Error (..)) +where +import DDC.Core.Exp +import DDC.Base.Pretty +import DDC.Core.Check (AnTEC(..)) +import DDC.Core.Tetra.Prim as E +import qualified DDC.Core.Tetra.Transform.Curry.Error as Curry +import qualified DDC.Control.Monad.Check as G + +-- | Conversion Monad +type ConvertM a x = G.CheckM () (Error a) x + + +-- | Things that can go wrong during the conversion. +data Error a + = ErrorCurry Curry.Error + + -- | The 'Main' module has no 'main' function. + | ErrorMainHasNoMain + + -- | Found unexpected AST node, like `LWithRegion`. + | ErrorMalformed + { errorMessage :: String } + + -- | The program is definately not well typed. + | ErrorMistyped + { errorExp :: Exp (AnTEC a E.Name) E.Name } + + -- | The program wasn't normalised, or we don't support the feature. + | ErrorUnsupported + { errorExp :: Exp (AnTEC a E.Name) E.Name + , errorDor :: Doc } + + -- | The program has bottom (missing) type annotations. + | ErrorBotAnnot + + -- | Found an unexpected type sum. + | ErrorUnexpectedSum + + -- | Found an unbound variable. + | ErrorUnbound + { errorBound :: Bound E.Name } + + -- | An invalid name used in a binding position + | ErrorInvalidBinder + { errorName :: E.Name } + + -- | An invalid name used in a bound position + | ErrorInvalidBound + { errorBound :: Bound E.Name } + + -- | An invalid data constructor name. + | ErrorInvalidDaCon + { errorDaCon :: DaCon E.Name } + + -- | An invalid name used for the constructor of an alternative. + | ErrorInvalidAlt + { errorAlt :: Alt (AnTEC a E.Name) E.Name } + + -- | Something that we can't destruct in a case expression. + | ErrorInvalidScrut + { errorScrut :: Exp (AnTEC a E.Name) E.Name } + +instance Show a => Pretty (Error a) where + ppr err + = case err of + ErrorCurry err' + -> ppr err' + + ErrorMalformed str + -> vcat [ text "Module is malformed." + , text str ] + + ErrorMistyped xx + -> vcat [ text "Module is mistyped." <> (text $ show xx) ] + + ErrorUnsupported xx doc + -> vcat [ text "Cannot convert expression." + , indent 2 $ doc + , empty + , indent 2 $ text "with:" <+> ppr xx ] + + ErrorBotAnnot + -> vcat [ text "Found bottom type annotation." + , text "Program should be type-checked before conversion." ] + + ErrorUnexpectedSum + -> vcat [ text "Unexpected type sum."] + + ErrorUnbound u + -> vcat [ text "Unbound name " <> ppr u <> text "."] + + ErrorInvalidBinder n + -> vcat [ text "Invalid name used in binder '" <> ppr n <> text "'."] + + ErrorInvalidBound n + -> vcat [ text "Invalid name used in bound occurrence " <> ppr n <> text "."] + + ErrorInvalidDaCon n + -> vcat [ text "Invalid data constructor name " <> ppr n <> text "." ] + + ErrorInvalidAlt alt + -> vcat [ text "Invalid alternative." + , indent 2 $ text "with:" <+> ppr alt ] + + ErrorInvalidScrut xx + -> vcat [ text "Invalid scrutinee." + , indent 2 $ text "with:" <+> ppr xx ] + + ErrorMainHasNoMain + -> vcat [ text "Main module has no 'main' function." ] + diff --git a/DDC/Core/Tetra/Convert/Exp.hs b/DDC/Core/Tetra/Convert/Exp.hs --- a/DDC/Core/Tetra/Convert/Exp.hs +++ b/DDC/Core/Tetra/Convert/Exp.hs @@ -1,411 +1,207 @@ -- | Conversion of Disciple Lite to Disciple Salt. module DDC.Core.Tetra.Convert.Exp - ( TopEnv (..) - , ExpContext (..) - , convertExpX) + (convertExp) where +import DDC.Core.Tetra.Transform.Curry.Callable +import DDC.Core.Tetra.Convert.Exp.Arg +import DDC.Core.Tetra.Convert.Exp.Ctor +import DDC.Core.Tetra.Convert.Exp.PrimCall +import DDC.Core.Tetra.Convert.Exp.PrimArith +import DDC.Core.Tetra.Convert.Exp.PrimVector +import DDC.Core.Tetra.Convert.Exp.PrimBoxing +import DDC.Core.Tetra.Convert.Exp.PrimError +import DDC.Core.Tetra.Convert.Exp.Base import DDC.Core.Tetra.Convert.Boxing -import DDC.Core.Tetra.Convert.Data import DDC.Core.Tetra.Convert.Type -import DDC.Core.Tetra.Convert.Base -import DDC.Core.Salt.Platform -import DDC.Core.Transform.LiftX -import DDC.Core.Compounds -import DDC.Core.Predicates -import DDC.Core.Exp -import DDC.Core.Check (AnTEC(..)) -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 DDC.Core.Tetra.Convert.Error +import DDC.Core.Exp.Annot +import DDC.Core.Check (AnTEC(..)) +import qualified DDC.Core.Call as Call +import qualified DDC.Core.Tetra.Prim as E +import qualified DDC.Core.Salt.Compounds as A +import qualified DDC.Core.Salt.Runtime as A +import qualified DDC.Core.Salt.Name as A -import DDC.Type.Universe import DDC.Type.DataDef -import DDC.Type.Env (KindEnv, TypeEnv) -import qualified DDC.Type.Env as Env - +import DDC.Base.Pretty +import Text.Show.Pretty import Control.Monad import Data.Maybe -import DDC.Base.Pretty -import DDC.Control.Monad.Check (throw) -import Data.Set (Set) -import qualified Data.Map as Map -import qualified Data.Set as Set +import DDC.Control.Monad.Check (throw) +import qualified Data.Map as Map --------------------------------------------------------------------------------------------------- --- | Information about the top-level environment. -data TopEnv - = TopEnv - { -- Platform we're converting to. - topEnvPlatform :: Platform - - -- Data type definitions. - , topEnvDataDefs :: DataDefs E.Name - - -- Names of top-level supercombinators that are directly callable. - , topEnvSupers :: Set E.Name - - -- Names of imported values that can be refered to directly. - , topEnvImportValues :: Set E.Name } - - --- | The context we're converting the expression in. --- We keep track of this during conversion to ensure we don't produce --- code outside the Salt language fragment. For example, in Salt a function --- can only be applied to a value variable, type or witness -- and not --- a general expression. -data ExpContext - = ExpTop -- ^ At the top-level of the module. - | ExpFun -- ^ At the top-level of a function. - | ExpBody -- ^ In the body of a function. - | ExpBind -- ^ In the right of a let-binding. - | ExpArg -- ^ In a function argument. - deriving (Show, Eq, Ord) - - -- | Convert the body of a supercombinator to Salt. -convertExpX +convertExp :: Show a - => TopEnv -- ^ Top-level environment. - -> KindEnv E.Name -- ^ Kind environment. - -> TypeEnv E.Name -- ^ Type environment. - -> ExpContext -- ^ What context we're converting in. + => ExpContext -- ^ The surrounding expression context. + -> Context a -- ^ Types and values in the environment. -> Exp (AnTEC a E.Name) E.Name -- ^ Expression to convert. -> ConvertM a (Exp a A.Name) -convertExpX penv kenv tenv ctx xx - = let pp = topEnvPlatform penv - defs = topEnvDataDefs penv - downArgX = convertExpX penv kenv tenv ExpArg - downPrimArgX = convertPrimArgX penv kenv tenv ExpArg - downCtorAppX = convertCtorAppX penv kenv tenv - +convertExp ectx ctx xx + = let defs = contextDataDefs ctx + convertX = contextConvertExp ctx + convertA = contextConvertAlt ctx + convertLts = contextConvertLets ctx + downCtorApp = convertCtorApp ctx in case xx of --------------------------------------------------- XVar _ UIx{} -> throw $ ErrorUnsupported xx - $ vcat [ text "Cannot convert program with anonymous value binders." - , text "The program must be namified before conversion." ] + $ vcat [ text "Cannot convert program with anonymous value binders." + , text "The program must be namified before conversion." ] XVar a u -> do let a' = annotTail a - u' <- convertValueU u + + u' <- convertDataU u + >>= maybe (throw $ ErrorInvalidBound u) return + return $ XVar a' u' + + --------------------------------------------------- + -- Unapplied data constructor. XCon a dc - -> do xx' <- convertCtorAppX penv kenv tenv a dc [] + -> do xx' <- downCtorApp a dc [] return xx' - --------------------------------------------------- - -- Type lambdas can only appear at the top-level of a function. - -- We keep region lambdas but ditch the others. Polymorphic values - -- are represented in generic boxed form, so we never need to - -- build a type abstraction of some other kind. - XLAM a b x - | ExpFun <- ctx - , isRegionKind $ typeOfBind b - -> do let a' = annotTail a - b' <- convertTypeB b - let kenv' = Env.extend b kenv - x' <- convertExpX penv kenv' tenv ctx x - - return $ XLAM a' b' x' - - -- When a function is fully polymorphic in some boxed data type, - -- then the type lambda in Tetra is converted to a region lambda in - -- Salt which binds the region the object is in. - | ExpFun <- ctx - , BName (E.NameVar str) k <- b - , isDataKind k - , str' <- str ++ "$r" - , b' <- BName (A.NameVar str') kRegion - -> do let a' = annotTail a - - let kenv' = Env.extend b kenv - x' <- convertExpX penv kenv' tenv ctx x - - return $ XLAM a' b' x' - - -- Erase effect lambdas. - | ExpFun <- ctx - , isEffectKind $ typeOfBind b - -> do let kenv' = Env.extend b kenv - convertExpX penv kenv' tenv ctx x - - -- Erase higher kinded type lambdas. - | ExpFun <- ctx - , Just _ <- takeKFun $ typeOfBind b - -> do let kenv' = Env.extend b kenv - convertExpX penv kenv' tenv ctx x - - -- A type abstraction that we can't convert to Salt. - | otherwise + --------------------------------------------------- + -- Type abstractions can only appear at the top-level of a function. + XLAM{} -> throw $ ErrorUnsupported xx - $ vcat [ text "Cannot convert type abstraction in this context." - , text "The program must be lambda-lifted before conversion." ] + $ vcat [ text "Cannot convert type abstraction in this context." + , text "The program must be lambda-lifted before conversion." ] --------------------------------------------------- -- Function abstractions can only appear at the top-level of a fucntion. - XLam a b x - | ExpFun <- ctx - -> let tenv' = Env.extend b tenv - in case universeFromType1 kenv (typeOfBind b) of - Just UniverseData - -> liftM3 XLam - (return $ annotTail a) - (convertRepableB defs kenv b) - (convertExpX penv kenv tenv' ctx x) - - Just UniverseWitness - -> liftM3 XLam - (return $ annotTail a) - (convertRepableB defs kenv b) - (convertExpX penv kenv tenv' ctx x) - - _ -> throw $ ErrorMalformed - $ "Invalid universe for XLam binder: " ++ show b - | otherwise + XLam{} -> throw $ ErrorUnsupported xx - $ vcat [ text "Cannot convert function abstraction in this context." - , text "The program must be lambda-lifted before conversion." ] - - - --------------------------------------------------- - -- Wrapping of pure values into boxed values. - -- We fake-up a data-type declaration so we can use the same data layout - -- code as for used-defined types. - XApp a _ _ - | Just ( E.NamePrimCast E.PrimCastConvert - , [XType _ tBIx, XType _ tBx, XCon _ c]) <- takeXPrimApps xx - , isBoxableIndexType tBIx - , isBoxedRepType tBx - , Just dt <- makeDataTypeForBoxableIndexType tBIx - , Just dc <- makeDataCtorForBoxableIndexType tBIx - -> do - let a' = annotTail a - xArg' <- convertLitCtorX a' c - tBIx' <- convertIndexT tBIx - - constructData pp kenv tenv a' - dt dc A.rTop [xArg'] [tBIx'] + $ vcat [ text "Cannot convert function abstraction in this context." + , text "The program must be lambda-lifted before conversion." ] --------------------------------------------------- - -- Unwrapping of boxed values into pure values. - -- We fake-up a data-type declaration so we can use the same data layout - -- code as for used-defined types. - XApp a _ _ - | Just ( E.NamePrimCast E.PrimCastConvert - , [XType _ tBx, XType _ tBIx, xArg]) <- takeXPrimApps xx - , isBoxedRepType tBx - , isBoxableIndexType tBIx - , Just dc <- makeDataCtorForBoxableIndexType tBIx - -> do - let a' = annotTail a - xArg' <- downArgX xArg - tBIx' <- convertIndexT tBIx - tBx' <- convertRepableT defs kenv tBx - - x' <- destructData pp a' dc - (UIx 0) A.rTop - [BAnon tBIx'] (XVar a' (UIx 0)) - - return $ XLet a' (LLet (BAnon tBx') (liftX 1 xArg')) - x' + -- Conversions for primitive operators are defined separately. + _ + | Just n <- takeNamePrimX xx + , Just r <- case n of + E.NamePrimArith{} -> convertPrimArith ectx ctx xx + E.NamePrimCast{} -> convertPrimBoxing ectx ctx xx + E.NameOpError{} -> convertPrimError ectx ctx xx + E.NameOpVector{} -> convertPrimVector ectx ctx xx + E.NameOpFun{} -> convertPrimCall ectx ctx xx + _ -> Nothing + -> r --------------------------------------------------- - -- Boxing of unboxed values. - -- We fake-up a data-type declaration so we can use the same data layout - -- code as for user-defined types. - XApp a _ _ - | Just ( E.NamePrimCast E.PrimCastConvert - , [XType _ tUx, XType _ tBx, xArg]) <- takeXPrimApps xx - , isUnboxedRepType tUx - , isBoxedRepType tBx - , Just tBIx <- takeIndexOfBoxedRepType tBx - , Just dt <- makeDataTypeForBoxableIndexType tBIx - , Just dc <- makeDataCtorForBoxableIndexType tBIx - -> do - let a' = annotTail a - xArg' <- downArgX xArg - tBIx' <- convertIndexT tBIx - - constructData pp kenv tenv a' - dt dc A.rTop [xArg'] [tBIx'] + -- Polymorphic instantiation. + -- A polymorphic function is being applied without any associated type + -- arguments. In the Salt code this is a no-op, so just return the + -- functional value itself. The other cases are handled when converting + -- let expressions. See [Note: Binding top-level supers] + -- + XApp _ xa xb + | (xF, xsArgs) <- takeXApps1 xa xb + , tsArgs <- [t | XType _ t <- xsArgs] + , length xsArgs == length tsArgs + , XVar _ (UName n) <- xF + , not $ Map.member n (contextCallable ctx) + -> convertX ExpBody ctx xF --------------------------------------------------- - -- Unboxing of boxed values. - -- We fake-up a data-type declaration so we can use the same data layout - -- code as for used-defined types. - XApp a _ _ - | Just ( E.NamePrimCast E.PrimCastConvert - , [XType _ tBx, XType _ tUx, xArg]) <- takeXPrimApps xx - , isBoxedRepType tBx - , isUnboxedRepType tUx - , Just tBIx <- takeIndexOfBoxedRepType tBx - , Just dc <- makeDataCtorForBoxableIndexType tBIx - -> do - let a' = annotTail a - xArg' <- downArgX xArg - tBIx' <- convertIndexT tBIx - tBx' <- convertRepableT defs kenv tBx - - x' <- destructData pp a' dc - (UIx 0) A.rTop - [BAnon tBIx'] (XVar a' (UIx 0)) - - return $ XLet a' (LLet (BAnon tBx') (liftX 1 xArg')) - x' - - - --------------------------------------------------- - -- Saturated application of a primitive data constructor, - -- including the Unit data constructor. - -- The types of these are directly attached. + -- Fully applied primitive data constructor. + -- The type of the constructor is attached directly to this node of the AST. + -- The data constructor must be fully applied. Partial applications of data + -- constructors that appear in the source language need to be eta-expanded + -- before Tetra -> Salt conversion. XApp a xa xb | (x1, xsArgs) <- takeXApps1 xa xb , XCon _ dc <- x1 , Just tCon <- takeTypeOfDaCon dc - -> if -- Check that the constructor is saturated. - length xsArgs == arityOfType tCon - then downCtorAppX a dc xsArgs + -> if length xsArgs == arityOfType tCon + then downCtorApp a dc xsArgs else throw $ ErrorUnsupported xx - $ text "Partial application of primitive data constructors is not supported." + $ text "Cannot convert partially applied data constructor." + --------------------------------------------------- -- Fully applied user-defined data constructor application. - -- The types of these are in the defs list. + -- The type of the constructor is retrieved in the data defs list. + -- The data constructor must be fully applied. Partial applications of data + -- constructors that appear in the source language need to be eta-expanded + -- before Tetra -> Salt conversion. XApp a xa xb | (x1, xsArgs ) <- takeXApps1 xa xb , XCon _ dc@(DaConBound n) <- x1 , Just dataCtor <- Map.lookup n (dataDefsCtors defs) - -> if -- Check that the constructor is saturated. - length xsArgs + -> if length xsArgs == length (dataCtorTypeParams dataCtor) + length (dataCtorFieldTypes dataCtor) - then downCtorAppX a dc xsArgs + then downCtorApp a dc xsArgs else throw $ ErrorUnsupported xx - $ text "Partial application of user-defined data constructors is not supported." - - - --------------------------------------------------- - -- Saturated application of a primitive operator. - XApp a xa xb - | (x1, xsArgs) <- takeXApps1 xa xb - , XVar _ (UPrim nPrim tPrim) <- x1 - - -- All the value arguments have representatable types. - , all isSomeRepType - $ map (annotType . annotOfExp) - $ filter (not . isXType) xsArgs - - -- The result is representable. - , isSomeRepType (annotType a) - - -> if -- Check that the primop is saturated. - length xsArgs == arityOfType tPrim - then do - x1' <- downArgX x1 - xsArgs' <- mapM downPrimArgX xsArgs - - case nPrim of - -- The Tetra type of these is also parameterised by the type of the - -- boolean result, so that we can choose between value type and unboxed - -- versions. In the Salt version we only need the first type parameter. - E.NamePrimArith o - | elem o [ E.PrimArithEq, E.PrimArithNeq - , E.PrimArithGt, E.PrimArithLt - , E.PrimArithLe, E.PrimArithGe ] - , [t1, _t2, z1, z2] <- xsArgs' - -> return $ xApps (annotTail a) x1' [t1, z1, z2] - - _ -> return $ xApps (annotTail a) x1' xsArgs' - - else throw $ ErrorUnsupported xx - $ text "Partial application of primitive operators is not supported." + $ text "Cannot convert partially applied data constructor." --------------------------------------------------- -- Saturated application of a top-level supercombinator or imported function. - -- This does not cover application of primops, the above case should - -- fire for these. + -- This does not cover application of primops, those are handled by one + -- of the above cases. + -- XApp (AnTEC _t _ _ a') xa xb | (x1, xsArgs) <- takeXApps1 xa xb -- The thing being applied is a named function that is defined -- at top-level, or imported directly. - , XVar _ (UName n) <- x1 - , Set.member n (topEnvSupers penv) - || Set.member n (topEnvImportValues penv) - - -- The function is saturated. - , length xsArgs == arityOfType (annotType $ annotOfExp x1) - - -> do -- Convert the functional part. - x1' <- downArgX x1 + , XVar _ (UName nF) <- x1 + , Map.member nF (contextCallable ctx) + -> convertExpSuperCall xx ectx ctx False a' nF xsArgs - -- Convert the arguments. - -- Effect type and witness arguments are discarded here. - xsArgs' <- liftM catMaybes - $ mapM (convertOrDiscardSuperArgX penv kenv tenv) xsArgs - - return $ xApps a' x1' xsArgs' + | otherwise + -> throw $ ErrorUnsupported xx + $ vcat [ text "Cannot convert application." + , text "fun: " <> ppr xa + , text "args: " <> ppr xb ] --------------------------------------------------- - -- Application of some function that is not a top-level supercombinator - -- or imported function. - XApp _ xa xb - | (x1, _xsArgs) <- takeXApps1 xa xb - - -- The thing being applied is a named function but is not defined - -- at top level, or imported directly. - , XVar _ (UName n) <- x1 - , not $ Set.member n (topEnvSupers penv) - , not $ Set.member n (topEnvImportValues penv) - -> throw $ ErrorUnsupported xx - $ text "Higher order functions are not yet supported." - - - --------------------------------------------------- -- let-expressions. XLet a lts x2 - | ctx <= ExpBind + | ectx <= ExpBind -> do -- Convert the bindings. - lts' <- convertLetsX penv kenv tenv lts + (mlts', ctx') <- convertLts ctx lts -- Convert the body of the expression. - let (bs1, bs0) = bindsOfLets lts - let kenv' = Env.extends bs1 kenv - let tenv' = Env.extends bs0 tenv - x2' <- convertExpX penv kenv' tenv' ExpBody x2 + x2' <- convertX ExpBody ctx' x2 - return $ XLet (annotTail a) lts' x2' + case mlts' of + Nothing -> return $ x2' + Just lts' -> return $ XLet (annotTail a) lts' x2' XLet{} -> throw $ ErrorUnsupported xx - $ vcat [ text "Cannot convert a let-expression in this context." - , text "The program must be a-normalized before conversion." ] + $ vcat [ text "Cannot convert a let-expression in this context." + , text "The program must be a-normalized before conversion." ] --------------------------------------------------- -- Match against literal unboxed values. -- The branch is against the literal value itself. XCase (AnTEC _ _ _ a') xScrut@(XVar (AnTEC tScrut _ _ _) uScrut) alts - | TCon (TyConBound (UPrim nType _) _) <- tScrut - , E.NamePrimTyCon _ <- nType + | isUnboxedRepType tScrut -> do -- Convert the scrutinee. - xScrut' <- convertExpX penv kenv tenv ExpArg xScrut + xScrut' <- convertX ExpArg ctx xScrut -- Convert the alternatives. - alts' <- mapM (convertAlt penv kenv tenv (min ctx ExpBody) - a' uScrut tScrut) + alts' <- mapM (convertA a' uScrut tScrut + (min ectx ExpBody) ctx) alts return $ XCase a' xScrut' alts' @@ -419,16 +215,16 @@ , isSomeRepType tScrut -> do -- Convert scrutinee, and determine its prime region. - x' <- convertExpX penv kenv tenv ExpArg xScrut - tX' <- convertRepableT defs kenv tX + x' <- convertX ExpArg ctx xScrut + tX' <- convertDataT (typeContext ctx) tX - tScrut' <- convertRepableT defs kenv tScrut + tScrut' <- convertDataT (typeContext ctx) tScrut let tPrime = fromMaybe A.rTop $ takePrimeRegion tScrut' -- Convert alternatives. - alts' <- mapM (convertAlt penv kenv tenv (min ctx ExpBody) - a' uScrut tScrut) + alts' <- mapM (convertA a' uScrut tScrut + (min ectx ExpBody) ctx) alts -- If the Tetra program does not have a default alternative @@ -456,14 +252,36 @@ -- expressions need to be eliminated before conversion. XCase{} -> throw $ ErrorUnsupported xx - $ text "Unsupported form of case expression" + $ text "Unsupported case expression form." + --------------------------------------------------- - -- Casts. + -- Type casts + -- Run an application of a top-level super. + XCast _ CastRun (XApp (AnTEC _t _ _ a') xa xb) + | (x1, xsArgs) <- takeXApps1 xa xb + + -- The thing being applied is a named function that is defined + -- at top-level, or imported directly. + , XVar _ (UName nSuper) <- x1 + , Map.member nSuper (contextCallable ctx) + -> convertExpSuperCall xx ectx ctx True a' nSuper xsArgs + + -- Run a suspended computation. + -- This isn't a super call, so the argument itself will be + -- represented as a thunk. + XCast (AnTEC _ _ _ a') CastRun xArg + -> do + xArg' <- convertX ExpArg ctx xArg + return $ A.xRunThunk a' A.rTop A.rTop xArg' + + + -- Some cast that has no operational behaviour. XCast _ _ x - -> convertExpX penv kenv tenv (min ctx ExpBody) x + -> convertX (min ectx ExpBody) ctx x + --------------------------------------------------- -- We shouldn't find any naked types. -- These are handled above in the XApp case. XType{} @@ -474,297 +292,81 @@ XWitness{} -> throw $ ErrorMalformed "Found a naked witness." - -- Expression can't be converted. - _ -> throw $ ErrorUnsupported xx - $ text "Unrecognised expression form." - --------------------------------------------------------------------------------------------------- --- | Convert a let-binding to Salt. -convertLetsX +convertExpSuperCall :: Show a - => TopEnv -- ^ Top-level environment. - -> KindEnv E.Name -- ^ Kind environment. - -> TypeEnv E.Name -- ^ Type environment. - -> Lets (AnTEC a E.Name) E.Name -- ^ Expression to convert. - -> ConvertM a (Lets a A.Name) - -convertLetsX penv kenv tenv lts - = let defs = topEnvDataDefs penv - in case lts of - LRec bxs - -> do let tenv' = Env.extends (map fst bxs) tenv - let (bs, xs) = unzip bxs - bs' <- mapM (convertValueB defs kenv) bs - xs' <- mapM (convertExpX penv kenv tenv' ExpFun) xs - return $ LRec $ zip bs' xs' - - LLet b x1 - -> do let tenv' = Env.extend b tenv - b' <- convertValueB defs kenv b - x1' <- convertExpX penv kenv tenv' ExpBind x1 - return $ LLet b' x1' - - LPrivate b mt bs - -> do b' <- mapM convertTypeB b - let kenv' = Env.extends b kenv - - bs' <- mapM (convertCapabilityB kenv') bs - mt' <- case mt of - Nothing -> return Nothing - Just t -> liftM Just $ convertRegionT kenv t - return $ LPrivate b' mt' bs' - - LWithRegion{} - -> throw $ ErrorMalformed "Cannot convert LWithRegion construct." - - ---------------------------------------------------------------------------------------------------- --- | Convert a Lite alternative to Salt. -convertAlt - :: Show a - => TopEnv -- ^ Top-level environment. - -> KindEnv E.Name -- ^ Kind environment. - -> TypeEnv E.Name -- ^ Type environment. - -> ExpContext -- ^ Context of enclosing case-expression. - -> a -- ^ Annotation from case expression. - -> Bound E.Name -- ^ Bound of scrutinee. - -> Type E.Name -- ^ Type of scrutinee - -> Alt (AnTEC a E.Name) E.Name -- ^ Alternative to convert. - -> ConvertM a (Alt a A.Name) - -convertAlt penv kenv tenv ctx a uScrut tScrut alt - = let pp = topEnvPlatform penv - defs = topEnvDataDefs penv - in case alt of - -- Match against the unit constructor. - -- This is baked into the langauge and doesn't have a real name, - -- so we need to handle it separately. - AAlt (PData dc []) x - | DaConUnit <- dc - -> do xBody <- convertExpX penv kenv tenv ctx x - let dcTag = DaConPrim (A.NameLitTag 0) A.tTag - return $ AAlt (PData dcTag []) xBody - - -- Match against literal unboxed values. - AAlt (PData dc []) x - | Just nCtor <- takeNameOfDaCon dc - , E.isNameLit nCtor - -> do dc' <- convertDaCon defs kenv dc - xBody1 <- convertExpX penv kenv tenv ctx x - return $ AAlt (PData dc' []) xBody1 - - -- Match against user-defined algebraic data. - AAlt (PData dc bsFields) x - | Just nCtor <- takeNameOfDaCon dc - , Just ctorDef <- Map.lookup nCtor $ dataDefsCtors defs - -> do - -- Convert the scrutinee. - uScrut' <- convertValueU uScrut - - -- Get the tag of this alternative. - let iTag = fromIntegral $ dataCtorTag ctorDef - let dcTag = DaConPrim (A.NameLitTag iTag) A.tTag - - -- Get the address of the payload. - bsFields' <- mapM (convertRepableB defs kenv) bsFields - - -- Convert the right of the alternative, - -- with all all the pattern variables in scope. - let tenv' = Env.extends bsFields tenv - xBody1 <- convertExpX penv kenv tenv' ctx x - - -- Determine the prime region of the scrutinee. - -- This is the region the associated Salt object is in. - trPrime <- saltPrimeRegionOfDataType kenv tScrut - - -- Wrap the body expression with let-bindings that bind - -- each of the fields of the data constructor. - xBody2 <- destructData pp a ctorDef uScrut' trPrime - bsFields' xBody1 - - return $ AAlt (PData dcTag []) xBody2 - - -- Default alternative. - AAlt PDefault x - -> do x' <- convertExpX penv kenv tenv ctx x - return $ AAlt PDefault x' - - AAlt{} - -> throw ErrorInvalidAlt - - ---------------------------------------------------------------------------------------------------- --- | Convert a data constructor application to Salt. -convertCtorAppX - :: Show a - => TopEnv -- ^ Top-level environment, - -> KindEnv E.Name -- ^ Kind environment. - -> TypeEnv E.Name -- ^ Type environment. - -> AnTEC a E.Name -- ^ Annot from deconstructed app node. - -> DaCon E.Name -- ^ Data constructor being applied. - -> [Exp (AnTEC a E.Name) E.Name] -- ^ Data constructor arguments. + => Exp (AnTEC a E.Name) E.Name + -> ExpContext -- ^ The surrounding expression context. + -> Context a -- ^ Types and values in the environment. + -> Bool -- ^ Whether this is call is directly inside a 'run' + -> a -- ^ Annotation from application node. + -> E.Name -- ^ Name of super. + -> [Exp (AnTEC a E.Name) E.Name] -- ^ Arguments to super. -> ConvertM a (Exp a A.Name) -convertCtorAppX penv kenv tenv (AnTEC tResult _ _ a) dc xsArgsAll - -- Handle the unit constructor. - | DaConUnit <- dc - = do return $ A.xAllocBoxed a A.rTop 0 (A.xNat a 0) - - -- Construct algebraic data. - | Just nCtor <- takeNameOfDaCon dc - , Just ctorDef <- Map.lookup nCtor $ dataDefsCtors (topEnvDataDefs penv) - , Just dataDef <- Map.lookup (dataCtorTypeName ctorDef) - $ dataDefsTypes (topEnvDataDefs penv) - = do - let pp = topEnvPlatform penv - - -- Get the prime region variable. - -- The prime region holds the outermost constructor of the object. - trPrime <- saltPrimeRegionOfDataType kenv tResult - - -- Split the constructor arguments into the type and value args. - let xsArgsTypes = [x | x@XType{} <- xsArgsAll] - let xsArgsValues = drop (length xsArgsTypes) xsArgsAll - - -- Convert all the constructor arguments to Salt. - xsArgsValues' <- mapM (convertExpX penv kenv tenv ExpArg) - $ xsArgsValues - - -- Determine the Salt type for each of the arguments. - tsArgsValues' <- mapM (saltDataTypeOfArgType kenv) - $ map (annotType . annotOfExp) xsArgsValues - - constructData pp kenv tenv a - dataDef ctorDef - trPrime xsArgsValues' tsArgsValues' - - --- If this fails then the provided constructor args list is probably malformed. --- This shouldn't happen in type-checked code. -convertCtorAppX _ _ _ _ _ _ - = throw $ ErrorMalformed "Invalid constructor application." - - ---------------------------------------------------------------------------------------------------- --- | Given an argument to a function or data constructor, either convert --- it to the corresponding argument to use in the Salt program, or --- return Nothing which indicates it should be discarded. -convertOrDiscardSuperArgX - :: Show a - => TopEnv -- ^ Top-level environment. - -> KindEnv E.Name -- ^ Kind environment. - -> TypeEnv E.Name -- ^ Type environment. - -> Exp (AnTEC a E.Name) E.Name -- ^ Expression to convert. - -> ConvertM a (Maybe (Exp a A.Name)) - -convertOrDiscardSuperArgX penv kenv tenv xx +convertExpSuperCall xx _ectx ctx isRun a nFun xsArgs - -- Region type arguments get passed through directly. - | XType a t <- xx - , isRegionKind (annotType a) - = do t' <- convertRegionT kenv t - return $ Just (XType (annotTail a) t') + -- EITHER Saturated super call where call site is running the result, + -- and the super itself directly produces a boxed computation. + -- OR Saturated super call where the call site is NOT running the result, + -- and the super itself does NOT directly produce a boxed computation. + -- + -- In both these cases we can just call the Salt-level super directly. + -- + | Just (arityVal, boxings) + <- case Map.lookup nFun (contextCallable ctx) of + Just (Callable _src _ty cs) + | Just (_, csVal, csBox) <- Call.splitStdCallCons cs + -> Just (length csVal, length csBox) - -- If we have a data type argument where the type is boxed, then we pass - -- the region the corresponding Salt object is in. - | XType a t <- xx - , isDataKind (annotType a) - , isBoxedRepType t - = do t' <- saltPrimeRegionOfDataType kenv t - return $ Just (XType (annotTail a) t') + _ -> Nothing - -- Some type that we don't know how to convert to Salt. - -- We don't handle type args with higher kinds. - -- See [Note: Salt conversion for higher kinded type arguments] - | XType{} <- xx - = throw $ ErrorUnsupported xx - $ vcat [ text "Unsupported type argument to function or constructor." - , text "In particular, we don't yet handle higher kinded type arguments." - , empty - , text "See [Note: Salt conversion for higher kinded type arguments] in" - , text "the implementation of the Tetra to Salt conversion." ] + -- super call is saturated. + , xsArgsVal <- filter (not . isXType) xsArgs + , length xsArgsVal == arityVal - -- Witness arguments are discarded. - | XWitness{} <- xx - = return $ Nothing + -- no run/box to get in the way. + , ( isRun && boxings == 1) + || ((not isRun) && boxings == 0) + = do + -- Convert the functional part. + uF <- convertDataU (UName nFun) + >>= maybe (throw $ ErrorInvalidBound (UName nFun)) return - -- Expression arguments. - | otherwise - = do x' <- convertExpX penv kenv tenv ExpArg xx - return $ Just x' + -- Convert the arguments. + -- Effect type and witness arguments are discarded here. + xsArgs' <- liftM catMaybes + $ mapM (convertOrDiscardSuperArgX ctx) xsArgs + + return $ xApps a (XVar a uF) xsArgs' --- | Although we ditch type arguments when applied to general functions, --- we need to convert the ones applied directly to primops, --- as the primops are specified polytypically. -convertPrimArgX - :: Show a - => TopEnv -- ^ Top-level environment. - -> KindEnv E.Name -- ^ Kind environment. - -> TypeEnv E.Name -- ^ Type environment. - -> ExpContext -- ^ What context we're converting in. - -> Exp (AnTEC a E.Name) E.Name -- ^ Expression to convert. - -> ConvertM a (Exp a A.Name) - -convertPrimArgX penv kenv tenv ctx xx - = let defs = topEnvDataDefs penv - in case xx of - XType a t - -> do t' <- convertRepableT defs kenv t - return $ XType (annotTail a) t' - - XWitness{} - -> throw $ ErrorUnsupported xx - $ text "Witness expressions are not part of the Tetra language." - - _ -> convertExpX penv kenv tenv ctx xx + -- We can't make the call, + -- so emit some debugging info. + | otherwise + = throw $ ErrorUnsupported xx + $ vcat [ text "Cannot convert application." + , text "xx: " <> ppr xx + , text "fun: " <> ppr nFun + , text "args: " <> ppr xsArgs + , text "callables: " <> text (ppShow $ contextCallable ctx) + ] --------------------------------------------------------------------------------------------------- --- | Convert a literal constructor to Salt. --- These are values that have boxable index types like Bool# and Nat#. -convertLitCtorX - :: a -- ^ Annot from deconstructed XCon node. - -> DaCon E.Name -- ^ Data constructor of literal. - -> ConvertM a (Exp a A.Name) - -convertLitCtorX a dc - | Just n <- takeNameOfDaCon dc - = case n of - E.NameLitBool b -> return $ A.xBool a b - E.NameLitNat i -> return $ A.xNat a i - E.NameLitInt i -> return $ A.xInt a i - E.NameLitWord i bits -> return $ A.xWord a i bits - _ -> throw $ ErrorMalformed "Invalid literal." +-- | If this is an application of a primitive or +-- the result of running one then take its name. +takeNamePrimX :: Exp a E.Name -> Maybe E.Name +takeNamePrimX xx + = case xx of + XApp{} + -> case takeXPrimApps xx of + Just (n, _) -> Just n + Nothing -> Nothing - | otherwise - = throw $ ErrorMalformed "Invalid literal." + XCast _ CastRun xx'@XApp{} + -> takeNamePrimX xx' + _ -> Nothing ---------------------------------------------------------------------------------------------------- --- [Note: Salt conversion for higher kinded type arguments] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Converting functions that use higher kinded types to Salt is problematic --- because we can't directly see what region is being used to represent --- each object. --- --- data List (r : Region) (a : Data) where ... --- --- idf [c : Data ~> Data] [a : Data] (x : c a) : Nat# ... --- --- f = ... idf [List r1] [Nat] (...) --- --- At the call-site, the value argument to idf is in region r1, but that --- information is not available when converting the body of 'idf'. --- When converting the body of 'idf' we can't assume the value bound to --- 'x' is in rTop. --- --- We need some simple subtyping in region types, to have a DontKnow region --- that can be used to indicate that the region an object is in is unknown. --- --- For now we just don't convert functions using higher kinded types, --- and leave this to future work. Higher kinding isn't particularly --- useful without a type clasing system with constructor classes, --- so we'll fix it later. --- diff --git a/DDC/Core/Tetra/Convert/Exp/Alt.hs b/DDC/Core/Tetra/Convert/Exp/Alt.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Exp/Alt.hs @@ -0,0 +1,96 @@ + +module DDC.Core.Tetra.Convert.Exp.Alt + (convertAlt) +where +import DDC.Core.Tetra.Convert.Exp.Base +import DDC.Core.Tetra.Convert.Data +import DDC.Core.Tetra.Convert.Type +import DDC.Core.Tetra.Convert.Error +import DDC.Core.Exp.Annot +import DDC.Type.DataDef +import DDC.Core.Check (AnTEC(..)) +import DDC.Control.Monad.Check (throw) +import qualified DDC.Core.Tetra.Prim as E +import qualified DDC.Core.Salt.Name as A +import qualified DDC.Core.Salt.Compounds as A +import qualified Data.Map as Map + + +-- | Convert a Tetra alternative to Salt. +convertAlt + :: Show a + => a -- ^ Annotation from case expression. + -> Bound E.Name -- ^ Bound of scrutinee. + -> Type E.Name -- ^ Type of scrutinee + -> ExpContext -- ^ Context of enclosing case-expression. + -> Context a -- ^ Type context of the conversion. + -> Alt (AnTEC a E.Name) E.Name -- ^ Alternative to convert. + -> ConvertM a (Alt a A.Name) + +convertAlt a uScrut tScrut ectx ctx alt + = let pp = contextPlatform ctx + defs = contextDataDefs ctx + kenv = contextKindEnv ctx + convertX = contextConvertExp ctx + tctx = typeContext ctx + in case alt of + -- Match against the unit constructor. + -- This is baked into the langauge and doesn't have a real name, + -- so we need to handle it separately. + AAlt (PData dc []) x + | DaConUnit <- dc + -> do xBody <- convertX ectx ctx x + let dcTag = DaConPrim (A.NamePrimLit $ A.PrimLitTag 0) A.tTag + return $ AAlt (PData dcTag []) xBody + + -- Match against literal unboxed values. + AAlt (PData dc []) x + | Just nCtor <- takeNameOfDaCon dc + , E.isNameLit nCtor + -> do dc' <- convertDaCon tctx dc + xBody1 <- convertX ectx ctx x + return $ AAlt (PData dc' []) xBody1 + + -- Match against user-defined algebraic data. + AAlt (PData dc bsFields) x + | Just nCtor <- takeNameOfDaCon dc + , Just ctorDef <- Map.lookup nCtor $ dataDefsCtors defs + -> do + -- Convert the scrutinee. + uScrut' <- convertDataU uScrut + >>= maybe (throw $ ErrorInvalidBound uScrut) return + + + -- Get the tag of this alternative. + let iTag = fromIntegral $ dataCtorTag ctorDef + let dcTag = DaConPrim (A.NamePrimLit $ A.PrimLitTag iTag) A.tTag + + -- Get the address of the payload. + bsFields' <- mapM (convertDataB tctx) bsFields + + -- Convert the right of the alternative, + -- with all all the pattern variables in scope. + let ctx' = extendsTypeEnv bsFields ctx + xBody1 <- convertX ectx ctx' x + + -- Determine the prime region of the scrutinee. + -- This is the region the associated Salt object is in. + trPrime <- saltPrimeRegionOfDataType kenv tScrut + + -- Wrap the body expression with let-bindings that bind + -- each of the fields of the data constructor. + xBody2 <- destructData pp a ctorDef uScrut' trPrime + bsFields' xBody1 + + return $ AAlt (PData dcTag []) xBody2 + + -- Default alternative. + AAlt PDefault x + -> do x' <- convertX ectx ctx x + return $ AAlt PDefault x' + + -- Invalid alternative. + -- Maybe we don't have the definition for the data constructor + -- being matched against. + AAlt{} + -> throw $ ErrorInvalidAlt alt diff --git a/DDC/Core/Tetra/Convert/Exp/Arg.hs b/DDC/Core/Tetra/Convert/Exp/Arg.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Exp/Arg.hs @@ -0,0 +1,79 @@ + +module DDC.Core.Tetra.Convert.Exp.Arg + (convertOrDiscardSuperArgX) +where +import DDC.Core.Tetra.Convert.Exp.Base +import DDC.Core.Tetra.Convert.Type +import DDC.Core.Tetra.Convert.Error +import DDC.Core.Exp.Annot +import DDC.Core.Check (AnTEC(..)) +import qualified DDC.Core.Tetra.Prim as E +import qualified DDC.Core.Salt.Name as A +import qualified DDC.Core.Salt.Runtime as A + + +--------------------------------------------------------------------------------------------------- +-- | Given an argument to a function or data constructor, either convert +-- it to the corresponding argument to use in the Salt program, or +-- return Nothing which indicates it should be discarded. +convertOrDiscardSuperArgX + :: Show a + => Context a -- ^ Type context of the conversion. + -> Exp (AnTEC a E.Name) E.Name -- ^ Expression to convert. + -> ConvertM a (Maybe (Exp a A.Name)) + +convertOrDiscardSuperArgX ctx xx + + -- In the salt code everything currently goes into the top-level region. + | XType a _ <- xx + , isRegionKind (annotType a) + = do return $ Just $ XType (annotTail a) A.rTop + + -- If we have a data type argument where the type is boxed, + -- then we pass the region the corresponding Salt object is in. + | XType a t <- xx + , isDataKind (annotType a) + = do let kenv = contextKindEnv ctx + t' <- saltPrimeRegionOfDataType kenv t + return $ Just (XType (annotTail a) t') + + -- Drop other type arguments. + | XType{} <- xx + = return Nothing + + -- Drop witneses. + | XWitness{} <- xx + = return Nothing + + -- Expression arguments. + | otherwise + = do x' <- contextConvertExp ctx ExpArg ctx xx + return $ Just x' + + +--------------------------------------------------------------------------------------------------- +-- [Note: Salt conversion for higher kinded type arguments] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Converting functions that use higher kinded types to Salt is problematic +-- because we can't directly see what region is being used to represent +-- each object. +-- +-- data List (r : Region) (a : Data) where ... +-- +-- idf [c : Data ~> Data] [a : Data] (x : c a) : Nat# ... +-- +-- f = ... idf [List r1] [Nat] (...) +-- +-- At the call-site, the value argument to idf is in region r1, but that +-- information is not available when converting the body of 'idf'. +-- When converting the body of 'idf' we can't assume the value bound to +-- 'x' is in rTop. +-- +-- We need some simple subtyping in region types, to have a DontKnow region +-- that can be used to indicate that the region an object is in is unknown. +-- +-- For now we just don't convert functions using higher kinded types, +-- and leave this to future work. Higher kinding isn't particularly +-- useful without a type clasing system with constructor classes, +-- so we'll fix it later. +-- diff --git a/DDC/Core/Tetra/Convert/Exp/Base.hs b/DDC/Core/Tetra/Convert/Exp/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Exp/Base.hs @@ -0,0 +1,166 @@ + +module DDC.Core.Tetra.Convert.Exp.Base + ( -- * Context + Context (..) + , typeContext + , extendKindEnv, extendsKindEnv + , extendTypeEnv, extendsTypeEnv + + , ExpContext (..) + + -- * Constructors + , xConvert + , xTakePtr + , xMakePtr) +where +import DDC.Core.Tetra.Transform.Curry.Callable +import DDC.Core.Tetra.Convert.Error +import DDC.Core.Salt.Platform +import DDC.Core.Exp.Annot +import DDC.Core.Check (AnTEC(..)) +import DDC.Type.DataDef +import DDC.Type.Env (KindEnv, TypeEnv) +import Data.Set (Set) +import Data.Map (Map) +import qualified DDC.Core.Tetra.Convert.Type.Base as T +import qualified DDC.Core.Tetra.Prim as E +import qualified DDC.Type.Env as Env +import qualified DDC.Core.Salt.Name as A +import qualified DDC.Core.Salt.Env as A + + +--------------------------------------------------------------------------------------------------- +-- | Context of an Exp conversion. +data Context a + = Context + { -- | The platform that we're converting to, + -- this sets the pointer width. + contextPlatform :: Platform + + -- | Data type definitions. + -- These are all the visible data type definitions, from both + -- the current module and imported ones. + , contextDataDefs :: DataDefs E.Name + + -- | Names of foreign boxed data type contructors. + -- These are names like 'Ref' and 'Array' that are defined in the + -- runtime system rather than as an algebraic data type with a + -- Tetra-level data type definition. Although there is no data + -- type definition, we still represent the values of these types + -- in generic boxed form. + , contextForeignBoxedTypeCtors + :: Set E.Name + + -- | Call patterns of things that we can call directly, in the generated code. + -- This is locally defined supers, as well as imported supers and sea functions. + , contextCallable :: Map E.Name Callable + + -- | Current kind environment. + -- This is updated as we decend into the AST during conversion. + , contextKindEnv :: KindEnv E.Name + + -- | Current type environment. + -- This is updated as we decend into the AST during conversion. + , contextTypeEnv :: TypeEnv E.Name + + -- | Re-bindings of top-level supers. + -- This is used to handle let-expressions like 'f = g [t]' where + -- 'g' is a top-level super. See [Note: Binding top-level supers] + -- Maps the left hand variable to the right hand one, eg f -> g, + -- along with its unpacked type arguments. + , contextSuperBinds + :: Map E.Name (E.Name, [(AnTEC a E.Name, Type E.Name)]) + + -- Functions to convert the various parts of the AST. + -- We tie the recursive knot though this `Context` type so that + -- we can split the implementation into separate non-recursive modules. + , contextConvertExp + :: ExpContext -> Context a + -> Exp (AnTEC a E.Name) E.Name + -> ConvertM a (Exp a A.Name) + + , contextConvertLets + :: Context a + -> Lets (AnTEC a E.Name) E.Name + -> ConvertM a (Maybe (Lets a A.Name), Context a) + + , contextConvertAlt + :: a + -> Bound E.Name -> Type E.Name + -> ExpContext -> Context a + -> Alt (AnTEC a E.Name) E.Name + -> ConvertM a (Alt a A.Name) + } + + +-- | Create a type context from an expression context. +typeContext :: Context a -> T.Context +typeContext ctx + = T.Context + { T.contextDataDefs = contextDataDefs ctx + , T.contextForeignBoxedTypeCtors + = contextForeignBoxedTypeCtors ctx + , T.contextKindEnv = contextKindEnv ctx } + + +-- | Extend the kind environment of a context with a new binding. +extendKindEnv :: Bind E.Name -> Context a -> Context a +extendKindEnv b ctx + = ctx { contextKindEnv = Env.extend b (contextKindEnv ctx) } + + +-- | Extend the kind environment of a context with some new bindings. +extendsKindEnv :: [Bind E.Name] -> Context a -> Context a +extendsKindEnv bs ctx + = ctx { contextKindEnv = Env.extends bs (contextKindEnv ctx) } + + +-- | Extend the type environment of a context with a new binding. +extendTypeEnv :: Bind E.Name -> Context a -> Context a +extendTypeEnv b ctx + = ctx { contextTypeEnv = Env.extend b (contextTypeEnv ctx) } + + +-- | Extend the type environment of a context with some new bindings. +extendsTypeEnv :: [Bind E.Name] -> Context a -> Context a +extendsTypeEnv bs ctx + = ctx { contextTypeEnv = Env.extends bs (contextTypeEnv ctx) } + + +--------------------------------------------------------------------------------------------------- +-- | The context we're converting an expression in. +-- We keep track of this during conversion to ensure we don't produce +-- code outside the Salt language fragment. For example, in Salt a function +-- can only be applied to a value variable, type or witness -- and not +-- a general expression. +data ExpContext + = ExpTop -- ^ At the top-level of the module. + | ExpFun -- ^ At the top-level of a function. + | ExpBody -- ^ In the body of a function. + | ExpBind -- ^ In the right of a let-binding. + | ExpArg -- ^ In a function argument. + deriving (Show, Eq, Ord) + + +--------------------------------------------------------------------------------------------------- +xConvert :: a -> Type A.Name -> Type A.Name -> Exp a A.Name -> Exp a A.Name +xConvert a t1 t2 x1 + = xApps a (XVar a (UPrim (A.NamePrimOp $ A.PrimCast $ A.PrimCastConvert) + (A.typeOfPrimCast A.PrimCastConvert))) + [ XType a t1, XType a t2, x1 ] + + +xTakePtr :: a -> Type A.Name -> Type A.Name -> Exp a A.Name -> Exp a A.Name +xTakePtr a tR tA x1 + = xApps a (XVar a (UPrim (A.NamePrimOp $ A.PrimStore A.PrimStoreTakePtr) + (A.typeOfPrimStore A.PrimStoreTakePtr))) + [ XType a tR, XType a tA, x1 ] + + +xMakePtr :: a -> Type A.Name -> Type A.Name -> Exp a A.Name -> Exp a A.Name +xMakePtr a tR tA x1 + = xApps a (XVar a (UPrim (A.NamePrimOp $ A.PrimStore A.PrimStoreMakePtr) + (A.typeOfPrimStore A.PrimStoreMakePtr))) + [ XType a tR, XType a tA, x1 ] + + diff --git a/DDC/Core/Tetra/Convert/Exp/Ctor.hs b/DDC/Core/Tetra/Convert/Exp/Ctor.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Exp/Ctor.hs @@ -0,0 +1,80 @@ + +module DDC.Core.Tetra.Convert.Exp.Ctor + (convertCtorApp) +where +import DDC.Core.Tetra.Convert.Data +import DDC.Core.Tetra.Convert.Type +import DDC.Core.Tetra.Convert.Error +import DDC.Core.Tetra.Convert.Exp.Base +import DDC.Core.Tetra.Convert.Exp.Lit +import DDC.Core.Pretty +import DDC.Core.Exp.Annot +import DDC.Core.Check (AnTEC(..)) +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 DDC.Type.DataDef + +import DDC.Control.Monad.Check (throw) +import qualified Data.Map as Map + + +-- | Convert a data constructor application to Salt. +convertCtorApp + :: Show a + => Context a + -> AnTEC a E.Name -- ^ Annot from deconstructed app node. + -> DaCon E.Name -- ^ Data constructor being applied. + -> [Exp (AnTEC a E.Name) E.Name] -- ^ Data constructor arguments. + -> ConvertM a (Exp a A.Name) + +convertCtorApp ctx (AnTEC tResult _ _ a) dc xsArgsAll + -- Handle the unit constructor. + | DaConUnit <- dc + = do return $ A.xAllocBoxed a A.rTop 0 (A.xNat a 0) + + -- Literal values + | DaConPrim n _ <- dc + , E.isNameLitUnboxed n + = convertLitCtor a dc + + -- Construct algebraic data. + | Just nCtor <- takeNameOfDaCon dc + , Just ctorDef <- Map.lookup nCtor $ dataDefsCtors (contextDataDefs ctx) + , Just dataDef <- Map.lookup (dataCtorTypeName ctorDef) + $ dataDefsTypes (contextDataDefs ctx) + = do + let pp = contextPlatform ctx + let kenv = contextKindEnv ctx + let tenv = contextTypeEnv ctx + let convertX = contextConvertExp ctx + let tctx = typeContext ctx + + -- Get the prime region variable. + -- The prime region holds the outermost constructor of the object. + trPrime <- saltPrimeRegionOfDataType kenv tResult + + -- Split the constructor arguments into the type and value args. + let xsArgsTypes = [x | x@XType{} <- xsArgsAll] + let xsArgsValues = drop (length xsArgsTypes) xsArgsAll + + -- Convert all the constructor arguments to Salt. + xsArgsValues' <- mapM (convertX ExpArg ctx) + $ xsArgsValues + + -- Determine the Salt type for each of the arguments. + tsArgsValues' <- mapM (convertDataT tctx) + $ map (annotType . annotOfExp) xsArgsValues + + constructData pp kenv tenv a + dataDef ctorDef + trPrime xsArgsValues' tsArgsValues' + + +-- If this fails then the provided constructor args list is probably malformed. +-- This shouldn't happen in type-checked code. +convertCtorApp _ _ dc xsArgsAll + = throw $ ErrorMalformed + $ "Invalid constructor application " ++ (renderIndent $ ppr (dc, xsArgsAll)) diff --git a/DDC/Core/Tetra/Convert/Exp/Lets.hs b/DDC/Core/Tetra/Convert/Exp/Lets.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Exp/Lets.hs @@ -0,0 +1,216 @@ + +module DDC.Core.Tetra.Convert.Exp.Lets + (convertLets) +where +import DDC.Core.Tetra.Convert.Exp.Base +import DDC.Core.Tetra.Convert.Type +import DDC.Core.Tetra.Convert.Error +import DDC.Core.Exp.Annot +import DDC.Core.Check (AnTEC(..)) +import qualified DDC.Core.Tetra.Convert.Type.Base as T +import qualified DDC.Core.Tetra.Prim as E +import qualified DDC.Core.Salt.Name as A +import qualified Data.Map as Map + + +-- | Convert some let-bindings to Salt. +convertLets + :: Show a + => Context a + -> Lets (AnTEC a E.Name) E.Name -- ^ Expression to convert. + -> ConvertM a (Maybe (Lets a A.Name), Context a) + +convertLets ctx lts + = let convertX = contextConvertExp ctx + in case lts of + -- Recursive let-binding. + LRec bxs + -> do let ctx' = extendsTypeEnv (map fst bxs) ctx + bxs' <- mapM (uncurry (convertBinding ctx)) bxs + return ( Just $ LRec bxs' + , ctx') + + -- Polymorphic instantiation of a top-level super. + -- See [Note: Binding top-level supers] + LLet (BName nBind _) (XApp _ xa xb) + | (xF, xsArgs) <- takeXApps1 xa xb + , atsArgs <- [(a, t) | XType a t <- xsArgs] + , tsArgs <- map snd atsArgs + , length tsArgs > 0 + , length xsArgs == length tsArgs + , XVar _ (UName nSuper) <- xF + , Map.member nSuper (contextCallable ctx) + -> return ( Nothing + , ctx { contextSuperBinds + = Map.insert nBind (nSuper, atsArgs) + (contextSuperBinds ctx) }) + + -- Standard non-recursive let-binding. + LLet b x1 + -> do b' <- convertDataB (typeContext ctx) b + x1' <- convertX ExpBind ctx x1 + return ( Just $ LLet b' x1' + , extendTypeEnv b ctx) + + LPrivate bs _ _ + -> return ( Nothing + , extendsTypeEnv bs ctx) + + +-- | Convert a possibly recursive let binding. +convertBinding + :: Show a + => Context a + -> Bind E.Name + -> Exp (AnTEC a E.Name) E.Name + -> ConvertM a (Bind A.Name, Exp a A.Name) + +convertBinding ctx b xx + = do + (x', t') <- convertSuperXT ctx xx (typeOfBind b) + b' <- case b of + BNone _ -> BNone <$> pure t' + BAnon _ -> BAnon <$> pure t' + BName n _ -> BName <$> convertBindNameM n <*> pure t' + + return (b', x') + + +-- | Convert a supercombinator expression in parallel with its type. +-- +-- This also checks that it is in the standard form, +-- meaning that type abstractions must be out the front, +-- then value abstractions, then the body expression. +-- +convertSuperXT + :: Context a + -> Exp (AnTEC a E.Name) E.Name + -> Type E.Name + -> ConvertM a (Exp a A.Name, Type A.Name) + +convertSuperXT ctx0 xx0 tt0 + = convertAbsType ctx0 xx0 (typeContext ctx0) tt0 + where + -- Accepting type abstractions -------------------- + convertAbsType ctxX xx ctxT tt + = case xx of + XLAM a bParamX xBody + | TForall bParamT tBody <- tt + -> convertXLAM a ctxX bParamX xBody + ctxT bParamT tBody + + _ -> convertAbsValue ctxX xx + ctxT tt + + convertXLAM a ctxX bParamX xBody + ctxT bParamT tBody + + -- Erase higher kinded type abstractions. + | Just _ <- takeKFun $ typeOfBind bParamX + = do let ctxX' = extendKindEnv bParamX ctxX + let ctxT' = T.extendKindEnv bParamT ctxT + convertAbsType ctxX' xBody ctxT' tBody + + -- Erase effect abstractions. + | isEffectKind $ typeOfBind bParamX + = do let ctxX' = extendKindEnv bParamX ctxX + let ctxT' = T.extendKindEnv bParamT ctxT + convertAbsType ctxX' xBody ctxT' tBody + + -- Retain region abstractions. + | isRegionKind $ typeOfBind bParamX + = do let a' = annotTail a + + bParamX' <- convertTypeB bParamX + bParamT' <- convertTypeB bParamT + + let ctxX' = extendKindEnv bParamX ctxX + let ctxT' = T.extendKindEnv bParamT ctxT + + (xBody', tBody') + <- convertAbsType ctxX' xBody ctxT' tBody + + return ( XLAM a' bParamX' xBody' + , TForall bParamT' tBody') + + -- When a function is polymorphic in some boxed data type, + -- then the type lambda in Tetra is converted to a region + -- lambda in Salt which binds the region the object is in. + | isDataKind $ typeOfBind bParamX + + , BName (E.NameVar strX) _ <- bParamX + , strX' <- strX ++ "$r" + , bParamX' <- BName (A.NameVar strX') kRegion + + , BName (E.NameVar strT) _ <- bParamT + , strT' <- strT ++ "$r" + , bParamT' <- BName (A.NameVar strT') kRegion + + = do let a' = annotTail a + + let ctxX' = extendKindEnv bParamX ctxX + let ctxT' = T.extendKindEnv bParamT ctxT + + (xBody', tBody') + <- convertAbsType ctxX' xBody ctxT' tBody + + return ( XLAM a' bParamX' xBody' + , TForall bParamT' tBody') + + -- Cannot convert this type abstraction. + -- Maybe the binder is anonymous. + | otherwise + = error "ddc-core-tetra.convertSuperXLAM: Cannot convert type abstraction." + + + -- Accepting value abstractions ------------------- + convertAbsValue ctxX xx ctxT tt + = case xx of + XLam a bParamX xBody + | Just (tParamT, tBody) <- takeTFun tt + -> convertXLam a ctxX bParamX xBody + ctxT tParamT tBody + + _ -> convertBody ctxX xx ctxT tt + + + convertXLam a ctxX bParamX xBody + ctxT tParamT tBody + = do + let a' = annotTail a + + let ctxX' = extendTypeEnv bParamX ctxX + + bParamX' <- convertDataB (typeContext ctxX) bParamX + tParamT' <- convertDataT ctxT tParamT + + (xBody', tBody') <- convertAbsValue ctxX' xBody ctxT tBody + + return ( XLam a' bParamX' xBody' + , tFun tParamT' tBody') + + + -- Converting body expressions--------------------- + convertBody ctxX xx ctxT tt + = do xBody' <- contextConvertExp ctxX ExpBody ctxX xx + tBody' <- convertDataT ctxT tt + return ( xBody', tBody' ) + + +-- Note: Binding top-level supers. +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- After the Curry transform completes, we can still have local bindings like +-- 'f = g [r]', where 'g' is some top-level super. However, we can't bind the +-- names of top-level supers in Salt. +-- +-- When generating code for higher order functions, there will be probably be +-- a 'creify# f' call later on. As the Salt-level reify operation only works +-- on the names of top-level supers rather than local bindings, remember that +-- 'f' is just an instantiation of 'g' so when we find the 'creify# f' we can +-- point it to 'g' instead. +-- +-- This fakes up enough binding of functional values to make code generation +-- easy, but they're still not first class. We cannot pass or return functional +-- values to/from other functions. +-- + diff --git a/DDC/Core/Tetra/Convert/Exp/Lit.hs b/DDC/Core/Tetra/Convert/Exp/Lit.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Exp/Lit.hs @@ -0,0 +1,34 @@ + +module DDC.Core.Tetra.Convert.Exp.Lit + (convertLitCtor) +where +import DDC.Core.Tetra.Convert.Error +import DDC.Core.Exp.Annot +import qualified DDC.Core.Tetra.Prim as E +import qualified DDC.Core.Salt.Name as A +import qualified DDC.Core.Salt.Compounds as A +import DDC.Control.Monad.Check (throw) + + +-- | Convert a literal constructor to Salt. +-- These are values that have boxable index types like Bool# and Nat#. +convertLitCtor + :: a -- ^ Annot from deconstructed XCon node. + -> DaCon E.Name -- ^ Data constructor of literal. + -> ConvertM a (Exp a A.Name) + +convertLitCtor a dc + | Just (E.NameLitUnboxed n) <- takeNameOfDaCon dc + = case n of + E.NameLitBool b -> return $ A.xBool a b + E.NameLitNat i -> return $ A.xNat a i + E.NameLitInt i -> return $ A.xInt a i + E.NameLitSize i -> return $ A.xSize a i + E.NameLitWord i bits -> return $ A.xWord a i bits + E.NameLitFloat f bits -> return $ A.xFloat a f bits + E.NameLitTextLit bs -> return $ A.xTextLit a bs + _ -> throw $ ErrorMalformed "Invalid literal." + + | otherwise + = throw $ ErrorMalformed "Invalid literal." + diff --git a/DDC/Core/Tetra/Convert/Exp/PrimArith.hs b/DDC/Core/Tetra/Convert/Exp/PrimArith.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Exp/PrimArith.hs @@ -0,0 +1,92 @@ + +module DDC.Core.Tetra.Convert.Exp.PrimArith + (convertPrimArith) +where +import DDC.Core.Tetra.Convert.Exp.Base +import DDC.Core.Tetra.Convert.Type +import DDC.Core.Tetra.Convert.Boxing +import DDC.Core.Tetra.Convert.Error +import DDC.Core.Pretty +import DDC.Core.Exp.Annot +import DDC.Core.Check (AnTEC(..)) +import DDC.Control.Monad.Check (throw) +import qualified DDC.Core.Tetra.Prim as E +import qualified DDC.Core.Salt.Name as A + + +-- | Convert a Tetra arithmetic or logic primop to Salt. +convertPrimArith + :: Show a + => 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)) + +convertPrimArith _ectx ctx xx + = let downPrimArgX = convertPrimArgX ctx ExpArg + downArgX = convertX ExpArg ctx + convertX = contextConvertExp ctx + in case xx of + + --------------------------------------------------- + -- Saturated application of a primitive operator. + XApp a xa xb + | (x1, xsArgs) <- takeXApps1 xa xb + , XVar _ (UPrim nPrim tPrim) <- x1 + + -- All the value arguments have representatable types. + , all isSomeRepType + $ map (annotType . annotOfExp) + $ filter (not . isXType) xsArgs + + -- The result is representable. + , isSomeRepType (annotType a) + + -> Just $ if -- Check that the primop is saturated. + length xsArgs == arityOfType tPrim + then do + x1' <- downArgX x1 + xsArgs' <- mapM downPrimArgX xsArgs + + case nPrim of + E.NamePrimArith o False + | elem o [ E.PrimArithEq, E.PrimArithNeq + , E.PrimArithGt, E.PrimArithLt + , E.PrimArithLe, E.PrimArithGe ] + , [t1, z1, z2] <- xsArgs' + -> return $ xApps (annotTail a) x1' [t1, z1, z2] + + _ -> return $ xApps (annotTail a) x1' xsArgs' + + else throw $ ErrorUnsupported xx + $ text "Partial application of primitive operators is not supported." + + --------------------------------------------------- + -- This isn't an arithmetic or logic primop. + _ -> Nothing + + +-- | Although we ditch type arguments when applied to general functions, +-- we need to convert the ones applied directly to primops, +-- as the primops are specified polytypically. +convertPrimArgX + :: Show a + => Context a + -> ExpContext -- ^ What context we're converting in. + -> Exp (AnTEC a E.Name) E.Name -- ^ Expression to convert. + -> ConvertM a (Exp a A.Name) + +convertPrimArgX ctx ectx xx + = let convertX = contextConvertExp ctx + in case xx of + XType a t + -> do t' <- convertDataPrimitiveT t + return $ XType (annotTail a) t' + + XWitness{} + -> throw $ ErrorUnsupported xx + $ text "Witness expressions are not part of the Tetra language." + + _ -> convertX ectx ctx xx + + diff --git a/DDC/Core/Tetra/Convert/Exp/PrimBoxing.hs b/DDC/Core/Tetra/Convert/Exp/PrimBoxing.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Exp/PrimBoxing.hs @@ -0,0 +1,81 @@ + +module DDC.Core.Tetra.Convert.Exp.PrimBoxing + (convertPrimBoxing) +where +import DDC.Core.Tetra.Convert.Exp.Base +import DDC.Core.Tetra.Convert.Boxing +import DDC.Core.Tetra.Convert.Data +import DDC.Core.Tetra.Convert.Type +import DDC.Core.Tetra.Convert.Error + +import DDC.Core.Transform.BoundX +import DDC.Core.Exp.Annot +import DDC.Core.Check (AnTEC(..)) +import qualified DDC.Core.Tetra.Prim as E +import qualified DDC.Core.Salt.Runtime as A +import qualified DDC.Core.Salt.Name as A + + +-- | Convert a Tetra boxing primop to Salt. +convertPrimBoxing + :: Show a + => 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)) + +convertPrimBoxing _ectx ctx xx + = let pp = contextPlatform ctx + kenv = contextKindEnv ctx + tenv = contextTypeEnv ctx + + convertX = contextConvertExp ctx + downArgX = convertX ExpArg ctx + + in case xx of + + -- Boxing of unboxed numeric values. + -- The unboxed representation of a numeric value is the machine value. + -- We fake-up a data-type declaration so we can use the same data layout + -- code as for user-defined types. + XApp a _ _ + | Just ( E.NamePrimCast E.PrimCastConvert + , [XType _ tUx, XType _ tBx, xArg]) <- takeXPrimApps xx + , isUnboxedRepType tUx + , isNumericType tBx + , Just dt <- makeBoxedPrimDataType tBx + , Just dc <- makeBoxedPrimDataCtor tBx + -> Just $ do + let a' = annotTail a + xArg' <- downArgX xArg + tUx' <- convertDataPrimitiveT tBx + + constructData pp kenv tenv a' + dt dc A.rTop [xArg'] [tUx'] + + + -- Unboxing of boxed values. + -- The unboxed representation of a numeric value is the machine value. + -- We fake-up a data-type declaration so we can use the same data layout + -- code as for used-defined types. + XApp a _ _ + | Just ( E.NamePrimCast E.PrimCastConvert + , [XType _ tBx, XType _ tUx, xArg]) <- takeXPrimApps xx + , isUnboxedRepType tUx + , isNumericType tBx + , Just dc <- makeBoxedPrimDataCtor tBx + -> Just $ do + let a' = annotTail a + xArg' <- downArgX xArg + tBx' <- convertDataT (typeContext ctx) tBx + tUx' <- convertDataPrimitiveT tBx + + x' <- destructData pp a' dc + (UIx 0) A.rTop + [BAnon tUx'] (XVar a' (UIx 0)) + + return $ XLet a' (LLet (BAnon tBx') (liftX 1 xArg')) x' + + -- This isn't a boxing primitive. + _ -> Nothing + diff --git a/DDC/Core/Tetra/Convert/Exp/PrimCall.hs b/DDC/Core/Tetra/Convert/Exp/PrimCall.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Exp/PrimCall.hs @@ -0,0 +1,219 @@ + +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 + :: Show a + => 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 + diff --git a/DDC/Core/Tetra/Convert/Exp/PrimError.hs b/DDC/Core/Tetra/Convert/Exp/PrimError.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Exp/PrimError.hs @@ -0,0 +1,37 @@ + +module DDC.Core.Tetra.Convert.Exp.PrimError + (convertPrimError) +where +import DDC.Core.Tetra.Convert.Exp.Base +import DDC.Core.Tetra.Convert.Error + +import DDC.Core.Exp.Annot +import DDC.Core.Check (AnTEC(..)) + +import qualified DDC.Core.Tetra.Prim as E +import qualified DDC.Core.Salt.Name as A +import qualified DDC.Core.Salt.Runtime as A + + +-- | Covnert a Tetra error primop to Salt. +convertPrimError + :: Show a + => 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)) + +convertPrimError _ectx ctx xx + = let convertX = contextConvertExp ctx + downArgX = convertX ExpArg ctx + in + case xx of + XApp a _ _ + | Just ( E.NameOpError E.OpErrorDefault True + , [_, xStr, xLine]) <- takeXPrimApps xx + -> Just $ do + xStr' <- downArgX xStr + xLine' <- downArgX xLine + return $ A.xErrorDefault (annotTail a) xStr' xLine' + + _ -> Nothing diff --git a/DDC/Core/Tetra/Convert/Exp/PrimVector.hs b/DDC/Core/Tetra/Convert/Exp/PrimVector.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Exp/PrimVector.hs @@ -0,0 +1,178 @@ + +module DDC.Core.Tetra.Convert.Exp.PrimVector + (convertPrimVector) +where +import DDC.Core.Tetra.Convert.Exp.Base +import DDC.Core.Tetra.Convert.Boxing +import DDC.Core.Tetra.Convert.Type +import DDC.Core.Tetra.Convert.Error +import DDC.Core.Exp.Annot +import DDC.Core.Check (AnTEC(..)) +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 + + +convertPrimVector + :: Show a + => 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)) + +convertPrimVector _ectx ctx xxExp + = let convertX = contextConvertExp ctx + in case xxExp of + + -- Vector allocate. + -- ISSUE #349: Zero the payload of unboxed vectors when we allocate them. + XCast _ CastRun xxApp@(XApp a _ _) + | Just ( E.NameOpVector E.OpVectorAlloc True + , [XType _ _rPrime, XType _ tElem, xLength]) + <- takeXPrimApps xxApp + , isNumericType tElem + -> Just $ do + let a' = annotTail a + + -- The element type of the vector. + tElem' <- convertDataPrimitiveT tElem + + -- Length of the vector payload, in elements. + xLengthElems' <- convertX ExpArg ctx xLength + + -- Length of the vector payload, in bytes. + let xLengthBytes' = A.xShl a' A.tNat xLengthElems' + (A.xStoreSize2 a' tElem') + + return $ XLet a' (LLet (BAnon (A.tPtr A.rTop A.tObj)) + (A.xAllocRaw a' A.rTop 0 xLengthBytes')) + $ XVar a' (UIx 0) + + + -- Vector length. + XApp a _ _ + | Just ( E.NameOpVector E.OpVectorLength True + , [XType _ _tPrime, XType _ tElem, xVec]) + <- takeXPrimApps xxExp + , isNumericType tElem + -> Just $ do + let a' = annotTail a + + -- The element type of the vector. + tElem' <- convertDataPrimitiveT tElem + + -- Pointer to the vector object. + xVec' <- convertX ExpArg ctx xVec + + -- Size of the vector payload, in bytes. + let xLengthBytes = xVectorLength a' A.rTop xVec' + + -- Shift down the length-in-bytes so we get length-in-elements. + return $ A.xShr a' A.tNat xLengthBytes + (A.xStoreSize2 a' tElem') + + + -- Vector read. + XCast _ CastRun xxApp@(XApp a _ _) + | Just ( E.NameOpVector E.OpVectorRead True + , [XType _ _rPrime, XType _ tElem, xVec, xIndex]) + <- takeXPrimApps xxApp + , isNumericType tElem + -> Just $ do + let a' = annotTail a + + -- The element type of the vector. + tElem' <- convertDataPrimitiveT tElem + + -- Pointer to the vector object. + xVec' <- convertX ExpArg ctx xVec + + -- Index of the element that we want. + xIndex' <- convertX ExpArg ctx xIndex + + -- Pointer to the start of the object payload, + -- which is the unboxed vector data. + let xPayload' = A.xCastPtr a' A.rTop tElem' (A.tWord 8) + (A.xPayloadOfRaw a' A.rTop xVec') + + -- Offset to the starting byte of the word we want, + -- relative to the start of the payload. + let xStart' = A.xShl a' A.tNat xIndex' + (A.xStoreSize2 a' tElem') + + -- Length of the vector payload, in bytes. + -- If xStart' is higher than this then we have an out-of-bounds error, + -- which the peekBounded primop will detect. + let xTop' = xVectorLength a' A.rTop xVec' + + -- Read the value. + return $ A.xPeekBounded a' A.rTop tElem' xPayload' xStart' xTop' + + + -- Vector write. + XCast _ CastRun xxApp@(XApp a _ _) + | Just ( E.NameOpVector E.OpVectorWrite True + , [XType _ _rPrime, XType _ tElem, xVec, xIndex, xValue]) + <- takeXPrimApps xxApp + , isNumericType tElem + -> Just $ do + let a' = annotTail a + + -- The element type of the vector. + tElem' <- convertDataPrimitiveT tElem + + -- Pointer to the vector object. + xVec' <- convertX ExpArg ctx xVec + + -- Index of the element that we want. + xIndex' <- convertX ExpArg ctx xIndex + + -- The value to write. + xValue' <- convertX ExpArg ctx xValue + + -- Pointer to the start of the object payload, + -- which is the unboxed vector data. + let xPayload' = A.xCastPtr a' A.rTop tElem' (A.tWord 8) + (A.xPayloadOfRaw a' A.rTop xVec') + + -- Offset to the starting byte of the word we want, + -- relative to the start of the payload. + let xStart' = A.xShl a' A.tNat xIndex' + (A.xStoreSize2 a' tElem') + + -- Length of the vector payload, in bytes. + -- If xStart' is higher than this then we have an out-of-bounds error, + -- which the peekBounded primop will detect. + let xTop' = xVectorLength a' A.rTop xVec' + + -- Write the value. + return $ A.xPokeBounded a' A.rTop tElem' xPayload' xStart' xTop' xValue' + + + _ -> Nothing + + +-- Get the size of the vector payload, in bytes. +-- +-- * This contains the hard-coded length of the raw object payload in bytes, +-- as well as a hard-coded offset to the size field of the header. +-- +xVectorLength + :: a -> Type A.Name + -> Exp a A.Name -> Exp a A.Name + +xVectorLength a rVec xVec + = let + -- Read the size field of the object, + -- to get the total object length in bytes. + xLengthObject + = A.xPromote a A.tNat (A.tWord 32) + $ A.xPeek a rVec (A.tWord 32) + (A.xCastPtr a rVec (A.tWord 32) A.tObj xVec) + (A.xNat a 4) + + -- Subtract the size of the object header, + -- so we get payload length in bytes. + in A.xSub a A.tNat xLengthObject (A.xNat a 8) + diff --git a/DDC/Core/Tetra/Convert/Layout.hs b/DDC/Core/Tetra/Convert/Layout.hs --- a/DDC/Core/Tetra/Convert/Layout.hs +++ b/DDC/Core/Tetra/Convert/Layout.hs @@ -44,7 +44,7 @@ , all isBoxedRepType tsFields = Just HeapObjectBoxed - -- All of the fixed size primitive types will fit in a RawSmall object. + -- All of the primitive numeric types will fit in a RawSmall object. -- Each field needs to be non-abstract, and have a real width. | [t1] <- dataCtorFieldTypes ctor , Just (NameTyConTetra TyConTetraU, [tp]) <- takePrimTyConApps t1 @@ -52,6 +52,13 @@ , isJust $ A.primTyConWidth pp ptc = Just HeapObjectRawSmall + -- Unboxed strings are represented as pointers to static memory. + -- The pointer will fit in a RawSmall object. + | [t1] <- dataCtorFieldTypes ctor + , Just (NameTyConTetra TyConTetraU, [tp]) <- takePrimTyConApps t1 + , Just (NamePrimTyCon PrimTyConTextLit, []) <- takePrimTyConApps tp + = Just HeapObjectRawSmall + | otherwise = Nothing @@ -127,14 +134,10 @@ -- but I can't think of reason to have them in data type definitions. PrimTyConVoid -> Nothing - -- Pointer tycon shouldn't appear by itself. - PrimTyConPtr -> Nothing - - PrimTyConAddr -> Just $ platformAddrBytes platform + PrimTyConBool -> Just $ 1 PrimTyConNat -> Just $ platformNatBytes platform PrimTyConInt -> Just $ platformNatBytes platform - PrimTyConTag -> Just $ platformTagBytes platform - PrimTyConBool -> Just $ 1 + PrimTyConSize -> Just $ platformNatBytes platform PrimTyConWord bits | bits `rem` 8 == 0 -> Just $ fromIntegral $ bits `div` 8 @@ -147,6 +150,14 @@ -- Vectors don't appear as raw fields. PrimTyConVec{} -> Nothing - -- Strings shouldn't appear as raw fields, only pointers to them. - PrimTyConString -> Nothing + -- Address value. + PrimTyConAddr -> Just $ platformAddrBytes platform + + -- Pointer tycon shouldn't appear by itself. + PrimTyConPtr -> Nothing + + -- Address of static memory where the string data is stored. + PrimTyConTextLit -> Just $ platformAddrBytes platform + + PrimTyConTag -> Just $ platformTagBytes platform diff --git a/DDC/Core/Tetra/Convert/Type.hs b/DDC/Core/Tetra/Convert/Type.hs --- a/DDC/Core/Tetra/Convert/Type.hs +++ b/DDC/Core/Tetra/Convert/Type.hs @@ -1,541 +1,38 @@ module DDC.Core.Tetra.Convert.Type - ( -- * Kind conversion. - convertK + ( -- * Names + convertBindNameM - -- * Type conversion. + -- * Kinds + , convertK + , convertTypeB + , convertTypeU + + -- * Region types , convertRegionT - , convertIndexT - , convertCapabilityT - , convertDataT - , convertRepableT + , saltPrimeRegionOfDataType - -- * Data constructor conversion. + -- * Data constructors + , convertCtorT , convertDaCon - -- * Bind and Bound conversion. - , convertTypeB - , convertTypeU - - , convertValueB - , convertRepableB + -- * Capabilities + , convertCapabilityT , convertCapabilityB - , convertValueU - -- * Names - , convertBindNameM + -- * Data + , convertDataB + , convertDataU + , convertDataT + , convertDataPrimitiveT - -- * Prime regions - , saltPrimeRegionOfDataType - , saltDataTypeOfArgType) + -- * Supers + , convertSuperConsT) where -import DDC.Core.Tetra.Convert.Boxing -import DDC.Core.Tetra.Convert.Base -import DDC.Core.Exp -import DDC.Type.Env -import DDC.Type.DataDef -import DDC.Type.Compounds -import DDC.Type.Predicates -import DDC.Control.Monad.Check (throw) -import qualified DDC.Core.Tetra.Prim as E -import qualified DDC.Core.Salt.Env as A -import qualified DDC.Core.Salt.Name as A -import qualified DDC.Core.Salt.Compounds as A -import qualified DDC.Core.Salt.Runtime as A -import qualified DDC.Type.Env as Env -import qualified Data.Map as Map -import Control.Monad - -import DDC.Base.Pretty - - --- Kind ------------------------------------------------------------------------------------------- --- | Convert a kind from Core Tetra to Core Salt. -convertK :: Kind E.Name -> ConvertM a (Kind A.Name) -convertK kk - = case kk of - TCon (TyConKind kc) - -> return $ TCon (TyConKind kc) - _ -> throw $ ErrorMalformed "Invalid kind." - - --- Region Types ----------------------------------------------------------------------------------- --- | Convert a region type to Salt. -convertRegionT :: KindEnv E.Name -> Type E.Name -> ConvertM a (Type A.Name) -convertRegionT kenv tt - | TVar u <- tt - , Just k <- Env.lookup u kenv - , isRegionKind k - = liftM TVar $ convertTypeU u - - | otherwise - = throw $ ErrorMalformed $ "Invalid region type " ++ (renderIndent $ ppr tt) - - --- Index Types ------------------------------------------------------------------------------------ --- | Convert a numeric index type to Salt. --- --- In Tetra numeric index types like Nat# are used as type indices when --- specifying a boxed representation (B# Nat#) --- or unboxed representation (U# Nat#) --- for a particular numeric value. --- --- Note that we do not convert Void# because it's not a numeric type. --- -convertIndexT :: Type E.Name -> ConvertM a (Type A.Name) -convertIndexT tt - | Just (E.NamePrimTyCon n, []) <- takePrimTyConApps tt - = case n of - E.PrimTyConBool -> return $ A.tBool - E.PrimTyConNat -> return $ A.tNat - E.PrimTyConInt -> return $ A.tInt - E.PrimTyConWord bits -> return $ A.tWord bits - E.PrimTyConFloat bits -> return $ A.tWord bits - _ -> throw $ ErrorMalformed "Invalid numeric index type." - - | otherwise - = throw $ ErrorMalformed "Invalid numeric index type." - - --- Capability Types ------------------------------------------------------------------------------- --- | Convert a capability / coeffect type to Salt. -convertCapabilityT :: KindEnv E.Name -> Type E.Name -> ConvertM a (Type A.Name) -convertCapabilityT kenv tt - | Just (TyConSpec tc, [tR]) <- takeTyConApps tt - = do tR' <- convertRegionT kenv tR - case tc of - TcConRead -> return $ tRead tR' - TcConWrite -> return $ tWrite tR' - TcConAlloc -> return $ tAlloc tR' - _ -> throw $ ErrorMalformed $ "Malformed capability type." - - | otherwise - = throw $ ErrorMalformed $ "Malformed capability type." - - --- Data Types ------------------------------------------------------------------------------------- --- | Convert a data type from Core Tetra to Core Salt. --- --- This version can be used to convert both representational and --- non-representational types. --- --- In the input program, all function parameters and arguments must --- be representational, but we may have let-bindings that bind pure values --- of non-representational type. --- -convertDataT - :: DataDefs E.Name -> KindEnv E.Name -> Type E.Name - -> ConvertM a (Type A.Name) - -convertDataT defs kenv tt - | Just (E.NamePrimTyCon n, []) <- takePrimTyConApps tt - = case n of - E.PrimTyConVoid -> return $ A.tVoid - E.PrimTyConBool -> return $ A.tBool - E.PrimTyConNat -> return $ A.tNat - E.PrimTyConInt -> return $ A.tInt - E.PrimTyConWord bits -> return $ A.tWord bits - E.PrimTyConString -> return $ A.tString - _ -> throw $ ErrorMalformed "Cannot convert data type." - - | otherwise - = convertRepableT defs kenv tt - - --- | Convert a representable type from Core Tetra to Core Salt. --- --- Representable numeric types must be explicitly boxed (like B# Nat) or --- unboxed (U# Nat#), and not plain Nat#. --- --- Function paramters and arguments cannot have non-representational --- types because this doesn't tell us what calling convention to use. --- -convertRepableT - :: DataDefs E.Name -> KindEnv E.Name -> Type E.Name - -> ConvertM a (Type A.Name) - -convertRepableT defs kenv tt - = case tt of - -- Convert type variables and constructors. - TVar u - -> case Env.lookup u kenv of - Just k - -- Parametric data types are represented as generic objects, - -- where the region those objects are in is named after the - -- original type name. - | isDataKind k - , UName (E.NameVar str) <- u - , str' <- str ++ "$r" - , u' <- UName (A.NameVar str') - -> return $ A.tPtr (TVar u') A.tObj - - | otherwise - -> throw $ ErrorMalformed "Repable var type has invalid kind or bound." - - Nothing - -> throw $ ErrorInvalidBound u - - -- We pass exising quantifiers of Region variables to the Salt language, - -- and convert quantifiers of data types to the punned name of - -- their top-level region.s - TForall b t - | isRegionKind (typeOfBind b) - -> do let kenv' = Env.extend b kenv - b' <- convertTypeB b - t' <- convertRepableT defs kenv' t - return $ TForall b' t' - - | isDataKind (typeOfBind b) - , BName (E.NameVar str) _ <- b - , str' <- str ++ "$r" - , b' <- BName (A.NameVar str') kRegion - -> do - let kenv' = Env.extend b kenv - t' <- convertRepableT defs kenv' t - return $ TForall b' t' - - | otherwise - -> do let kenv' = Env.extend b kenv - convertRepableT defs kenv' t - - -- Convert unapplied type constructors. - TCon{} -> convertRepableTyConApp defs kenv tt - - -- Convert type constructor applications. - TApp{} -> convertRepableTyConApp defs kenv tt - - -- Resentable types always have kind Data, but type sums cannot. - TSum{} -> throw $ ErrorUnexpectedSum - - --- | Convert the application of a type constructor to Salt form. -convertRepableTyConApp - :: DataDefs E.Name -> KindEnv E.Name - -> Type E.Name -> ConvertM a (Type A.Name) - -convertRepableTyConApp defs kenv tt - -- Convert Tetra function types to Salt function types. - | Just (t1, t2) <- takeTFun tt - = do t1' <- convertRepableT defs kenv t1 - t2' <- convertRepableT defs kenv t2 - return $ tFunPE t1' t2' - - -- Ambient TyCons ----------------------- - -- The Unit type. - | Just (TyConSpec TcConUnit, []) <- takeTyConApps tt - = return $ A.tPtr A.rTop A.tObj - - -- The Suspended Computation type. - | Just (TyConSpec TcConSusp, [_tEff, tResult]) <- takeTyConApps tt - = do convertRepableT defs kenv tResult - - - -- Primitive TyCons --------------------- - -- The Void# type. - | Just (E.NamePrimTyCon E.PrimTyConVoid, []) <- takePrimTyConApps tt - = return A.tVoid - - -- The String# type. - | Just (E.NamePrimTyCon E.PrimTyConString, []) <- takePrimTyConApps tt - = return A.tString - - -- The Ref# type. - | Just (E.NamePrimTyCon E.PrimTyConVoid, []) <- takePrimTyConApps tt - = return A.tVoid - - -- The Ptr# types. - | Just (E.NamePrimTyCon E.PrimTyConPtr, [tR, tX]) <- takePrimTyConApps tt - = do tR' <- convertRegionT kenv tR - tX' <- convertDataT defs kenv tX - return $ A.tPtr tR' tX' - - - -- Tetra TyCons ------------------------- - -- The mutable reference type. - | Just ( E.NameTyConTetra E.TyConTetraRef - , [tR, _tX]) <- takePrimTyConApps tt - = do - tR' <- convertRegionT kenv tR - return $ A.tPtr tR' A.tObj - - -- Explicitly Boxed numeric types. - -- In Salt, boxed numeric values are represented in generic form, - -- as pointers to objects in the top-level region. - | Just ( E.NameTyConTetra E.TyConTetraB - , [tBIx]) <- takePrimTyConApps tt - , isBoxableIndexType tBIx - = return $ A.tPtr A.rTop A.tObj - - -- Explicitly Unboxed numeric types. - -- In Salt, unboxed numeric values are represented directly as - -- values of the corresponding machine type. - | Just ( E.NameTyConTetra E.TyConTetraU - , [tBIx]) <- takePrimTyConApps tt - , isBoxableIndexType tBIx - = do tBIx' <- convertIndexT tBIx - return tBIx' - - - -- User defined TyCons ------------------ - -- A user-defined data type with a primary region. - -- These are converted to generic boxed objects in the same region. - | Just (TyConBound (UName n) _, tR : _args) <- takeTyConApps tt - , TVar u <- tR - , Just k <- Env.lookup u kenv - , isRegionKind k - , Map.member n (dataDefsTypes defs) - = do tR' <- convertRegionT kenv tR - return $ A.tPtr tR' A.tObj - - -- A user-defined data type without a primary region. - -- These are converted to generic boxed objects in the top-level region. - | Just (TyConBound (UName n) _, _) <- takeTyConApps tt - , Map.member n (dataDefsTypes defs) - = do return $ A.tPtr A.rTop A.tObj - - | otherwise - = throw $ ErrorMalformed - $ "Invalid type constructor application " - ++ (renderIndent $ ppr tt) - --- Binds ------------------------------------------------------------------------------------------ --- | Convert a type binder. --- These are formal type parameters. -convertTypeB :: Bind E.Name -> ConvertM a (Bind A.Name) -convertTypeB bb - = case bb of - BNone k -> liftM BNone (convertK k) - BAnon k -> liftM BAnon (convertK k) - BName n k -> liftM2 BName (convertBindNameM n) (convertK k) - - --- | Convert a value binder with a representable type. --- This is used for the binders of function arguments, which must have --- representatable types to adhere to some calling convention. -convertRepableB - :: DataDefs E.Name -> KindEnv E.Name - -> Bind E.Name -> ConvertM a (Bind A.Name) - -convertRepableB defs kenv bb - = case bb of - BNone t -> liftM BNone (convertRepableT defs kenv t) - BAnon t -> liftM BAnon (convertRepableT defs kenv t) - BName n t -> liftM2 BName (convertBindNameM n) (convertRepableT defs kenv t) - - --- | Convert a witness binder. -convertCapabilityB :: KindEnv E.Name -> Bind E.Name -> ConvertM a (Bind A.Name) -convertCapabilityB kenv bb - = case bb of - BNone t -> liftM BNone (convertCapabilityT kenv t) - BAnon t -> liftM BAnon (convertCapabilityT kenv t) - BName n t -> liftM2 BName (convertBindNameM n) (convertCapabilityT kenv t) - - --- | Convert a value binder. --- This uses `convertDataT` on the attached type, so works for representational --- or non-representational types. The latter is used for let-binders which --- don't need to be representational becaues the values only exist --- internally to a function. -convertValueB - :: DataDefs E.Name -> KindEnv E.Name - -> Bind E.Name -> ConvertM a (Bind A.Name) - -convertValueB defs kenv bb - = case bb of - BNone t -> liftM BNone (convertDataT defs kenv t) - BAnon t -> liftM BAnon (convertDataT defs kenv t) - BName n t -> liftM2 BName (convertBindNameM n) (convertDataT defs kenv t) - - - --- | Convert the name of a Bind. -convertBindNameM :: E.Name -> ConvertM a A.Name -convertBindNameM nn - = case nn of - E.NameVar str -> return $ A.NameVar str - _ -> throw $ ErrorInvalidBinder nn - - --- Bounds ----------------------------------------------------------------------------------------- --- | Convert a type bound. --- These are bound by formal type parametrs. -convertTypeU :: Bound E.Name -> ConvertM a (Bound A.Name) -convertTypeU uu - = case uu of - UIx i - -> return $ UIx i - - UName (E.NameVar str) - -> return $ UName (A.NameVar str) - - -- There are no primitive type variables, - -- so we don't need to handle the UPrim case. - _ -> throw $ ErrorInvalidBound uu - - --- | Convert a value bound. --- These refer to function arguments or let-bound values, --- and hence must have representable types. -convertValueU :: Bound E.Name -> ConvertM a (Bound A.Name) -convertValueU uu - = case uu of - UIx i - -> return $ UIx i - - UName (E.NameVar str) - -> return $ UName (A.NameVar str) - - -- When converting primops, use the type directly specified by the - -- Salt language instead of converting it from Tetra. The types from - -- each language definition may not be inter-convertible. - UPrim n _ - -> case n of - E.NamePrimArith op - -> return $ UPrim (A.NamePrimOp (A.PrimArith op)) - (A.typeOfPrimArith op) - - E.NamePrimCast op - -> return $ UPrim (A.NamePrimOp (A.PrimCast op)) - (A.typeOfPrimCast op) - - _ -> throw $ ErrorInvalidBound uu - - _ -> throw $ ErrorInvalidBound uu - - --- DaCon ------------------------------------------------------------------------------------------ --- | Convert a data constructor definition. -convertDaCon - :: DataDefs E.Name -> KindEnv E.Name -> DaCon E.Name - -> ConvertM a (DaCon A.Name) - -convertDaCon defs kenv dc - = case dc of - DaConUnit - -> return DaConUnit - - DaConPrim n t - -> do n' <- convertDaConNameM dc n - t' <- convertDataT defs kenv t - return $ DaConPrim - { daConName = n' - , daConType = t' } - - DaConBound n - -> do n' <- convertDaConNameM dc n - return $ DaConBound - { daConName = n' } - - --- | Convert the name of a data constructor. -convertDaConNameM :: DaCon E.Name -> E.Name -> ConvertM a A.Name -convertDaConNameM dc nn - = case nn of - E.NameLitBool val -> return $ A.NameLitBool val - E.NameLitNat val -> return $ A.NameLitNat val - E.NameLitInt val -> return $ A.NameLitInt val - E.NameLitWord val bits -> return $ A.NameLitWord val bits - _ -> throw $ ErrorInvalidDaCon dc - - --- Prime Region ----------------------------------------------------------------------------------- --- | Given the type of some data value, determine what prime region to use --- for the object in the Salt language. The supplied type must have kind --- Data, else you'll get a bogus result. --- --- Boxed data types whose first parameter is a region, by convention that --- region is the prime one. --- List r1 a => r1 --- --- Boxed data types that do not have a region as the first parameter, --- these are allocated into the top-level region. --- Unit => rTop --- B# Nat# => rTop --- --- Functions are also allocated into the top-level region. --- a -> b => rTop --- forall ... => rTop --- --- For completely parametric data types we use a region named after the --- associated type variable. --- a => a$r --- --- For types with an abstract constructor, we currently reject them outright. --- There's no way to tell what region an object of such a type should be --- allocated into. In future we should add a supertype of regions, and treat --- such objects as belong to the Any region. --- See [Note: Salt conversion for higher kinded type arguments] --- c a b => ** NOTHING ** --- --- Unboxed and index types don't refer to boxed objects, so they don't have --- associated prime regions. --- Nat# => ** NOTHING ** --- U# Nat# => ** NOTHING ** --- -saltPrimeRegionOfDataType - :: KindEnv E.Name - -> Type E.Name - -> ConvertM a (Type A.Name) - -saltPrimeRegionOfDataType kenv tt - -- Boxed data types with an attached primary region variable. - | TCon _ : TVar u : _ <- takeTApps tt - , Just k <- Env.lookup u kenv - , isRegionKind k - , isBoxedRepType tt - = do u' <- convertTypeU u - return $ TVar u' - - -- Boxed data types without an attached primary region variable. - -- This also covers the function case. - | TCon _ : _ <- takeTApps tt - , isBoxedRepType tt - = do return A.rTop - - -- Quantified types. - | TForall{} <- tt - = do return A.rTop - - -- Completely parametric data types. - | TVar u <- tt - , Just k <- Env.lookup u kenv - , isDataKind k - , UName (E.NameVar str) <- u - , str' <- str ++ "$r" - , u' <- UName (A.NameVar str') - = do return $ TVar u' - - | otherwise - = throw $ ErrorMalformed - $ "Cannot take prime region from " ++ (renderIndent $ ppr tt) - - --- | Given the type of some function parameters or return value, produce the --- Salt type used to represent it. The supplied type must have kind data, --- and a boxed or unboxed representation. As this is used for function --- parameters and return values, functions and quantified typesare represented ---- as generic boxed objects. -saltDataTypeOfArgType - :: KindEnv E.Name - -> Type E.Name - -> ConvertM a (Type A.Name) - -saltDataTypeOfArgType kenv tt - -- Boxed values are represented as pointers to generic objects. - | isBoxedRepType tt - = do trPrime <- saltPrimeRegionOfDataType kenv tt - return $ A.tPtr trPrime A.tObj - - -- Explicitly unboxed types. - | isUnboxedRepType tt - , Just ( E.NameTyConTetra E.TyConTetraU - , [tBIx]) <- takePrimTyConApps tt - , isBoxableIndexType tBIx - = do tBIx' <- convertIndexT tBIx - return tBIx' - - | otherwise - = throw $ ErrorMalformed - $ "Cannot convert argument type " ++ (renderIndent $ ppr tt) - +import DDC.Core.Tetra.Convert.Type.Kind +import DDC.Core.Tetra.Convert.Type.Region +import DDC.Core.Tetra.Convert.Type.Witness +import DDC.Core.Tetra.Convert.Type.Super +import DDC.Core.Tetra.Convert.Type.DaCon +import DDC.Core.Tetra.Convert.Type.Data +import DDC.Core.Tetra.Convert.Type.Base diff --git a/DDC/Core/Tetra/Convert/Type/Base.hs b/DDC/Core/Tetra/Convert/Type/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Type/Base.hs @@ -0,0 +1,59 @@ + +module DDC.Core.Tetra.Convert.Type.Base + ( Context (..) + , extendKindEnv + , extendsKindEnv + , convertBindNameM) +where +import DDC.Core.Tetra.Convert.Error +import DDC.Type.Exp +import DDC.Type.DataDef +import DDC.Control.Monad.Check (throw) +import DDC.Type.Env (KindEnv) +import Data.Set (Set) +import qualified DDC.Type.Env as Env +import qualified DDC.Core.Tetra.Prim as E +import qualified DDC.Core.Salt.Name as A + + +-- | Context of a type conversion. +data Context + = Context + { -- | Data type definitions. + -- These are all the visible data type definitions, from both + -- the current module and imported ones. + contextDataDefs :: DataDefs E.Name + + -- | Names of foreign boxed data type contructors. + -- These are names like 'Ref' and 'Array' that are defined in the + -- runtime system rather than as an algebraic data type with a + -- Tetra-level data type definition. Although there is no data + -- type definition, we still represent the values of these types + -- in generic boxed form. + , contextForeignBoxedTypeCtors + :: Set E.Name + + , contextKindEnv :: KindEnv E.Name } + + +extendKindEnv :: Bind E.Name -> Context -> Context +extendKindEnv b ctx + = ctx { contextKindEnv = Env.extend b (contextKindEnv ctx) } + +extendsKindEnv :: [Bind E.Name] -> Context -> Context +extendsKindEnv bs ctx + = ctx { contextKindEnv = Env.extends bs (contextKindEnv ctx) } + + +-- | Convert the name of a Bind. +convertBindNameM :: E.Name -> ConvertM a A.Name +convertBindNameM nn + = case nn of + E.NameVar str + -> return $ A.NameVar str + + E.NameExt n str + -> do n' <- convertBindNameM n + return $ A.NameExt n' str + + _ -> throw $ ErrorInvalidBinder nn diff --git a/DDC/Core/Tetra/Convert/Type/DaCon.hs b/DDC/Core/Tetra/Convert/Type/DaCon.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Type/DaCon.hs @@ -0,0 +1,121 @@ + +module DDC.Core.Tetra.Convert.Type.DaCon + ( convertCtorT + , convertDaCon) +where +import DDC.Core.Tetra.Convert.Type.Kind +import DDC.Core.Tetra.Convert.Type.Data +import DDC.Core.Tetra.Convert.Type.Base +import DDC.Core.Tetra.Convert.Error +import DDC.Core.Exp.Annot.Exp +import DDC.Type.Compounds +import DDC.Type.Predicates +import DDC.Control.Monad.Check (throw) +import qualified DDC.Core.Tetra.Prim as E +import qualified DDC.Core.Salt.Name as A + + +-- Ctor Types ------------------------------------------------------------------------------------- +-- | Convert the type of a data constructor. +-- +-- The code to build data values is generated by the compiler so that it +-- always has as many parameters as there are function arguments in its +-- type. +-- +convertCtorT :: Context -> Type E.Name -> ConvertM a (Type A.Name) +convertCtorT ctx0 tt0 + = convertAbsType ctx0 tt0 + where + -- Accepting type abstractions -------------------- + convertAbsType ctx tt + = case tt of + TForall bParam tBody + -> convertConsType ctx bParam tBody + _ -> convertAbsValue ctx tt + + convertConsType ctx bParam tBody + -- Erase higher kinded type abstractions. + | Just _ <- takeKFun $ typeOfBind bParam + = do let ctx' = extendKindEnv bParam ctx + convertAbsType ctx' tBody + + -- Erase effect abstractions. + | isEffectKind $ typeOfBind bParam + = do let ctx' = extendKindEnv bParam ctx + convertAbsType ctx' tBody + + -- Retain region abstractions. + | isRegionKind $ typeOfBind bParam + = do bParam' <- convertTypeB bParam + let ctx' = extendKindEnv bParam ctx + tBody' <- convertCtorT ctx' tBody + return $ TForall bParam' tBody' + + -- Convert data type abstractions to region abstractions. + | isDataKind $ typeOfBind bParam + , BName (E.NameVar str) _ <- bParam + , str' <- str ++ "$r" + , bParam' <- BName (A.NameVar str') kRegion + = do let ctx' = extendKindEnv bParam ctx + tBody' <- convertAbsType ctx' tBody + return $ TForall bParam' tBody' + + -- Some other type that we can't convert. + | otherwise + = error "ddc-core-tetra.converCtorT: cannot convert type." + + + -- Accepting value abstractions ------------------- + convertAbsValue ctx tt + = case tt of + TApp{} + | Just (tParam, tBody) <- takeTFun tt + -> convertConsValue ctx tParam tBody + _ -> convertDataT ctx tt + + + convertConsValue ctx tParam tBody + = do tParam' <- convertDataT ctx tParam + tBody' <- convertAbsValue ctx tBody + return $ tFun tParam' tBody' + + +-- DaCon ------------------------------------------------------------------------------------------ +-- | Convert a data constructor definition. +convertDaCon :: Context -> DaCon E.Name -> ConvertM a (DaCon A.Name) +convertDaCon ctx dc + = case dc of + DaConUnit + -> return DaConUnit + + DaConPrim n t + -> do n' <- convertDaConNameM dc n + t' <- convertCtorT ctx t + return $ DaConPrim + { daConName = n' + , daConType = t' } + + DaConBound n + -> do n' <- convertDaConNameM dc n + return $ DaConBound + { daConName = n' } + + +-- | Convert the name of a data constructor. +convertDaConNameM :: DaCon E.Name -> E.Name -> ConvertM a A.Name +convertDaConNameM dc nn + = case nn of + E.NameLitUnboxed (E.NameLitBool val) + -> return $ A.NamePrimLit $ A.PrimLitBool val + + E.NameLitUnboxed (E.NameLitNat val) + -> return $ A.NamePrimLit $ A.PrimLitNat val + + E.NameLitUnboxed (E.NameLitInt val) + -> return $ A.NamePrimLit $ A.PrimLitInt val + + E.NameLitUnboxed (E.NameLitWord val bits) + -> return $ A.NamePrimLit $ A.PrimLitWord val bits + + _ -> throw $ ErrorInvalidDaCon dc + diff --git a/DDC/Core/Tetra/Convert/Type/Data.hs b/DDC/Core/Tetra/Convert/Type/Data.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Type/Data.hs @@ -0,0 +1,256 @@ + +module DDC.Core.Tetra.Convert.Type.Data + ( convertDataB + , convertDataU + , convertDataT + , convertDataPrimitiveT) +where +import DDC.Core.Tetra.Convert.Type.Region +import DDC.Core.Tetra.Convert.Type.Base +import DDC.Core.Tetra.Convert.Boxing +import DDC.Core.Tetra.Convert.Error +import DDC.Core.Exp.Annot.Exp +import DDC.Type.DataDef +import DDC.Type.Compounds +import DDC.Type.Predicates +import DDC.Control.Monad.Check (throw) +import qualified DDC.Core.Tetra.Prim as E +import qualified DDC.Core.Salt.Compounds as A +import qualified DDC.Core.Salt.Runtime as A +import qualified DDC.Core.Salt.Name as A +import qualified DDC.Core.Salt.Env as A +import qualified DDC.Type.Env as Env +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Monad +import DDC.Base.Pretty + + +-- | Convert a value binder with a representable type. +-- This is used for the binders of function arguments, which must have +-- representatable types to adhere to some calling convention. +convertDataB :: Context -> Bind E.Name -> ConvertM a (Bind A.Name) +convertDataB ctx bb + = case bb of + BNone t -> liftM BNone (convertDataT ctx t) + BAnon t -> liftM BAnon (convertDataT ctx t) + BName n t -> liftM2 BName (convertBindNameM n) (convertDataT ctx t) + + +-- | Convert a value bound. +-- These refer to function arguments or let-bound values, +-- and hence must have representable types. +convertDataU :: Bound E.Name -> ConvertM a (Maybe (Bound A.Name)) +convertDataU uu + = case uu of + UIx i + -> return $ Just $ UIx i + + UName n + -> do n' <- convertBindNameM n + return $ Just $ UName n' + + -- When converting primops, use the type directly specified by the + -- Salt language instead of converting it from Tetra. The types from + -- each language definition may not be inter-convertible. + UPrim n _ + -> case n of + E.NamePrimArith op True + -> return + $ Just $ UPrim (A.NamePrimOp (A.PrimArith op)) + (A.typeOfPrimArith op) + + E.NamePrimCast op + -> return + $ Just $ UPrim (A.NamePrimOp (A.PrimCast op)) + (A.typeOfPrimCast op) + + _ -> return Nothing + + +-- | Convert a value type from Core Tetra to Core Salt. +-- +-- Value types have kind Data and can be passed to, and returned from +-- functions. Functional types themselves are converted to generic +-- boxed form (Ptr# rTop Obj#) +-- +convertDataT :: Context -> Type E.Name -> ConvertM a (Type A.Name) +convertDataT ctx tt + = case tt of + -- Convert value type variables and constructors. + TVar u + -> case Env.lookup u (contextKindEnv ctx) of + Just k + -- Parametric data types are represented as generic objects, + -- where the region those objects are in is named after the + -- original type name. + | isDataKind k + -> return $ A.tPtr A.rTop A.tObj + + | otherwise + -> throw $ ErrorMalformed + $ "Invalid value type " ++ (renderIndent $ ppr tt) + + Nothing + -> throw $ ErrorUnbound u + + -- We should not find any polymorphic values. + TForall{} -> throw $ ErrorMalformed + $ "Invalid polymorphic value type." + + -- Convert unapplied type constructors. + TCon{} -> convertDataAppT ctx tt + + -- Convert type constructor applications. + TApp{} -> convertDataAppT ctx tt + + -- Resentable types always have kind Data, but type sums cannot. + TSum{} -> throw $ ErrorUnexpectedSum + + +-- | Convert some data type from Core Tetra to Core Salt. +convertDataAppT :: Context -> Type E.Name -> ConvertM a (Type A.Name) +convertDataAppT ctx tt + + -- Ambient TyCons --------------------------------- + -- The Unit type. + | Just (TyConSpec TcConUnit, []) <- takeTyConApps tt + = return $ A.tPtr A.rTop A.tObj + + -- The Suspended computation type. + | Just (TyConSpec TcConSusp, [_tEff, tResult]) <- takeTyConApps tt + = do convertDataT ctx tResult + + + -- Primitive TyCons ------------------------------- + -- We don't handle the numeric types here, because they should have + -- been converted to explicitly unboxed form by the boxing transform. + + -- The Void# type. + | Just (E.NamePrimTyCon E.PrimTyConVoid, []) <- takePrimTyConApps tt + = return A.tVoid + + -- The Ptr# type. + | Just ( E.NamePrimTyCon E.PrimTyConPtr + , [_tR, _tA]) <- takePrimTyConApps tt + = do return $ A.tPtr A.rTop A.tObj + + + -- Numeric TyCons --------------------------------- + -- These are represented in boxed form. + | Just (E.NamePrimTyCon n, []) <- takePrimTyConApps tt + , True <- case n of + E.PrimTyConBool -> True + E.PrimTyConNat -> True + E.PrimTyConInt -> True + E.PrimTyConWord _ -> True + _ -> False + = return $ A.tPtr A.rTop A.tObj + + + -- Tetra TyCons ----------------------------------- + + -- Explicitly unboxed numeric types. + -- In Salt, unboxed numeric values are represented directly as + -- values of the corresponding machine type. + | Just ( E.NameTyConTetra E.TyConTetraU + , [tNum]) <- takePrimTyConApps tt + , isNumericType tNum + = do tNum' <- convertDataPrimitiveT tNum + return tNum' + + -- Explicitly unboxed text literals. + -- These are represented as pointers to static memory. + | Just ( E.NameTyConTetra E.TyConTetraU + , [tStr]) <- takePrimTyConApps tt + , isTextLitType tStr + = do return $ A.tPtr A.rTop (A.tWord 8) + + -- The F# type (reified function) + | Just ( E.NameTyConTetra E.TyConTetraF + , [_]) <- takePrimTyConApps tt + = return $ A.tPtr A.rTop A.tObj + + -- The C# type (reified function) + | Just ( E.NameTyConTetra E.TyConTetraC + , [_]) <- takePrimTyConApps tt + = return $ A.tPtr A.rTop A.tObj + + -- Boxed text literals. + -- The box holds a pointer to the string data. + | Just (E.NamePrimTyCon E.PrimTyConTextLit, []) + <- takePrimTyConApps tt + = return $ A.tPtr A.rTop A.tObj + + + -- Boxed functions -------------------------------- + | Just _ <- takeTFun tt + = return $ A.tPtr A.rTop A.tObj + + + -- Boxed vectors of unboxed values----------------- + | Just ( E.NameTyConTetra E.TyConTetraVector + , [_, _]) <- takePrimTyConApps tt + = return $ A.tPtr A.rTop A.tObj + + + -- Foreign boxed data types ----------------------- + -- If these have a primary region then we use that, + -- otherwise they are represnted in generic boxed form. + | Just (TyConBound (UName n) _, args) <- takeTyConApps tt + , Set.member n (contextForeignBoxedTypeCtors ctx) + = case args of + tR : _ + | TVar u <- tR + , Just k <- Env.lookup u (contextKindEnv ctx) + , isRegionKind k + -> do tR' <- convertRegionT ctx tR + return $ A.tPtr tR' A.tObj + + _ -> return $ A.tPtr A.rTop A.tObj + + + -- User defined TyCons ---------------------------- + -- A user-defined data type with a primary region. + -- These are converted to generic boxed objects in the same region. + | Just (TyConBound (UName n) _, tR : _args) <- takeTyConApps tt + , Map.member n (dataDefsTypes $ contextDataDefs ctx) + , TVar u <- tR + , Just k <- Env.lookup u (contextKindEnv ctx) + , isRegionKind k + = do tR' <- convertRegionT ctx tR + return $ A.tPtr tR' A.tObj + + -- A user-defined data type without a primary region. + -- These are converted to generic boxed objects in the top-level region. + | Just (TyConBound (UName n) _, _) <- takeTyConApps tt + , Map.member n (dataDefsTypes $ contextDataDefs ctx) + = do return $ A.tPtr A.rTop A.tObj + + | otherwise + = throw $ ErrorMalformed + $ "Invalid type constructor application " + ++ (renderIndent $ ppr tt) + + +-- | Convert a primitive type directly to its Salt form. +convertDataPrimitiveT :: Type E.Name -> ConvertM a (Type A.Name) +convertDataPrimitiveT tt + | Just (E.NamePrimTyCon n, []) <- takePrimTyConApps tt + = case n of + E.PrimTyConBool -> return $ A.tBool + E.PrimTyConNat -> return $ A.tNat + E.PrimTyConInt -> return $ A.tInt + E.PrimTyConSize -> return $ A.tSize + E.PrimTyConWord bits -> return $ A.tWord bits + E.PrimTyConFloat bits -> return $ A.tFloat bits + + E.PrimTyConTextLit -> return $ A.tTextLit + + _ -> throw $ ErrorMalformed + $ "Invalid primitive type " ++ (renderIndent $ ppr tt) + + | otherwise + = throw $ ErrorMalformed + $ "Invalid primitive type " ++ (renderIndent $ ppr tt) + diff --git a/DDC/Core/Tetra/Convert/Type/Kind.hs b/DDC/Core/Tetra/Convert/Type/Kind.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Type/Kind.hs @@ -0,0 +1,53 @@ + +module DDC.Core.Tetra.Convert.Type.Kind + ( convertTypeB + , convertTypeU + , convertK) +where +import DDC.Core.Tetra.Convert.Type.Base +import DDC.Core.Tetra.Convert.Error +import DDC.Type.Exp +import DDC.Base.Pretty +import DDC.Control.Monad.Check (throw) +import Control.Monad +import qualified DDC.Core.Tetra.Prim as E +import qualified DDC.Core.Salt.Name as A + + +-- | Convert a type binder. +-- These are formal type parameters. +convertTypeB :: Bind E.Name -> ConvertM a (Bind A.Name) +convertTypeB bb + = case bb of + BNone k -> liftM BNone (convertK k) + BAnon k -> liftM BAnon (convertK k) + BName n k -> liftM2 BName (convertBindNameM n) (convertK k) + + +-- | Convert a type bound. +-- These are bound by formal type parametrs. +convertTypeU :: Bound E.Name -> ConvertM a (Bound A.Name) +convertTypeU uu + = case uu of + UIx i + -> return $ UIx i + + UName (E.NameVar str) + -> return $ UName (A.NameVar str) + + UPrim (E.NameVar str) k + -> do k' <- convertK k + return $ UPrim (A.NameVar str) k' + + _ -> throw $ ErrorMalformed + $ "Invalid type bound " ++ (renderIndent $ ppr uu) + +-- | Convert a kind from Core Tetra to Core Salt. +convertK :: Kind E.Name -> ConvertM a (Kind A.Name) +convertK kk + | TCon (TyConKind kc) <- kk + = return $ TCon (TyConKind kc) + + | otherwise + = throw $ ErrorMalformed + $ "Invalid kind " ++ (renderIndent $ ppr kk) diff --git a/DDC/Core/Tetra/Convert/Type/Region.hs b/DDC/Core/Tetra/Convert/Type/Region.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Type/Region.hs @@ -0,0 +1,99 @@ + +module DDC.Core.Tetra.Convert.Type.Region + ( convertRegionT + , saltPrimeRegionOfDataType) +where +import DDC.Core.Tetra.Convert.Type.Base +import DDC.Core.Tetra.Convert.Error +import DDC.Core.Exp.Annot.Exp +import DDC.Type.Env +import DDC.Type.Compounds +import DDC.Type.Predicates +import DDC.Control.Monad.Check (throw) +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.Type.Env as Env +import DDC.Base.Pretty + + +-- Region Types ----------------------------------------------------------------------------------- +-- | Convert a region type to Salt. +convertRegionT :: Context -> Type E.Name -> ConvertM a (Type A.Name) +convertRegionT ctx tt + | TVar u <- tt + , Just k <- Env.lookup u (contextKindEnv ctx) + , isRegionKind k + = return $ A.rTop + + | otherwise + = throw $ ErrorMalformed + $ "Invalid region type " ++ (renderIndent $ ppr tt) + + +-- Prime Region ----------------------------------------------------------------------------------- +-- | Given the type of some data value, determine what prime region to use +-- for the object in the Salt language. The supplied type must have kind +-- Data, else you'll get a bogus result. +-- +-- Boxed data types whose first parameter is a region, by convention that +-- region is the prime one. +-- List r1 a => r1 +-- +-- Boxed data types that do not have a region as the first parameter, +-- these are allocated into the top-level region. +-- Unit => rTop +-- B# Nat# => rTop +-- +-- Functions are also allocated into the top-level region. +-- a -> b => rTop +-- forall ... => rTop +-- +-- For completely parametric data types we use a region named after the +-- associated type variable. +-- a => a$r +-- +-- For types with an abstract constructor, we currently reject them outright. +-- There's no way to tell what region an object of such a type should be +-- allocated into. In future we should add a supertype of regions, and treat +-- such objects as belong to the Any region. +-- See [Note: Salt conversion for higher kinded type arguments] +-- c a b => ** NOTHING ** +-- +-- Unboxed and index types don't refer to boxed objects, so they don't have +-- associated prime regions. +-- Nat# => ** NOTHING ** +-- U# Nat# => ** NOTHING ** +-- +saltPrimeRegionOfDataType + :: KindEnv E.Name + -> Type E.Name + -> ConvertM a (Type A.Name) + +saltPrimeRegionOfDataType kenv tt + -- Boxed data types with an attached primary region variable. + | TCon _ : TVar u : _ <- takeTApps tt + , Just k <- Env.lookup u kenv + , isRegionKind k + = do -- u' <- convertTypeU u + return A.rTop + + -- Boxed data types without an attached primary region variable. + -- This also covers the function case. + | TCon _ : _ <- takeTApps tt + = do return A.rTop + + -- Quantified types. + | TForall{} <- tt + = do return A.rTop + + -- Completely parametric data types. + | TVar u <- tt + , Just k <- Env.lookup u kenv + , isDataKind k + = do return A.rTop + + | otherwise + = throw $ ErrorMalformed + $ "Cannot take prime region from " ++ (renderIndent $ ppr tt) + diff --git a/DDC/Core/Tetra/Convert/Type/Super.hs b/DDC/Core/Tetra/Convert/Type/Super.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Type/Super.hs @@ -0,0 +1,85 @@ + +module DDC.Core.Tetra.Convert.Type.Super + (convertSuperConsT) +where +import DDC.Core.Tetra.Convert.Type.Kind +import DDC.Core.Tetra.Convert.Type.Data +import DDC.Core.Tetra.Convert.Type.Base +import DDC.Core.Tetra.Convert.Error +import DDC.Core.Call +import DDC.Core.Exp.Annot.Exp +import DDC.Type.Compounds +import DDC.Type.Predicates +import qualified DDC.Core.Tetra.Prim as E +import qualified DDC.Core.Salt.Name as A + + +-- | Convert the Tetra type of a super with the given call pattern to Salt. +-- +-- This type conversion mirrors the `convertSuperXT` conversion function +-- except that we only know the call pattern of the function, rather than +-- its defining expression. +-- +convertSuperConsT + :: Context + -> [Cons E.Name] + -> Type E.Name + -> ConvertM a (Type A.Name) + +convertSuperConsT ctx0 cs0 tt0 + = convertAbsType ctx0 cs0 tt0 + where + -- Accepting type abstractions -------------------- + convertAbsType ctx cs tt + = case cs of + ConsType _k : cs' + | TForall bParam tBody <- tt + -> convertConsType ctx bParam cs' tBody + _ -> convertAbsValue ctx cs tt + + convertConsType ctx bParam cs tBody + -- Erase higher kinded type abstractions. + | Just _ <- takeKFun $ typeOfBind bParam + = do let ctx' = extendKindEnv bParam ctx + convertAbsType ctx' cs tBody + + -- Erase effect abstractions. + | isEffectKind $ typeOfBind bParam + = do let ctx' = extendKindEnv bParam ctx + convertAbsType ctx' cs tBody + + -- Retain region abstractions. + | isRegionKind $ typeOfBind bParam + = do bParam' <- convertTypeB bParam + let ctx' = extendKindEnv bParam ctx + tBody' <- convertAbsType ctx' cs tBody + return $ TForall bParam' tBody' + + -- Convert data type abstractions to region abstractions. + | isDataKind $ typeOfBind bParam + , BName (E.NameVar str) _ <- bParam + , str' <- str ++ "$r" + , bParam' <- BName (A.NameVar str') kRegion + = do let ctx' = extendKindEnv bParam ctx + tBody' <- convertAbsType ctx' cs tBody + return $ TForall bParam' tBody' + + -- Some other type abstraction we can't convert. + | otherwise + = error "ddc-core-tetra.convertSuperConsT: cannot convert type abstraction." + + + -- Accepting value abstractions ------------------- + convertAbsValue ctx cs tt + = case cs of + ConsValue tParam : cs' + | Just (_tArg, tBody) <- takeTFun tt + -> convertConsValue ctx tParam cs' tBody + _ -> convertDataT ctx tt + + + convertConsValue ctx tParam cs tBody + = do tParam' <- convertDataT ctx tParam + tBody' <- convertAbsValue ctx cs tBody + return $ tFun tParam' tBody' + diff --git a/DDC/Core/Tetra/Convert/Type/Witness.hs b/DDC/Core/Tetra/Convert/Type/Witness.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Type/Witness.hs @@ -0,0 +1,43 @@ + +module DDC.Core.Tetra.Convert.Type.Witness + ( convertCapabilityB + , convertCapabilityT) +where +import DDC.Core.Tetra.Convert.Type.Region +import DDC.Core.Tetra.Convert.Type.Base +import DDC.Core.Tetra.Convert.Error +import DDC.Core.Exp.Annot.Exp +import DDC.Type.Compounds +import DDC.Control.Monad.Check (throw) +import qualified DDC.Core.Tetra.Prim as E +import qualified DDC.Core.Salt.Name as A +import Control.Monad +import DDC.Base.Pretty + + +-- | Convert a witness binder. +convertCapabilityB :: Context -> Bind E.Name -> ConvertM a (Bind A.Name) +convertCapabilityB ctx bb + = case bb of + BNone t -> liftM BNone (convertCapabilityT ctx t) + BAnon t -> liftM BAnon (convertCapabilityT ctx t) + BName n t -> liftM2 BName (convertBindNameM n) (convertCapabilityT ctx t) + + +-- | Convert a capability / coeffect type to Salt. +-- Works for Read#, Write#, Alloc# +convertCapabilityT :: Context -> Type E.Name -> ConvertM a (Type A.Name) +convertCapabilityT ctx tt + | Just (TyConSpec tc, [tR]) <- takeTyConApps tt + = do tR' <- convertRegionT ctx tR + case tc of + TcConRead -> return $ tRead tR' + TcConWrite -> return $ tWrite tR' + TcConAlloc -> return $ tAlloc tR' + _ -> throw $ ErrorMalformed + $ "Malformed capability type " ++ (renderIndent $ ppr tt) + + | otherwise + = throw $ ErrorMalformed + $ "Malformed capability type " ++ (renderIndent $ ppr tt) + diff --git a/DDC/Core/Tetra/Env.hs b/DDC/Core/Tetra/Env.hs --- a/DDC/Core/Tetra/Env.hs +++ b/DDC/Core/Tetra/Env.hs @@ -3,7 +3,9 @@ ( primDataDefs , primSortEnv , primKindEnv - , primTypeEnv) + , primTypeEnv + + , dataDefBool) where import DDC.Core.Tetra.Prim import DDC.Core.Tetra.Compounds @@ -27,11 +29,7 @@ primDataDefs = fromListDataDefs -- Primitive ----------------------------------------------- - -- Bool# - $ [ makeDataDefAlg (NamePrimTyCon PrimTyConBool) - [] - (Just [ (NameLitBool True, []) - , (NameLitBool False, []) ]) + $ [ dataDefBool -- Nat# , makeDataDefAlg (NamePrimTyCon PrimTyConNat) [] Nothing @@ -45,8 +43,19 @@ , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 16)) [] Nothing , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 8)) [] Nothing - -- Ref# - , makeDataDefAbs (NameTyConTetra TyConTetraRef) [] + -- FloatN# + , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 64)) [] Nothing + , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 32)) [] Nothing + + -- TextLit# + , makeDataDefAlg (NamePrimTyCon PrimTyConTextLit) [] Nothing + + -- Vector# + , makeDataDefAlg (NameTyConTetra TyConTetraVector) [] Nothing + + -- U# + -- We need this data def when matching against literals with case expressions. + , makeDataDefAlg (NameTyConTetra TyConTetraU) [] Nothing ] -- Tuple @@ -54,8 +63,17 @@ -- We don't have a way of avoiding the upper bound. ++ [ makeTupleDataDef arity | arity <- [2..32] ] - + +-- | Data type definition for `Bool`. +dataDefBool :: DataDef Name +dataDefBool + = makeDataDefAlg (NamePrimTyCon PrimTyConBool) + [] + (Just [ (NameLitBool True, []) + , (NameLitBool False, []) ]) + + -- | Make a tuple data def for the given tuple arity. makeTupleDataDef :: Int -> DataDef Name makeTupleDataDef n @@ -92,6 +110,7 @@ = case nn of NameTyConTetra tc -> Just $ kindTyConTetra tc NamePrimTyCon tc -> Just $ kindPrimTyCon tc + NameVar "rT" -> Just $ kRegion _ -> Nothing @@ -106,15 +125,26 @@ typeOfPrimName :: Name -> Maybe (Type Name) typeOfPrimName dc = case dc of - NameDaConTetra p -> Just $ typeDaConTetra p - NameOpStore p -> Just $ typeOpStore p - NamePrimArith p -> Just $ typePrimArith p - NamePrimCast p -> Just $ typePrimCast p + NameDaConTetra p -> Just $ typeDaConTetra p + NameOpFun p -> Just $ typeOpFun p + NameOpVector p f -> Just $ typeOpVectorFlag p f + NameOpError p f -> Just $ typeOpErrorFlag p f + NamePrimArith p f -> Just $ typePrimArithFlag p f + NamePrimCast p -> Just $ typePrimCast p - NameLitBool _ -> Just $ tBool - NameLitNat _ -> Just $ tNat - NameLitInt _ -> Just $ tInt - NameLitWord _ bits -> Just $ tWord bits + NameLitBool _ -> Just $ tBool + NameLitNat _ -> Just $ tNat + NameLitInt _ -> Just $ tInt + NameLitWord _ bits -> Just $ tWord bits + NameLitFloat _ bits -> Just $ tFloat bits + NameLitTextLit _ -> Just $ tTextLit - _ -> Nothing + NameLitUnboxed NameLitBool{} -> Just $ tUnboxed tBool + NameLitUnboxed NameLitNat{} -> Just $ tUnboxed tNat + NameLitUnboxed NameLitInt{} -> Just $ tUnboxed tInt + NameLitUnboxed (NameLitWord _ bits) -> Just $ tUnboxed (tWord bits) + NameLitUnboxed (NameLitFloat _ bits) -> Just $ tUnboxed (tFloat bits) + NameLitUnboxed NameLitTextLit{} -> Just $ tUnboxed tTextLit + + _ -> Nothing diff --git a/DDC/Core/Tetra/Error.hs b/DDC/Core/Tetra/Error.hs --- a/DDC/Core/Tetra/Error.hs +++ b/DDC/Core/Tetra/Error.hs @@ -31,3 +31,4 @@ = vcat [ text "Invalid type of main function in Main module." , text " Type of main function: " <> ppr t , text " is not an instance of: [e : Effect]. Unit -> S e Unit" ] + diff --git a/DDC/Core/Tetra/Prim.hs b/DDC/Core/Tetra/Prim.hs --- a/DDC/Core/Tetra/Prim.hs +++ b/DDC/Core/Tetra/Prim.hs @@ -4,6 +4,7 @@ Name (..) , isNameHole , isNameLit + , isNameLitUnboxed , readName , takeTypeOfLitName , takeTypeOfPrimOpName @@ -12,26 +13,41 @@ , TyConTetra (..) , readTyConTetra , kindTyConTetra + , tTupleN, tUnboxed, tFunValue, tCloValue, tTextLit -- * Baked-in data constructors. , DaConTetra (..) , readDaConTetra , typeDaConTetra + , xTuple2 + , dcTuple2 + , dcTupleN - -- * Baked-in store operators. - , OpStore (..) - , readOpStore - , typeOpStore + -- * Baked-in function operators. + , OpFun (..) + , readOpFun + , typeOpFun + -- * Baked-in vector operators. + , OpVector (..) + , readOpVectorFlag + , typeOpVectorFlag + + --- * Baked-in error handling. + , OpError (..) + , readOpErrorFlag + , typeOpErrorFlag + -- * Primitive type constructors. , PrimTyCon (..) - , readPrimTyCon + , pprPrimTyConStem + , readPrimTyCon, readPrimTyConStem , kindPrimTyCon -- * Primitive arithmetic operators. , PrimArith (..) - , readPrimArith - , typePrimArith + , readPrimArithFlag + , typePrimArithFlag -- * Primitive numeric casts. , PrimCast (..) @@ -42,40 +58,53 @@ import DDC.Core.Tetra.Prim.TyConTetra import DDC.Core.Tetra.Prim.TyConPrim import DDC.Core.Tetra.Prim.DaConTetra -import DDC.Core.Tetra.Prim.OpStore +import DDC.Core.Tetra.Prim.OpError import DDC.Core.Tetra.Prim.OpArith import DDC.Core.Tetra.Prim.OpCast -import DDC.Core.Salt.Name - ( readLitPrimNat - , readLitPrimInt - , readLitPrimWordOfBits) - +import DDC.Core.Tetra.Prim.OpFun +import DDC.Core.Tetra.Prim.OpVector +import DDC.Data.ListUtils import DDC.Type.Exp import DDC.Base.Pretty +import DDC.Base.Name import Control.DeepSeq import Data.Char +import qualified Data.Text as T +import DDC.Core.Lexer.Names (isVarStart) +import DDC.Core.Salt.Name + ( readLitNat + , readLitInt + , readLitWordOfBits) instance NFData Name where rnf nn = case nn of NameVar s -> rnf s NameCon s -> rnf s - + NameExt n s -> rnf n `seq` rnf s + NameTyConTetra con -> rnf con NameDaConTetra con -> rnf con - NameOpStore op -> rnf op + NameOpError op !_ -> rnf op + NameOpFun op -> rnf op + NameOpVector op !_ -> rnf op NamePrimTyCon op -> rnf op - NamePrimArith op -> rnf op + NamePrimArith op !_ -> rnf op NamePrimCast op -> rnf op - NameLitBool b -> rnf b - NameLitNat n -> rnf n - NameLitInt i -> rnf i - NameLitWord i bits -> rnf i `seq` rnf bits + NameLitBool b -> rnf b + NameLitNat n -> rnf n + NameLitInt i -> rnf i + NameLitSize s -> rnf s + NameLitWord i bits -> rnf i `seq` rnf bits + NameLitFloat d bits -> rnf d `seq` rnf bits + NameLitTextLit bs -> rnf bs + NameLitUnboxed n -> rnf n + NameHole -> () @@ -84,24 +113,51 @@ = case nn of NameVar v -> text v NameCon c -> text c + NameExt n s -> ppr n <> text "$" <> text s NameTyConTetra tc -> ppr tc NameDaConTetra dc -> ppr dc - NameOpStore op -> ppr op + + NameOpError op False -> ppr op + NameOpError op True -> ppr op <> text "#" + + NameOpFun op -> ppr op + + NameOpVector op False -> ppr op + NameOpVector op True -> ppr op <> text "#" + NamePrimTyCon op -> ppr op - NamePrimArith op -> ppr op + + NamePrimArith op False -> ppr op + NamePrimArith op True -> ppr op <> text "#" + NamePrimCast op -> ppr op NameLitBool True -> text "True#" NameLitBool False -> text "False#" - NameLitNat i -> integer i <> text "#" - NameLitInt i -> integer i <> text "i" <> text "#" - NameLitWord i bits -> integer i <> text "w" <> int bits <> text "#" + NameLitNat i -> integer i + NameLitInt i -> integer i <> text "i" + NameLitSize s -> integer s <> text "s" + NameLitWord i bits -> integer i <> text "w" <> int bits + NameLitFloat f bits -> double f <> text "f" <> int bits + NameLitTextLit tx -> text (show $ T.unpack tx) + NameLitUnboxed n -> ppr n <> text "#" + NameHole -> text "?" +instance CompoundName Name where + extendName n str + = NameExt n str + + splitName nn + = case nn of + NameExt n str -> Just (n, str) + _ -> Nothing + + -- | Read the name of a variable, constructor or literal. readName :: String -> Maybe Name readName str @@ -112,36 +168,52 @@ | Just p <- readDaConTetra str = Just $ NameDaConTetra p - | Just p <- readOpStore str - = Just $ NameOpStore p + | Just (p,f) <- readOpErrorFlag str + = Just $ NameOpError p f + | Just p <- readOpFun str + = Just $ NameOpFun p + + | Just (p, f) <- readOpVectorFlag str + = Just $ NameOpVector p f + -- Primitive names. | Just p <- readPrimTyCon str = Just $ NamePrimTyCon p - | Just p <- readPrimArith str - = Just $ NamePrimArith p + | Just (p, f) <- readPrimArithFlag str + = Just $ NamePrimArith p f | Just p <- readPrimCast str = Just $ NamePrimCast p -- Literal Bools - | str == "True#" = Just $ NameLitBool True - | str == "False#" = Just $ NameLitBool False + | str == "True" = Just $ NameLitBool True + | str == "False" = Just $ NameLitBool False -- Literal Nat - | Just val <- readLitPrimNat str + | Just val <- readLitNat str = Just $ NameLitNat val -- Literal Ints - | Just val <- readLitPrimInt str + | Just val <- readLitInt str = Just $ NameLitInt val -- Literal Words - | Just (val, bits) <- readLitPrimWordOfBits str + | Just (val, bits) <- readLitWordOfBits str , elem bits [8, 16, 32, 64] = Just $ NameLitWord val bits + -- Unboxed literals. + | Just base <- stripSuffix "#" str + , Just n <- readName base + = case n of + NameLitBool{} -> Just n + NameLitNat{} -> Just n + NameLitInt{} -> Just n + NameLitWord{} -> Just n + _ -> Nothing + -- Holes | str == "?" = Just $ NameHole @@ -153,7 +225,7 @@ -- Variables. | c : _ <- str - , isLower c + , isVarStart c = Just $ NameVar str | otherwise @@ -167,7 +239,9 @@ NameLitBool{} -> Just tBool NameLitNat{} -> Just tNat NameLitInt{} -> Just tInt - NameLitWord _ bits -> Just (tWord bits) + NameLitWord _ bits -> Just (tWord bits) + NameLitFloat _ bits -> Just (tFloat bits) + NameLitTextLit _ -> Just tTextLit _ -> Nothing @@ -175,8 +249,10 @@ takeTypeOfPrimOpName :: Name -> Maybe (Type Name) takeTypeOfPrimOpName nn = case nn of - NameOpStore op -> Just (typeOpStore op) - NamePrimArith op -> Just (typePrimArith op) - NamePrimCast op -> Just (typePrimCast op) - _ -> Nothing + NameOpError op f -> Just (typeOpErrorFlag op f) + NameOpFun op -> Just (typeOpFun op) + NameOpVector op f -> Just (typeOpVectorFlag op f) + NamePrimArith op f -> Just (typePrimArithFlag op f) + NamePrimCast op -> Just (typePrimCast op) + _ -> Nothing diff --git a/DDC/Core/Tetra/Prim/Base.hs b/DDC/Core/Tetra/Prim/Base.hs --- a/DDC/Core/Tetra/Prim/Base.hs +++ b/DDC/Core/Tetra/Prim/Base.hs @@ -3,15 +3,19 @@ ( Name (..) , isNameHole , isNameLit + , isNameLitUnboxed , TyConTetra (..) , DaConTetra (..) - , OpStore (..) + , OpError (..) + , OpFun (..) + , OpVector (..) , PrimTyCon (..) , PrimArith (..) , PrimCast (..)) where import Data.Typeable +import Data.Text (Text) import DDC.Core.Salt.Name ( PrimTyCon (..) , PrimArith (..) @@ -21,43 +25,79 @@ -- | Names of things used in Disciple Core Tetra. data Name -- | User defined variables. - = NameVar String + = NameVar !String -- | A user defined constructor. - | NameCon String + | NameCon !String + -- | An extended name. + | NameExt !Name !String + -- | Baked-in type constructors. - | NameTyConTetra TyConTetra + | NameTyConTetra !TyConTetra -- | Baked-in data constructors. - | NameDaConTetra DaConTetra + | NameDaConTetra !DaConTetra - -- | Baked-in operators. - | NameOpStore OpStore + -- | Baked-in runtime error reporting. + -- The flag indicates whether this is the + -- boxed (False) or unboxed (True) version. + | NameOpError !OpError !Bool + -- | Baked-in function operators. + | NameOpFun !OpFun + + -- | Baked-in vector operators. + -- The flag indicates whether this is the + -- boxed (False) or unboxed (True) version. + | NameOpVector !OpVector !Bool + -- Machine primitives ------------------ -- | A primitive type constructor. - | NamePrimTyCon PrimTyCon + | NamePrimTyCon !PrimTyCon - -- | Primitive arithmetic, logic, comparison and bit-wise operators. - | NamePrimArith PrimArith + -- | Primitive arithmetic, logic, comparison and + -- bit-wise operators. + -- The flag indicates whether this is the boxed + -- (False) or unboxed (True) version. + | NamePrimArith !PrimArith !Bool -- | Primitive numeric casting operators. - | NamePrimCast PrimCast + | NamePrimCast !PrimCast -- Literals ----------------------------- -- | A boolean literal. - | NameLitBool Bool + | NameLitBool !Bool - -- | A natural literal. - | NameLitNat Integer + -- | A natural literal, + -- with enough precision to count every heap object. + | NameLitNat !Integer - -- | An integer literal. - | NameLitInt Integer + -- | An integer literal, + -- with enough precision to count every heap object. + | NameLitInt !Integer - -- | A word literal. - | NameLitWord Integer Int + -- | An unsigned size literal, + -- with enough precision to count every addressable byte of memory. + | NameLitSize !Integer + -- | A word literal, + -- with the given number of bits precision. + | NameLitWord !Integer !Int + + -- | A floating point literal, + -- with the given number of bits precision. + | NameLitFloat !Double !Int + + -- | A text literal (UTF-8 encoded) + -- Note that 'Text' and 'TextLit#' are different types. + -- The later is the primitive literal. + | NameLitTextLit !Text + + -- Wrappers ----------------------------- + -- | Wrapper to indicate an explicitly unboxed literal. + | NameLitUnboxed !Name + -- Inference ---------------------------- -- | Hole used during type inference. | NameHole @@ -68,37 +108,51 @@ isNameHole :: Name -> Bool isNameHole nn = case nn of - NameHole -> True - _ -> False + NameHole -> True + _ -> False -- | Check whether a name represents some literal value. isNameLit :: Name -> Bool isNameLit nn = case nn of - NameLitBool{} -> True - NameLitNat{} -> True - NameLitInt{} -> True - NameLitWord{} -> True - _ -> False + NameLitBool{} -> True + NameLitNat{} -> True + NameLitInt{} -> True + NameLitSize{} -> True + NameLitWord{} -> True + NameLitFloat{} -> True + NameLitTextLit{} -> True + NameLitUnboxed n -> isNameLit n + _ -> False +-- | Check whether a name is an unboxed literal. +isNameLitUnboxed :: Name -> Bool +isNameLitUnboxed nn + = case nn of + NameLitUnboxed n -> isNameLit n + _ -> False + + -- TyConTetra ---------------------------------------------------------------- -- | Baked-in type constructors. data TyConTetra - -- | @Ref#@. Mutable reference. - = TyConTetraRef - -- | @TupleN#@. Tuples. - | TyConTetraTuple Int + = TyConTetraTuple Int - -- | @B#@. Boxing type constructor. - -- Used to represent boxed numeric values. - | TyConTetraB + -- | @Vector#@. Vectors of unboxed values. + | TyConTetraVector - -- | @U#@. Unboxed type constructor. + -- | @U#@ Unboxed type constructor. -- Used to represent unboxed numeric values. | TyConTetraU + + -- | @F#@ Reified function value. + | TyConTetraF + + -- | @C#@ Reified function closure. + | TyConTetraC deriving (Eq, Ord, Show) @@ -110,11 +164,56 @@ deriving (Eq, Ord, Show) --- OpStore ------------------------------------------------------------------- --- | Mutable References. -data OpStore - = OpStoreAllocRef -- ^ Allocate a reference. - | OpStoreReadRef -- ^ Read a reference. - | OpStoreWriteRef -- ^ Write to a reference. +-- OpError -------------------------------------------------------------------- +-- | Operators for runtime error reporting. +data OpError + -- | Raise an error due to inexhaustive case expressions. + = OpErrorDefault + deriving (Eq, Ord, Show) + + +-- OpFun ---------------------------------------------------------------------- +-- | Operators for building function values and closures. +-- The implicit versions work on functions of type (a -> b), +-- while the explicit versions use expliciy closure types like C# (a -> b). +data OpFun + -- | Partially apply a supecombinator to some arguments, producing + -- an implicitly typed closure. + = OpFunCurry Int + + -- | Apply an implicitly typed closure to some more arguments. + | OpFunApply Int + + -- | Reify a function into an explicit functional value. + | OpFunCReify + + -- | Apply an explicit functional value to some arguments, + -- producing an explicitly typed closure. + | OpFunCCurry Int + + -- | Extend an explicitly typed closure with more arguments, + -- producing a new closure. + | OpFunCExtend Int + + -- | Apply an explicitly typed closure to some arguments, + -- possibly evaluating the contained function. + | OpFunCApply Int + deriving (Eq, Ord, Show) + + +-- OpVector ------------------------------------------------------------------- +-- | Vector operators. +data OpVector + -- | Allocate a new vector of a given length number of elements. + = OpVectorAlloc + + -- | Get the length of a vector, in elements. + | OpVectorLength + + -- | Read a value from a vector. + | OpVectorRead + + -- | Write a value to a vector. + | OpVectorWrite deriving (Eq, Ord, Show) diff --git a/DDC/Core/Tetra/Prim/DaConTetra.hs b/DDC/Core/Tetra/Prim/DaConTetra.hs --- a/DDC/Core/Tetra/Prim/DaConTetra.hs +++ b/DDC/Core/Tetra/Prim/DaConTetra.hs @@ -1,19 +1,24 @@ module DDC.Core.Tetra.Prim.DaConTetra ( typeDaConTetra - , readDaConTetra) + , readDaConTetra + , xTuple2 + , dcTuple2 + , dcTupleN ) where import DDC.Core.Tetra.Prim.Base import DDC.Core.Tetra.Prim.TyConTetra -import DDC.Core.Compounds.Annot -import DDC.Core.Exp.Simple +import DDC.Core.Exp.Simple.Compounds +import DDC.Core.Exp.Simple.Exp import DDC.Base.Pretty import Control.DeepSeq import Data.Char import Data.List -instance NFData DaConTetra +instance NFData DaConTetra where + rnf !_ = () + instance Pretty DaConTetra where ppr dc @@ -39,4 +44,28 @@ typeDaConTetra (DaConTetraTuple n) = tForalls (replicate n kData) $ \args -> foldr tFun (tTupleN args) args + + +-- | Construct a @Tuple2#@ +xTuple2 :: Type Name -> Type Name + -> Exp a Name -> Exp a Name + -> Exp a Name + +xTuple2 t1 t2 x1 x2 + = xApps (XCon dcTuple2) + [XType t1, XType t2, x1, x2] + + +-- | Data constructor for @Tuple2#@ +dcTuple2 :: DaCon Name +dcTuple2 = DaConPrim (NameDaConTetra (DaConTetraTuple 2)) + (typeDaConTetra (DaConTetraTuple 2)) + + +-- | Data constructor for n-tuples +dcTupleN :: Int -> DaCon Name +dcTupleN n + = DaConPrim (NameDaConTetra (DaConTetraTuple n)) + (typeDaConTetra (DaConTetraTuple n)) + diff --git a/DDC/Core/Tetra/Prim/OpArith.hs b/DDC/Core/Tetra/Prim/OpArith.hs --- a/DDC/Core/Tetra/Prim/OpArith.hs +++ b/DDC/Core/Tetra/Prim/OpArith.hs @@ -1,63 +1,87 @@ module DDC.Core.Tetra.Prim.OpArith - ( readPrimArith - , typePrimArith) + ( readPrimArithFlag + , typePrimArithFlag) where +import DDC.Core.Tetra.Prim.TyConTetra +import DDC.Core.Tetra.Prim.TyConPrim import DDC.Core.Tetra.Prim.Base import DDC.Type.Compounds import DDC.Type.Exp -import DDC.Core.Salt.Name (readPrimArith) - +import Data.List -- | Take the type of a primitive arithmetic operator. -typePrimArith :: PrimArith -> Type Name -typePrimArith op - = case op of - -- Arithmetic Operators. - -- Parameterised by the type they work on. - PrimArithNeg -> tForall kData $ \t -> t `tFun` t - PrimArithAdd -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithSub -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithMul -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithDiv -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithMod -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithRem -> tForall kData $ \t -> t `tFun` t `tFun` t +typePrimArithFlag :: PrimArith -> Bool -> Type Name +typePrimArithFlag op bUnboxed + = let + fb | bUnboxed = tUnboxed + | otherwise = id - -- Bitwise Operators. - PrimArithShl -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithShr -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithBAnd -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithBOr -> tForall kData $ \t -> t `tFun` t `tFun` t - PrimArithBXOr -> tForall kData $ \t -> t `tFun` t `tFun` t + tOp1 = tForall kData $ \t -> fb t `tFun` fb t + tOp2 = tForall kData $ \t -> fb t `tFun` fb t `tFun` fb t + tEq = tForall kData $ \t -> fb t `tFun` fb t `tFun` fb tBool - -- Boolean Operators. - PrimArithAnd -> tForall kData $ \tb - -> tb `tFun` tb `tFun` tb - - PrimArithOr -> tForall kData $ \tb - -> tb `tFun` tb `tFun` tb + in case op of + PrimArithNeg -> tOp1 - -- Comparison Operators. - -- These are parameterised by the input type, as well as the boolean result, - -- so that we can convert between value type and unboxed type representations - -- in the boxing transform. - PrimArithEq -> tForalls [kData, kData] $ \[t, tb] - -> t `tFun` t `tFun` tb - - PrimArithNeq -> tForalls [kData, kData] $ \[t, tb] - -> t `tFun` t `tFun` tb - - PrimArithGt -> tForalls [kData, kData] $ \[t, tb] - -> t `tFun` t `tFun` tb - - PrimArithLt -> tForalls [kData, kData] $ \[t, tb] - -> t `tFun` t `tFun` tb - - PrimArithLe -> tForalls [kData, kData] $ \[t, tb] - -> t `tFun` t `tFun` tb - - PrimArithGe -> tForalls [kData, kData] $ \[t, tb] - -> t `tFun` t `tFun` tb + PrimArithAdd -> tOp2 + PrimArithSub -> tOp2 + PrimArithMul -> tOp2 + PrimArithDiv -> tOp2 + PrimArithMod -> tOp2 + PrimArithRem -> tOp2 + PrimArithShl -> tOp2 + PrimArithShr -> tOp2 + PrimArithBAnd -> tOp2 + PrimArithBOr -> tOp2 + PrimArithBXOr -> tOp2 + PrimArithAnd -> tOp2 + PrimArithOr -> tOp2 + PrimArithEq -> tEq + PrimArithNeq -> tEq + PrimArithGt -> tEq + PrimArithLt -> tEq + PrimArithLe -> tEq + PrimArithGe -> tEq + + +-- | Read a primitive operator. +readPrimArithFlag :: String -> Maybe (PrimArith, Bool) +readPrimArithFlag str + = case find (\(_, n) -> str == n) primArithNames of + Just (p, _) -> Just p + _ -> Nothing + + +-- | Names of primitve operators. +primArithNames :: [((PrimArith, Bool), String)] +primArithNames + = concat + $ [ [ ((p, False), str) + , ((p, True), str ++ "#")] + | (p, str) <- table] + where + table + = [ (PrimArithNeg, "neg#") + , (PrimArithAdd, "add#") + , (PrimArithSub, "sub#") + , (PrimArithMul, "mul#") + , (PrimArithDiv, "div#") + , (PrimArithRem, "rem#") + , (PrimArithMod, "mod#") + , (PrimArithEq, "eq#" ) + , (PrimArithNeq, "neq#") + , (PrimArithGt, "gt#" ) + , (PrimArithGe, "ge#" ) + , (PrimArithLt, "lt#" ) + , (PrimArithLe, "le#" ) + , (PrimArithAnd, "and#") + , (PrimArithOr, "or#" ) + , (PrimArithShl, "shl#") + , (PrimArithShr, "shr#") + , (PrimArithBAnd, "band#") + , (PrimArithBOr, "bor#") + , (PrimArithBXOr, "bxor#") ] diff --git a/DDC/Core/Tetra/Prim/OpError.hs b/DDC/Core/Tetra/Prim/OpError.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Prim/OpError.hs @@ -0,0 +1,47 @@ + +module DDC.Core.Tetra.Prim.OpError + ( OpError (..) + , readOpErrorFlag + , typeOpErrorFlag) +where +import DDC.Core.Tetra.Prim.TyConTetra +import DDC.Core.Tetra.Prim.TyConPrim +import DDC.Core.Tetra.Prim.Base +import DDC.Type.Compounds +import DDC.Type.Exp +import DDC.Base.Pretty +import Control.DeepSeq + + +instance NFData OpError where + rnf op + = case op of + OpErrorDefault -> () + + +instance Pretty OpError where + ppr op + = case op of + OpErrorDefault -> text "default#" + + +-- | Read a primitive error operator. +readOpErrorFlag :: String -> Maybe (OpError, Bool) +readOpErrorFlag str + = case str of + "default#" -> Just (OpErrorDefault, False) + "default##" -> Just (OpErrorDefault, True) + _ -> Nothing + + +-- | Get the type of a primitive error operator. +typeOpErrorFlag :: OpError -> Bool -> Type Name +typeOpErrorFlag err False + = case err of + OpErrorDefault + -> tForall kData $ \t -> tTextLit `tFun` tNat `tFun` t + +typeOpErrorFlag err True + = case err of + OpErrorDefault + -> tForall kData $ \t -> tUnboxed tTextLit `tFun` tUnboxed tNat `tFun` t diff --git a/DDC/Core/Tetra/Prim/OpFun.hs b/DDC/Core/Tetra/Prim/OpFun.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Prim/OpFun.hs @@ -0,0 +1,163 @@ + +module DDC.Core.Tetra.Prim.OpFun + ( OpFun (..) + , readOpFun + , typeOpFun) +where +import DDC.Core.Tetra.Prim.TyConTetra +import DDC.Core.Tetra.Prim.Base +import DDC.Type.Compounds +import DDC.Type.Exp +import DDC.Base.Pretty +import Control.DeepSeq +import Data.Char +import Data.List + + +instance NFData OpFun where + rnf op + = case op of + OpFunCurry n -> rnf n + OpFunApply n -> rnf n + OpFunCReify -> () + OpFunCCurry n -> rnf n + OpFunCExtend n -> rnf n + OpFunCApply n -> rnf n + + +instance Pretty OpFun where + ppr pf + = case pf of + OpFunCurry n + -> text "curry" <> int n <> text "#" + + OpFunApply n + -> text "apply" <> int n <> text "#" + + OpFunCReify + -> text "creify#" + + OpFunCCurry n + -> text "ccurry" <> int n <> text "#" + + OpFunCExtend n + -> text "cextend" <> int n <> text "#" + + OpFunCApply n + -> text "capply" <> int n <> text "#" + + +-- | Read a primitive function operator. +readOpFun :: String -> Maybe OpFun +readOpFun str + -- curryN# + | Just rest <- stripPrefix "curry" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 0 + = Just $ OpFunCurry n + + -- applyN# + | Just rest <- stripPrefix "apply" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 1 + = Just $ OpFunApply n + + -- creify# + | "creify#" <- str + = Just $ OpFunCReify + + -- ccurryN# + | Just rest <- stripPrefix "ccurry" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 0 + = Just $ OpFunCCurry n + + -- cextendN# + | Just rest <- stripPrefix "cextend" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 1 + = Just $ OpFunCExtend n + + -- capplyN# + | Just rest <- stripPrefix "capply" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 0 + = Just $ OpFunCApply n + + | otherwise + = Nothing + + +-- | Take the type of a primitive function operator. +typeOpFun :: OpFun -> Type Name +typeOpFun op + = case op of + OpFunCurry n + -> tForalls (replicate (n + 1) kData) + $ \ts -> + let tLast : tsFront' = reverse ts + tsFront = reverse tsFront' + Just tF = tFunOfList ts + Just result + = tFunOfList + ( tFunValue tF + : tsFront ++ [tLast]) + in result + + OpFunApply n + -> tForalls (replicate (n + 1) kData) + $ \ts -> + let Just tF = tFunOfList ts + Just result = tFunOfList (tF : ts) + in result + + OpFunCReify + -> tForalls [kData, kData] + $ \[tA, tB] -> (tA `tFun` tB) `tFun` tFunValue (tA `tFun` tB) + + OpFunCCurry n + -> tForalls (replicate (n + 1) kData) + $ \ts -> + let tLast : tsFront' = reverse ts + tsFront = reverse tsFront' + Just tF = tFunOfList ts + Just result + = tFunOfList + ( tFunValue tF + : tsFront ++ [tCloValue tLast]) + in result + + OpFunCExtend n + -> tForalls (replicate (n + 1) kData) + $ \ts -> + let tLast : tsFront' = reverse ts + tsFront = reverse tsFront' + Just tF = tFunOfList ts + Just result + = tFunOfList + ( tCloValue tF + : tsFront ++ [tCloValue tLast]) + in result + + OpFunCApply n + -> tForalls (replicate (n + 1) kData) + $ \ts -> + let tLast : tsFront' = reverse ts + tsFront = reverse tsFront' + Just tF = tFunOfList ts + Just result + = tFunOfList + ( tCloValue tF + : tsFront ++ [tLast]) + in result + diff --git a/DDC/Core/Tetra/Prim/OpStore.hs b/DDC/Core/Tetra/Prim/OpStore.hs deleted file mode 100644 --- a/DDC/Core/Tetra/Prim/OpStore.hs +++ /dev/null @@ -1,56 +0,0 @@ - -module DDC.Core.Tetra.Prim.OpStore - ( readOpStore - , typeOpStore) -where -import DDC.Core.Tetra.Prim.TyConTetra -import DDC.Core.Tetra.Prim.Base -import DDC.Type.Compounds -import DDC.Type.Exp -import DDC.Base.Pretty -import Control.DeepSeq -import Data.List - - -instance NFData OpStore - -instance Pretty OpStore where - ppr op - = let Just (_, n) = find (\(p, _) -> op == p) opStoreNames - in (text n) - - --- | Read a primitive store operator. -readOpStore :: String -> Maybe OpStore -readOpStore str - = case find (\(_, n) -> str == n) opStoreNames of - Just (p, _) -> Just p - _ -> Nothing - - --- | Names of primitive store operators. -opStoreNames :: [(OpStore, String)] -opStoreNames - = [ (OpStoreAllocRef, "allocRef#") - , (OpStoreReadRef, "readRef#") - , (OpStoreWriteRef, "writeRef#") ] - - --- | Take the type of a primitive store operator. -typeOpStore :: OpStore -> Type Name -typeOpStore op - = case op of - OpStoreAllocRef - -> tForalls [kRegion, kData] - $ \[tR, tA] -> tA - `tFun` tSusp (tAlloc tR) (tRef tR tA) - - OpStoreReadRef - -> tForalls [kRegion, kData] - $ \[tR, tA] -> tRef tR tA - `tFun` tSusp (tRead tR) tA - - OpStoreWriteRef - -> tForalls [kRegion, kData] - $ \[tR, tA] -> tRef tR tA `tFun` tA - `tFun` tSusp (tWrite tR) tUnit diff --git a/DDC/Core/Tetra/Prim/OpVector.hs b/DDC/Core/Tetra/Prim/OpVector.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Prim/OpVector.hs @@ -0,0 +1,96 @@ + +module DDC.Core.Tetra.Prim.OpVector + ( readOpVectorFlag + , typeOpVectorFlag) +where +import DDC.Core.Tetra.Prim.TyConTetra +import DDC.Core.Tetra.Prim.TyConPrim +import DDC.Core.Tetra.Prim.Base +import DDC.Type.Compounds +import DDC.Type.Exp +import DDC.Base.Pretty +import Control.DeepSeq + + +instance NFData OpVector where + rnf !_ = () + + +instance Pretty OpVector where + ppr pv + = case pv of + OpVectorAlloc -> text "vectorAlloc#" + OpVectorLength -> text "vectorLength#" + OpVectorRead -> text "vectorRead#" + OpVectorWrite -> text "vectorWrite#" + + +-- | Read a primitive vector operator, +-- along with the flag that indicates whether this is the +-- boxed or unboxed version. +readOpVectorFlag :: String -> Maybe (OpVector, Bool) +readOpVectorFlag str + = case str of + "vectorAlloc#" -> Just (OpVectorAlloc, False) + "vectorAlloc##" -> Just (OpVectorAlloc, True) + + "vectorLength#" -> Just (OpVectorLength, False) + "vectorLength##" -> Just (OpVectorLength, True) + + "vectorRead#" -> Just (OpVectorRead, False) + "vectorRead##" -> Just (OpVectorRead, True) + + "vectorWrite#" -> Just (OpVectorWrite, False) + "vectorWrite##" -> Just (OpVectorWrite, True) + + _ -> Nothing + + +-- | Take the type of a primitive vector operator. +typeOpVectorFlag :: OpVector -> Bool -> Type Name + +typeOpVectorFlag op False + = case op of + OpVectorAlloc + -> tForalls [kRegion, kData] + $ \[tR, tA] -> tNat + `tFun` tSusp (tAlloc tR) (tVector tR tA) + + OpVectorLength + -> tForalls [kRegion, kData] + $ \[tR, tA] -> tVector tR tA + `tFun` tNat + + OpVectorRead + -> tForalls [kRegion, kData] + $ \[tR, tA] -> tVector tR tA `tFun` tNat + `tFun` tSusp (tRead tR) tA + + OpVectorWrite + -> tForalls [kRegion, kData] + $ \[tR, tA] -> tVector tR tA `tFun` tNat `tFun` tA + `tFun` tSusp (tWrite tR) tVoid + +typeOpVectorFlag op True + = case op of + OpVectorAlloc + -> tForalls [kRegion, kData] + $ \[tR, tA] -> tUnboxed tNat + `tFun` tSusp (tAlloc tR) (tVector tR tA) + + OpVectorLength + -> tForalls [kRegion, kData] + $ \[tR, tA] -> tVector tR tA + `tFun` tUnboxed tNat + + OpVectorRead + -> tForalls [kRegion, kData] + $ \[tR, tA] -> tVector tR tA `tFun` tUnboxed tNat + `tFun` tSusp (tRead tR) (tUnboxed tA) + + OpVectorWrite + -> tForalls [kRegion, kData] + $ \[tR, tA] -> tVector tR tA `tFun` tUnboxed tNat `tFun` tUnboxed tA + `tFun` tSusp (tWrite tR) tVoid + + diff --git a/DDC/Core/Tetra/Prim/TyConPrim.hs b/DDC/Core/Tetra/Prim/TyConPrim.hs --- a/DDC/Core/Tetra/Prim/TyConPrim.hs +++ b/DDC/Core/Tetra/Prim/TyConPrim.hs @@ -1,54 +1,92 @@ module DDC.Core.Tetra.Prim.TyConPrim ( PrimTyCon (..) - , readPrimTyCon + , pprPrimTyConStem + , readPrimTyCon, readPrimTyConStem , kindPrimTyCon + , tVoid , tBool - , tNat - , tInt - , tWord) + , tNat, tInt, tSize, tWord, tFloat + , tPtr + , tTextLit) where import DDC.Core.Tetra.Prim.Base -import DDC.Core.Compounds.Annot -import DDC.Core.Exp.Simple -import DDC.Core.Salt.Name (readPrimTyCon) +import DDC.Core.Exp.Annot.Compounds +import DDC.Core.Exp.Simple.Exp +import DDC.Core.Salt.Name + ( pprPrimTyConStem + , readPrimTyCon, readPrimTyConStem) -- | Yield the kind of a type constructor. kindPrimTyCon :: PrimTyCon -> Kind Name kindPrimTyCon tc = case tc of - PrimTyConVoid -> kData - PrimTyConBool -> kData - PrimTyConNat -> kData - PrimTyConInt -> kData - PrimTyConWord{} -> kData - PrimTyConFloat{} -> kData - PrimTyConVec{} -> kData `kFun` kData - PrimTyConAddr{} -> kData - PrimTyConPtr{} -> kRegion `kFun` kData `kFun` kData - PrimTyConTag{} -> kData - PrimTyConString{} -> kData + PrimTyConVoid -> kData + PrimTyConBool -> kData + PrimTyConNat -> kData + PrimTyConInt -> kData + PrimTyConSize -> kData + PrimTyConWord{} -> kData + PrimTyConFloat{} -> kData + PrimTyConVec{} -> kData `kFun` kData + PrimTyConAddr{} -> kData + PrimTyConPtr{} -> kRegion `kFun` kData `kFun` kData + PrimTyConTextLit{} -> kData + PrimTyConTag{} -> kData -- Compounds ------------------------------------------------------------------ +-- | Primitive `Void` type. +tVoid :: Type Name +tVoid = tConPrim PrimTyConVoid + + -- | Primitive `Bool` type. tBool :: Type Name -tBool = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConBool) kData) kData) +tBool = tConPrim PrimTyConBool -- | Primitive `Nat` type. -tNat :: Type Name -tNat = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConNat) kData) kData) +tNat :: Type Name +tNat = tConPrim PrimTyConNat -- | Primitive `Int` type. -tInt :: Type Name -tInt = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConInt) kData) kData) +tInt :: Type Name +tInt = tConPrim PrimTyConInt -- | Primitive `WordN` type of the given width. tWord :: Int -> Type Name -tWord bits - = TCon (TyConBound (UPrim (NamePrimTyCon (PrimTyConWord bits)) kData) kData) +tWord bits = tConPrim (PrimTyConWord bits) + + +-- | Primitive `Size` type. +tSize :: Type Name +tSize = tConPrim PrimTyConSize + + +-- | Primitive `FloatN` type of the given width. +tFloat :: Int -> Type Name +tFloat bits = tConPrim (PrimTyConFloat bits) + + +-- | Primitive `Ptr` type with given region and data type +tPtr :: Type Name -> Type Name -> Type Name +tPtr r a + = tConPrim PrimTyConPtr `TApp` r `TApp` a + + +-- | The text literal type. +tTextLit :: Type Name +tTextLit = tConPrim PrimTyConTextLit + + +-- | Yield the type for a primtiive type constructor. +tConPrim :: PrimTyCon -> Type Name +tConPrim tc + = let k = kindPrimTyCon tc + in TCon (TyConBound (UPrim (NamePrimTyCon tc) k) k) + diff --git a/DDC/Core/Tetra/Prim/TyConTetra.hs b/DDC/Core/Tetra/Prim/TyConTetra.hs --- a/DDC/Core/Tetra/Prim/TyConTetra.hs +++ b/DDC/Core/Tetra/Prim/TyConTetra.hs @@ -2,29 +2,33 @@ module DDC.Core.Tetra.Prim.TyConTetra ( kindTyConTetra , readTyConTetra - , tRef , tTupleN - , tBoxed - , tUnboxed) + , tVector + , tUnboxed + , tFunValue + , tCloValue) where import DDC.Core.Tetra.Prim.Base -import DDC.Core.Compounds.Annot -import DDC.Core.Exp.Simple +import DDC.Core.Exp.Simple.Exp +import DDC.Type.Compounds import DDC.Base.Pretty import Control.DeepSeq import Data.List import Data.Char -instance NFData TyConTetra +instance NFData TyConTetra where + rnf !_ = () + instance Pretty TyConTetra where ppr tc = case tc of - TyConTetraRef -> text "Ref#" TyConTetraTuple n -> text "Tuple" <> int n <> text "#" - TyConTetraB -> text "B#" + TyConTetraVector -> text "Vector#" TyConTetraU -> text "U#" + TyConTetraF -> text "F#" + TyConTetraC -> text "C#" -- | Read the name of a baked-in type constructor. @@ -38,9 +42,10 @@ | otherwise = case str of - "Ref#" -> Just TyConTetraRef - "B#" -> Just TyConTetraB + "Vector#" -> Just TyConTetraVector "U#" -> Just TyConTetraU + "F#" -> Just TyConTetraF + "C#" -> Just TyConTetraC _ -> Nothing @@ -48,33 +53,37 @@ kindTyConTetra :: TyConTetra -> Type Name kindTyConTetra tc = case tc of - TyConTetraRef -> kRegion `kFun` kData `kFun` kData TyConTetraTuple n -> foldr kFun kData (replicate n kData) - TyConTetraB -> kData `kFun` kData + TyConTetraVector -> kRegion `kFun` kData `kFun` kData TyConTetraU -> kData `kFun` kData + TyConTetraF -> kData `kFun` kData + TyConTetraC -> kData `kFun` kData -- Compounds ------------------------------------------------------------------ -tRef :: Region Name -> Type Name -> Type Name -tRef tR tA - = tApps (TCon (TyConBound (UPrim (NameTyConTetra TyConTetraRef) k) k)) - [tR, tA] - where k = kRegion `kFun` kData `kFun` kData - - -- | Construct a tuple type. tTupleN :: [Type Name] -> Type Name tTupleN tys = tApps (tConTyConTetra (TyConTetraTuple (length tys))) tys --- | Construct a boxed representation type. -tBoxed :: Type Name -> Type Name -tBoxed t = tApp (tConTyConTetra TyConTetraB) t +-- | Construct a vector type. +tVector :: Region Name -> Type Name -> Type Name +tVector tR tA = tApps (tConTyConTetra TyConTetraVector) [tR, tA] -- | Construct an unboxed representation type. tUnboxed :: Type Name -> Type Name tUnboxed t = tApp (tConTyConTetra TyConTetraU) t + + +-- | Construct a reified function type. +tFunValue :: Type Name -> Type Name +tFunValue t = tApp (tConTyConTetra TyConTetraF) t + + +-- | Construct a reified closure type. +tCloValue :: Type Name -> Type Name +tCloValue t = tApp (tConTyConTetra TyConTetraC) t -- Utils ---------------------------------------------------------------------- diff --git a/DDC/Core/Tetra/Profile.hs b/DDC/Core/Tetra/Profile.hs --- a/DDC/Core/Tetra/Profile.hs +++ b/DDC/Core/Tetra/Profile.hs @@ -27,7 +27,8 @@ , profilePrimKinds = primKindEnv , profilePrimTypes = primTypeEnv , profileTypeIsUnboxed = const False - , profileNameIsHole = Just isNameHole } + , profileNameIsHole = Just isNameHole + , profileMakeStringName = Just (\_ t -> NameLitTextLit t) } features :: Features @@ -38,10 +39,18 @@ , featuresFunctionalEffects = False , featuresFunctionalClosures = False , featuresEffectCapabilities = True + + -- We don't want to insert implicit casts when type checking + -- the core code during transformation, but we do insert them + -- the first time the source + , featuresImplicitRun = False + , featuresImplicitBox = False + , featuresPartialPrims = True , featuresPartialApplication = True , featuresGeneralApplication = True , featuresNestedFunctions = True + , featuresGeneralLetRec = True , featuresDebruijnBinders = True , featuresUnboundLevel0Vars = False , featuresUnboxedInstantiation = True @@ -59,7 +68,7 @@ where rn (Token strTok sp) = case renameTok readName strTok of Just t' -> Token t' sp - Nothing -> Token (KJunk "lexical error") sp + Nothing -> Token (KErrorJunk "lexical error") sp -- | Lex a string to tokens, using primitive names. @@ -71,7 +80,7 @@ where rn (Token strTok sp) = case renameTok readName strTok of Just t' -> Token t' sp - Nothing -> Token (KJunk "lexical error") sp + Nothing -> Token (KErrorJunk "lexical error") sp -- | Create a new type variable name that is not in the given environment. diff --git a/DDC/Core/Tetra/Transform/Boxing.hs b/DDC/Core/Tetra/Transform/Boxing.hs --- a/DDC/Core/Tetra/Transform/Boxing.hs +++ b/DDC/Core/Tetra/Transform/Boxing.hs @@ -4,190 +4,140 @@ where import DDC.Core.Tetra.Compounds import DDC.Core.Tetra.Prim -import DDC.Core.Transform.Boxing import DDC.Core.Module import DDC.Core.Exp +import DDC.Core.Transform.Boxing (Rep(..), Config(..)) +import qualified DDC.Core.Transform.Boxing as Boxing -- | Manage boxing of numeric values in a module. boxingModule :: Show a => Module a Name -> Module a Name -boxingModule mm - = boxing config mm +boxingModule mm + = let + tsForeignSea + = [ (n, t) | (n, ImportValueSea _ t) <- moduleImportValues mm] + in Boxing.boxingModule (config tsForeignSea) mm + -- | Tetra-specific configuration for boxing transform. -config :: Config a Name -config = Config - { configIsValueIndexType = isValueIndexType - , configIsBoxedType = isBoxedType - , configIsUnboxedType = isUnboxedType - , configBoxedOfIndexType = boxedOfIndexType - , configUnboxedOfIndexType = unboxedOfIndexType - , configIndexTypeOfBoxed = indexTypeOfBoxed - , configIndexTypeOfUnboxed = indexTypeOfUnboxed - , configNameIsUnboxedOp = isNameOfUnboxedOp +config :: [(Name, Type Name)] -> Config a Name +config ntsForeignSea + = Config + { configRepOfType = repOfType + , configConvertRepType = convertRepType + , configConvertRepExp = convertRepExp , configValueTypeOfLitName = takeTypeOfLitName , configValueTypeOfPrimOpName = takeTypeOfPrimOpName - , configValueTypeOfForeignName = const Nothing - , configBoxedOfValue = boxedOfValue - , configValueOfBoxed = valueOfBoxed - , configBoxedOfUnboxed = boxedOfUnboxed - , configUnboxedOfBoxed = unboxedOfBoxed } + , configValueTypeOfForeignName = \n -> lookup n ntsForeignSea + , configUnboxPrimOpName = unboxPrimOpName + , configUnboxLitName = unboxLitName } --- | Check whether a value of this type needs boxing to make the --- program representational. -isValueIndexType :: Type Name -> Bool -isValueIndexType tt - -- These types are listed out in full so anyone who adds more - -- constructors to the PrimTyCon type is forced to say whether - -- those types refer to unboxed values or not. - -- +-- | Get the representation of a given type. +repOfType :: Type Name -> Maybe Rep +repOfType tt + -- These types are listed out in full so anyone who adds more + -- constructors to the PrimTyCon type is forced to specify what + -- the representation is. | Just (NamePrimTyCon n, _) <- takePrimTyConApps tt = case n of - -- There should never be any value of type Void# being passed - -- around, but say they don't need boxing anyway so we don't - -- complicate an already broken program. - PrimTyConVoid -> False - - PrimTyConBool -> True - PrimTyConNat -> True - PrimTyConInt -> True - PrimTyConWord{} -> True - PrimTyConFloat{} -> True - PrimTyConVec{} -> True - PrimTyConAddr{} -> True - PrimTyConPtr{} -> True - PrimTyConTag{} -> True - PrimTyConString{} -> True - - -- These are all higher-kinded type constructors, - -- with don't have a value-level representation. - | Just (NameTyConTetra n, _) <- takePrimTyConApps tt - = case n of - TyConTetraRef{} -> False - TyConTetraTuple{} -> False - TyConTetraB{} -> False - TyConTetraU{} -> False - - | otherwise - = False - - --- | Check whether this is a boxed representation type. -isBoxedType :: Type Name -> Bool -isBoxedType tt - | Just (n, _) <- takePrimTyConApps tt - , NameTyConTetra TyConTetraB <- n - = True - - | otherwise = False + PrimTyConVoid -> Just RepNone + PrimTyConBool -> Just RepBoxed + PrimTyConNat -> Just RepBoxed + PrimTyConInt -> Just RepBoxed + PrimTyConSize -> Just RepBoxed + PrimTyConWord{} -> Just RepBoxed + PrimTyConFloat{} -> Just RepBoxed + PrimTyConVec{} -> Just RepBoxed + PrimTyConAddr{} -> Just RepBoxed + PrimTyConPtr{} -> Just RepBoxed + PrimTyConTextLit{} -> Just RepBoxed + PrimTyConTag{} -> Just RepBoxed --- | Check whether this is a boxed representation type. -isUnboxedType :: Type Name -> Bool -isUnboxedType tt + -- Explicitly unboxed things. | Just (n, _) <- takePrimTyConApps tt , NameTyConTetra TyConTetraU <- n - = True + = Just RepUnboxed - | otherwise = False + | Just (NameTyConTetra n, _) <- takePrimTyConApps tt + = case n of + -- These are all higher-kinded type constructors, + -- which don't have any associated values. + TyConTetraTuple{} -> Just RepNone + TyConTetraVector{} -> Just RepNone + TyConTetraU{} -> Just RepNone + TyConTetraF{} -> Just RepNone + TyConTetraC{} -> Just RepNone --- | Take the index type from a boxed type, if it is one. -indexTypeOfBoxed :: Type Name -> Maybe (Type Name) -indexTypeOfBoxed tt - | Just (n, [t]) <- takePrimTyConApps tt - , NameTyConTetra TyConTetraB <- n - = Just t - | otherwise = Nothing --- | Take the index type from an unboxed type, if it is one. -indexTypeOfUnboxed :: Type Name -> Maybe (Type Name) -indexTypeOfUnboxed tt +-- | Get the type for a different representation of the given one. +convertRepType :: Rep -> Type Name -> Maybe (Type Name) +convertRepType RepBoxed tt + -- Produce the value type from an unboxed one. | Just (n, [t]) <- takePrimTyConApps tt , NameTyConTetra TyConTetraU <- n = Just t - | otherwise - = Nothing - - --- | Get the boxed version of some type of kind Data. -boxedOfIndexType :: Type Name -> Maybe (Type Name) -boxedOfIndexType tt - | Just (NamePrimTyCon tc, []) <- takePrimTyConApps tt - = case tc of - PrimTyConBool -> Just $ tBoxed tBool - PrimTyConNat -> Just $ tBoxed tNat - PrimTyConInt -> Just $ tBoxed tInt - PrimTyConWord bits -> Just $ tBoxed (tWord bits) - _ -> Nothing - - | otherwise = Nothing - - --- | Get the unboxed version of some type of kind Data. -unboxedOfIndexType :: Type Name -> Maybe (Type Name) -unboxedOfIndexType tt +convertRepType RepUnboxed tt | Just (NamePrimTyCon tc, []) <- takePrimTyConApps tt = case tc of PrimTyConBool -> Just $ tUnboxed tBool PrimTyConNat -> Just $ tUnboxed tNat PrimTyConInt -> Just $ tUnboxed tInt + PrimTyConSize -> Just $ tUnboxed tSize PrimTyConWord bits -> Just $ tUnboxed (tWord bits) + PrimTyConFloat bits -> Just $ tUnboxed (tFloat bits) + PrimTyConTextLit -> Just $ tUnboxed tTextLit _ -> Nothing - | otherwise = Nothing - + | Just (NameTyConTetra tc, []) <- takePrimTyConApps tt + = case tc of + _ -> Nothing --- | Check if the primitive operator with this name takes unboxed values --- directly. -isNameOfUnboxedOp :: Name -> Bool -isNameOfUnboxedOp nn - = case nn of - NamePrimArith{} -> True - NamePrimCast{} -> True - _ -> False +convertRepType _ _ + = Nothing --- | Wrap a pure value into its boxed representation. -boxedOfValue :: a -> Exp a Name -> Type Name -> Maybe (Exp a Name) -boxedOfValue a xx tt - | Just tBx <- boxedOfIndexType tt - = Just $ xCastConvert a tt tBx xx +-- | Convert an expression from one representation to another. +convertRepExp :: Rep -> a -> Type Name -> Exp a Name -> Maybe (Exp a Name) +convertRepExp rep a tSource xx + | Just tResult <- convertRepType rep tSource + = Just $ xCastConvert a tSource tResult xx - | otherwise = Nothing + | otherwise + = Nothing --- | Unwrap a boxed value. -valueOfBoxed :: a -> Exp a Name -> Type Name -> Maybe (Exp a Name) -valueOfBoxed a xx tt - | Just tBx <- boxedOfIndexType tt - = Just $ xCastConvert a tBx tt xx - - | otherwise = Nothing +-- | Convert a primitive operator name to the unboxed version. +unboxPrimOpName :: Name -> Maybe Name +unboxPrimOpName n + = case n of + -- The types of arithmetic operators are already polytypic, + -- and can be instantiated at either value types or unboxed types. + NamePrimArith op False + -> Just $ NamePrimArith op True + -- The types of vector operators have different value type and unboxed versions. + NameOpVector op False + -> Just $ NameOpVector op True --- | Box an expression of the given type. -boxedOfUnboxed :: a -> Exp a Name -> Type Name -> Maybe (Exp a Name) -boxedOfUnboxed a xx tt - | Just tBx <- boxedOfIndexType tt - , Just tUx <- unboxedOfIndexType tt - = Just $ xCastConvert a tUx tBx xx + NameOpError op False + -> Just $ NameOpError op True - | otherwise = Nothing + _ -> Nothing --- | Unbox an expression of the given type. -unboxedOfBoxed :: a -> Exp a Name -> Type Name -> Maybe (Exp a Name) -unboxedOfBoxed a xx tt - | Just tBx <- boxedOfIndexType tt - , Just tUx <- unboxedOfIndexType tt - = Just $ xCastConvert a tBx tUx xx - - | otherwise = Nothing +-- | If this is the name of an literal, then produce the unboxed version. +unboxLitName :: Name -> Maybe Name +unboxLitName n + | isNameLit n && not (isNameLitUnboxed n) + = Just $ NameLitUnboxed n + | otherwise + = Nothing diff --git a/DDC/Core/Tetra/Transform/Curry.hs b/DDC/Core/Tetra/Transform/Curry.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Transform/Curry.hs @@ -0,0 +1,213 @@ + +module DDC.Core.Tetra.Transform.Curry + (curryModule) +where +import DDC.Core.Tetra.Transform.Curry.Call +import DDC.Core.Tetra.Transform.Curry.Callable +import DDC.Core.Tetra.Transform.Curry.Error +import DDC.Core.Tetra.Prim +import DDC.Core.Transform.Reannotate +import DDC.Core.Exp.Annot.AnTEC +import DDC.Core.Module +import DDC.Core.Exp.Annot +import Data.Maybe +import Data.Map (Map) +import qualified DDC.Core.Call as Call +import qualified Data.Map.Strict as Map +import qualified Data.List as List + + +-- | Insert primitives to manage higher order functions in a module. +-- +-- We work out which supers are being fully applied, under applied or +-- over applied, and build and evaluate closures as necessary. +-- +curryModule + :: Module (AnTEC a Name) Name + -> Either Error (Module () Name) + +curryModule mm + = do + -- Add all the foreign functions to the function map. + -- We can do a saturated call for these directly. + callables <- fmap (Map.fromList . catMaybes) + $ mapM (uncurry takeCallableFromImport) + $ moduleImportValues mm + + -- Apply curry transform in the body of the module. + xBody' <- curryBody callables + $ moduleBody mm + + return $ mm { moduleBody = xBody' } + + +-- | Manage higher-order functions in a module body. +curryBody + :: Map Name Callable + -> Exp (AnTEC a Name) Name + -> Either Error (Exp () Name) + +curryBody callables xx + = case xx of + XLet _ (LRec bxs) xBody + -> do let (bs, xs) = unzip bxs + + -- Add types of supers to the map of callable things. + csSuper <- fmap (Map.fromList) + $ mapM (uncurry takeCallableFromSuper) bxs + + let callables' + = Map.union csSuper callables + + -- Rewrite bindings in the body of the let-expression. + xs' <- mapM (curryX callables') xs + let bxs' = zip bs xs' + xBody' <- curryBody callables' xBody + return $ XLet () (LRec bxs') xBody' + + _ -> return $ reannotate (const ()) xx + + +-- | Manage function application in an expression. +curryX :: Map Name Callable + -> Exp (AnTEC a Name) Name + -> Either Error (Exp () Name) + +curryX callables xx + = let down x = curryX callables x + in case xx of + XVar a (UName nF) + -> do result <- makeCall callables nF (annotType a) [] + case result of + Just xx' -> return xx' + Nothing -> return $ XVar () (UName nF) + + XVar _ u + -> return $ XVar () u + + XApp _ x1 x2 + -> do result <- curryX_call callables xx + case result of + Just xx' -> return xx' + Nothing -> XApp () <$> down x1 <*> down x2 + + XCast _ CastRun x1 + -> do result <- curryX_call callables xx + case result of + Just xx' -> return xx' + Nothing -> XCast () CastRun <$> down x1 + + -- Boilerplate. + XCon _ c + -> return $ XCon () c + + XLam _ b xBody + -> let callables' = shadowCallables [b] callables + in XLam () b <$> curryX callables' xBody + + XLAM _ b xBody + -> XLAM () b <$> curryX callables xBody + + XLet _ lts@(LLet b _) xBody + -> let callables' = shadowCallables [b] callables + in XLet () <$> curryLts callables' lts + <*> curryX callables' xBody + + XLet _ lts@(LRec bxs) xBody + -> let bs = map fst bxs + callables' = shadowCallables bs callables + in XLet () <$> curryLts callables' lts + <*> curryX callables' xBody + + XLet _ lts@(LPrivate{}) xBody + -> XLet () <$> curryLts callables lts + <*> curryX callables xBody + + XCase _ x as + -> XCase () <$> down x + <*> mapM (curryAlt callables) as + + XCast _ c xBody + -> XCast () <$> return (reannotate (const ()) c) + <*> curryX callables xBody + + XType _ t + -> return $ XType () t + + XWitness _ w + -> return $ XWitness () (reannotate (const ()) w) + + +-- If we introduce a locally bound name with the same name as one of +-- the top-level callable things then we need to remove it from the map +-- of callables. References in the new context refer to the local thing +-- instead. +shadowCallables :: [Bind Name] -> Map Name Callable -> Map Name Callable +shadowCallables bs callables + = List.foldl' (flip Map.delete) callables + $ mapMaybe takeNameOfBind bs + + +-- | Build a function call for the given application expression. +curryX_call + :: Map Name Callable + -> Exp (AnTEC a Name) Name + -> Either Error (Maybe (Exp () Name)) + +curryX_call callables xx + + -- If this is a call of a named function then split it into the + -- functional part and arguments, then work out how to call it. + | (xF, esArgs) <- Call.takeCallElim xx + , XVar aF (UName nF) <- xF + , length esArgs > 0 + = do esArgs' <- mapM downElim esArgs + makeCall callables nF (annotType aF) esArgs' + + | otherwise + = return $ Nothing + + where downElim ee + = case ee of + Call.ElimType _ _ t + -> return $ Call.ElimType () () t + + Call.ElimValue _ x + -> Call.ElimValue () + <$> curryX callables x + + Call.ElimRun _ + -> return $ Call.ElimRun () + + +-- | Manage function application in a let binding. +curryLts :: Map Name Callable + -> Lets (AnTEC a Name) Name + -> Either Error (Lets () Name) + +curryLts callables lts + = case lts of + LLet b x + -> LLet b <$> curryX callables x + + LRec bxs + -> do let (bs, xs) = unzip bxs + xs' <- mapM (curryX callables) xs + return $ LRec $ zip bs xs' + + LPrivate bs mt ws + -> return $ LPrivate bs mt ws + + +-- | Manage function application in a case alternative. +curryAlt :: Map Name Callable + -> Alt (AnTEC a Name) Name + -> Either Error (Alt () Name) + +curryAlt callables alt + = case alt of + AAlt w xBody + -> let bs = bindsOfPat w + callables' = shadowCallables bs callables + in AAlt w <$> curryX callables' xBody + diff --git a/DDC/Core/Tetra/Transform/Curry/Call.hs b/DDC/Core/Tetra/Transform/Curry/Call.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Transform/Curry/Call.hs @@ -0,0 +1,95 @@ + +module DDC.Core.Tetra.Transform.Curry.Call + (makeCall) +where +import DDC.Core.Tetra.Transform.Curry.CallSuper +import DDC.Core.Tetra.Transform.Curry.CallThunk +import DDC.Core.Tetra.Transform.Curry.Callable +import DDC.Core.Tetra.Transform.Curry.Error +import DDC.Core.Tetra.Prim +import DDC.Core.Exp +import DDC.Type.Equiv +import Control.Monad +import Data.Map (Map) +import qualified DDC.Core.Call as Call +import qualified Data.Map as Map + + +-- | Call a thing, depending on what it is. +-- Decide how to call the functional thing, depending on +-- whether its a super, foreign imports, or thunk. +makeCall + :: Map Name Callable -- ^ Types and arities of functions in the environment. + -> Name -- ^ Name of function to call. + -> Type Name -- ^ Type of function to call. + -> [Call.Elim () Name] -- ^ Eliminators for function call. + -> Either Error (Maybe (Exp () Name)) + +makeCall callables nFun tFun esArgs + + -- Call of a local or imported super. + | Just (tFunTable, csF) + <- case Map.lookup nFun callables of + Just (Callable _ tFunTable csFun) -> Just (tFunTable, csFun) + _ -> Nothing + = do + -- Internal sanity check: the type annotation on the function + -- to call should match the type we have for it in the callables + -- table. If not then we're bugged. + when (not $ equivT tFun tFunTable) + $ Left $ ErrorSuperTypeMismatch nFun tFun tFunTable + + case Call.dischargeConsWithElims csF esArgs of + -- Saturating call. + -- We have matching eliminators for all the constructors. + ([], []) + -> fmap Just $ makeCallSuperSaturated nFun csF esArgs + + -- Under application. + -- The eliminators have all been used up, + -- but the super that we're applying still has outer constructors. + -- We need to build a PAP object to store the eliminators we have, + -- rather than calling the super right now. + (_csRemain, []) + -> makeCallSuperUnder nFun tFun csF esArgs + + -- Over application. + -- The constructors have all been used up, + -- but we still have eliminators at the call site. + ([], esOver) + -> do -- Split off enough eliminators to saturate the super. + let nSat = length csF + let esSat = take nSat esArgs + + -- Apply the super to all its arguments, + -- which yields a thunk that wants more arguments. + xApp <- makeCallSuperSaturated nFun csF esSat + + -- Work out the type of the returned thunk. + -- If this fails then the expression was mis-typed, + -- or the arity information we had was wrong. + tFun' <- case Call.dischargeTypeWithElims tFun esSat of + Just tFun' -> return tFun' + Nothing -> Left $ ErrorSuperCallPatternMismatch + nFun (Just tFun) Nothing esSat + + -- Apply the resulting thunk to the remaining arguments. + makeCallThunk xApp tFun' esOver + + -- Bad application. + -- The eliminators we have do not match the constructors of the + -- thing that we're applying. The program is mis-typed. + (_, _) + -> Left $ ErrorSuperCallPatternMismatch + nFun (Just tFun) Nothing esArgs + + -- Apply a thunk to some arguments. + -- The functional part is a variable bound to a thunk object. + | length esArgs > 0 + = makeCallThunk (XVar () (UName nFun)) tFun esArgs + + -- This was an existing thunk applied to no arguments, + -- so we can just return it without doing anything. + | otherwise + = return $ Nothing + diff --git a/DDC/Core/Tetra/Transform/Curry/CallSuper.hs b/DDC/Core/Tetra/Transform/Curry/CallSuper.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Transform/Curry/CallSuper.hs @@ -0,0 +1,131 @@ + +module DDC.Core.Tetra.Transform.Curry.CallSuper + ( makeCallSuperSaturated + , makeCallSuperUnder) +where +import DDC.Core.Tetra.Transform.Curry.Error +import DDC.Core.Tetra.Prim +import DDC.Core.Exp.Annot +import qualified DDC.Type.Transform.Instantiate as T +import qualified DDC.Core.Tetra.Compounds as C +import qualified DDC.Core.Call as Call + + +--------------------------------------------------------------------------------------------------- +-- | Fully saturated application. +-- +-- When the eliminators at the call site exactly match the way the super +-- is constructed then we can call the super directly. In the generated +-- object code we do a standard function call. +-- +makeCallSuperSaturated + :: Name -- ^ Name of super to call. + -> [Call.Cons Name] -- ^ How the super is constructed. + -> [Call.Elim () Name] -- ^ Eliminators at call site. + -> Either Error (Exp () Name) + +makeCallSuperSaturated nF cs es + | length es == length cs + , and $ zipWith Call.elimForCons es cs + = return $ foldl Call.applyElim (XVar () (UName nF)) es + + | otherwise + = Left $ ErrorSuperCallPatternMismatch nF Nothing (Just cs) es + + +--------------------------------------------------------------------------------------------------- +-- | Under saturated application. +-- +-- When we don't have enough eliminators to match all the constructors +-- in the function header then the application is under-saturated. +-- +-- We build a PAP object to store the arguments we have at the moment, +-- and the runtime will wait until we have the full set until calling +-- the underlying super. +-- +-- This only works for supers in the standard form, +-- eg /\(a1 : k1). .. /\(a2 : k1). \(x1 : t1). .. \(x2 : t2). box +-- +-- At the call site we must provide type arguments to satify +-- all the type parameters, but don't need to supply all the value +-- arguments, or to run the box. We restrict the call pattern this +-- way to make the runtime easier to write, and so that we can implement +-- PAP construction and elimination using primitives with straightforward +-- types. +-- +makeCallSuperUnder + :: Name -- ^ Name of super to call. + -> Type Name -- ^ Type of super. + -> [Call.Cons Name] -- ^ How the super is constructed. + -> [Call.Elim () Name] -- ^ Eliminators at call site. + -> Either Error (Maybe (Exp () Name)) + +makeCallSuperUnder nF tF cs es + -- We have no eliminators at all, + -- so this is just a reference to a top-level super that is not + -- being applied. + -- | [] <- es + -- = return $ Just $ XVar () (UName nF) + + + -- We have more constructors than eliminators. + | length es < length cs + + -- The super and call must be in standard form. + , Just (esType, esValue, esRuns) <- Call.splitStdCallElims es + , Just (csType, _csValue, _cBox) <- Call.splitStdCallCons cs + + -- There must be types to satisfy all of the type parameters of the super. + , length esType == length csType + + -- Instantiate the type of the function. + , Just tF_inst <- T.instantiateTs tF [t | Call.ElimType _ _ t <- esType] + = let + -- Split the quantifiers, parameter type, and body type + -- from the type of the super. + (tsParam, tResult) = C.takeTFunArgResult tF_inst + + iArity = length cs + xsArgType = [XType at t | Call.ElimType _ at t <- esType] + xsArgValue = [x | Call.ElimValue _ x <- esValue] + + -- Split the value parameters into ones accepted by the super, + -- and ones that are accepted by the returned closures. + (tsParamLam, tsParamClo) + = splitAt iArity tsParam + + -- Build the type of the returned value. + tResult' = C.tFunOfParamResult tsParamClo tResult + + -- Instantiate all the type parameters. + xFunAPP = C.xApps () (XVar () (UName nF)) xsArgType + + -- Split types of the super parameters into the ones that can be + -- satisfied by this application, and the remaining parameters that + -- are still waiting for arguments. + (tsParamSat, tsParamRemain) + = splitAt (length xsArgValue) tsParamLam + + -- The type of the result after performing this application. + -- If there are remaining, un-saturated parameters the result + -- type will still be a function. + tResultClo = C.tFunOfParamResult tsParamRemain tResult' + + in case tsParamLam of + -- We should have at least one argument to apply. + -- If not then the arity information is wrong or the super we were + -- told to call doesn't have any parameters. Either case is a bug. + [] -> error $ "ddc-core-tetra.makeCallSuperUnder: no arguments to apply." + + tParamFirst : tsParamRest + -> let tSuperResult = C.tFunOfParamResult tsParamRest tResult' + in return + $ Just + $ makeRuns () (length esRuns) + $ C.xApps () (C.xFunCurry () tsParamSat tResultClo + (C.xFunCReify () tParamFirst tSuperResult xFunAPP)) + xsArgValue + + | otherwise + = return $ Nothing + diff --git a/DDC/Core/Tetra/Transform/Curry/CallThunk.hs b/DDC/Core/Tetra/Transform/Curry/CallThunk.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Transform/Curry/CallThunk.hs @@ -0,0 +1,49 @@ + +module DDC.Core.Tetra.Transform.Curry.CallThunk + (makeCallThunk) +where +import DDC.Core.Tetra.Transform.Curry.Error +import DDC.Core.Tetra.Prim +import DDC.Core.Exp.Annot +import qualified DDC.Core.Call as Call +import qualified DDC.Core.Tetra.Compounds as C + + +-- | Apply a thunk to some more arguments. +-- +-- The arguments must have be values, with type of kind `Data`. +-- If this is not true then `Nothing`. +-- +makeCallThunk + :: Exp () Name -- ^ Functional expression to apply. + -> Type Name -- ^ Type of functional expression. + -> [Call.Elim () Name] -- ^ Eliminators for applicatoin. + -> Either Error (Maybe (Exp () Name)) + +makeCallThunk xF tF esArgs + + -- Split the eliminators according to the standard call pattern. + | Just ([], esValues, esRuns) <- Call.splitStdCallElims esArgs + = let + (tsParam, tResult) = C.takeTFunArgResult tF + + -- Split the value parameters into ones applied to the thunk, + -- and the ones that form part of its resulting type. + (tsParamArg, tsParamClo) = splitAt (length esValues) tsParam + + -- Build the type of the returned closure. + -- Splitting the type like this assumes that the thunk + -- we're applying has a monomorphic type, which is true + -- for thunked supers with standard calling convention as + -- t he types of these are all prenex. + tResultClo = C.tFunOfParamResult tsParamClo tResult + + xsArgs = [ x | Call.ElimValue _ x <- esValues] + + in return + $ Just + $ makeRuns () (length esRuns) + $ C.xFunApply () tsParamArg tResultClo xF xsArgs + + | otherwise + = return $ Nothing diff --git a/DDC/Core/Tetra/Transform/Curry/Callable.hs b/DDC/Core/Tetra/Transform/Curry/Callable.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Transform/Curry/Callable.hs @@ -0,0 +1,133 @@ + +module DDC.Core.Tetra.Transform.Curry.Callable + ( Callable (..) + , CallableSource (..) + , typeOfCallable + , consOfCallable + , takeCallablesOfModule + , takeCallableFromImport + , takeCallableFromSuper) +where +import DDC.Core.Tetra.Transform.Curry.Error +import DDC.Core.Module +import DDC.Core.Exp +import DDC.Core.Exp.Annot.AnTEC +import Control.Monad +import Data.Maybe +import Data.Map (Map) +import qualified DDC.Core.Call as Call +import qualified DDC.Core.Tetra.Prim as E +import qualified Data.Map as Map + + +-- | Enough information to call a super. +-- +-- Callable supers are must use the standard call convention, +-- with their type parameters, value parameters and boxings in that order. +-- +data Callable + -- | A directly callable super in the current module. + = Callable + { callableSource :: CallableSource + , callableType :: Type E.Name + , callableCons :: [Call.Cons E.Name] } + deriving (Show) + + +-- | The source of a callable super. +data CallableSource + -- | Callable super is defined in the current module. + = CallableSuperLocal + + -- | Callable thing is a super + | CallableSuperOther + + -- | Callable super is imported from sea land. + | CallableImportSea + deriving Show + + +-- | Take the Tetra type of a callable thing. +typeOfCallable :: Callable -> Type E.Name +typeOfCallable (Callable _ t _) = t + + +-- | Take the call constructors from a `Callable`. +consOfCallable :: Callable -> [Call.Cons E.Name] +consOfCallable (Callable _ _ cs) = cs + + +-- Get callable things from the current module. +takeCallablesOfModule + :: Module (AnTEC a E.Name) E.Name + -> Either Error (Map E.Name Callable) + +takeCallablesOfModule mm + = do + -- Get callables from imported things. + nsCallableImport + <- liftM catMaybes + $ mapM (uncurry takeCallableFromImport) + $ moduleImportValues mm + + -- Get callable top-level supers. + nsCallableSuperLocal + <- mapM (uncurry takeCallableFromSuper) + $ mapTopBinds (\b x -> (b, x)) mm + + return $ Map.fromList $ nsCallableSuperLocal ++ nsCallableImport + + +-- | Take a `Callable` from an `ImportValue`, or Nothing if there isn't one. +takeCallableFromImport + :: E.Name -- ^ Name of the imported thing. + -> ImportValue E.Name -- ^ Import definition. + -> Either Error (Maybe (E.Name, Callable)) + +takeCallableFromImport n im + + -- A thing imported from some other module. + -- We determine the call pattern from its type and arity information, + -- which comes in the interface file. We need the arity information + -- because the super may return a functional value, which we cannot + -- direct from its logical type alone. + | ImportValueModule _ _ tThing (Just arity) <- im + , (nTypes, nValues, nBoxes) <- arity + = case Call.takeStdCallConsFromTypeArity tThing nTypes nValues nBoxes of + Nothing + -> Left $ ErrorSuperArityMismatch n tThing (nTypes, nValues, nBoxes) + + Just cs + -> return $ Just (n, Callable CallableSuperOther tThing cs) + + -- A thing imported from sea land. + -- We determine the call pattern directly from the type. + -- Things imported from Sea land do not return functional values, + -- so every parameter in the type is a real parameter in the call pattern. + -- + -- ISSUE #348: Restrict types of things that can be foreign imported. + -- The parameter and result type of imported functions should have + -- primitive type only, but we don't check this fact. We should also + -- check that each imported function has the standard call pattern. + -- + | ImportValueSea _ ty <- im + = let cs = Call.takeCallConsFromType ty + in return $ Just (n, Callable CallableImportSea ty cs) + + | otherwise + = return Nothing + + +-- | Take the standard call pattern from the body of a super combinator. +takeCallableFromSuper + :: Bind E.Name + -> Exp a E.Name + -> Either Error (E.Name, Callable) + +takeCallableFromSuper (BName n t) xx + = do let cs = Call.takeCallConsFromExp xx + return $ (n, Callable CallableSuperLocal t cs) + +takeCallableFromSuper b _ + = Left $ ErrorSuperUnnamed b + diff --git a/DDC/Core/Tetra/Transform/Curry/Error.hs b/DDC/Core/Tetra/Transform/Curry/Error.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Transform/Curry/Error.hs @@ -0,0 +1,73 @@ + +module DDC.Core.Tetra.Transform.Curry.Error + (Error (..)) +where +import DDC.Core.Tetra.Prim +import DDC.Type.Exp +import DDC.Base.Pretty +import qualified DDC.Core.Call as Call + + +data Error + -- | Super is not fully named. + = ErrorSuperUnnamed + { errorBind :: Bind Name } + + -- | Super is not in prenex form. + | ErrorSuperNotPrenex + { errorBind :: Bind Name } + + -- | The arity information that we have for a super does not match + -- its type. For example, the arity information may say that it + -- is a function with two parameters, but the type only has a + -- single one. + | ErrorSuperArityMismatch + { errorName :: Name + , errorType :: Type Name + , errorArity :: (Int, Int, Int) } + + -- | Type mismatch between the type annotation on a super to call, + -- and the type we have for it in the callables table. + | ErrorSuperTypeMismatch + { errorName :: Name + , errorType1 :: Type Name + , errorType2 :: Type Name } + + -- | We tried to call a super with the wrong call pattern. + | ErrorSuperCallPatternMismatch + { errorName :: Name + , errorCallType :: Maybe (Type Name) + , errorCallCons :: Maybe [Call.Cons Name] + , errorCallElims :: [Call.Elim () Name] } + deriving (Show) + + +instance Pretty Error where + ppr err + = case err of + ErrorSuperUnnamed b + -> vcat [ text "Super with binder " + <> (squotes $ ppr b) <> text " lacks a name." ] + + ErrorSuperNotPrenex b + -> vcat [ text "Super " + <> (squotes $ ppr b) <> text " is not in prenex form." ] + + ErrorSuperArityMismatch n t arity + -> vcat [ text "Arity information for " + <> ppr n <> text " does not match its type." + , text " type: " <> ppr t + , text " arity: " <> text (show arity) ] + + ErrorSuperTypeMismatch n tAnnot tTable + -> vcat [ text "Type mismatch for " + <> ppr n <> text " in super type annotation" + , text " type on annotation: " <> ppr tAnnot + , text " type of callable: " <> ppr tTable ] + + ErrorSuperCallPatternMismatch n t cs es + -> vcat [ text "Call pattern mismatch when calling " <> ppr n + , text " call type: " <> text (show t) + , text " call cons: " <> text (show cs) + , text " call elims: " <> text (show es) ] + diff --git a/ddc-core-tetra.cabal b/ddc-core-tetra.cabal --- a/ddc-core-tetra.cabal +++ b/ddc-core-tetra.cabal @@ -1,5 +1,5 @@ Name: ddc-core-tetra -Version: 0.4.1.3 +Version: 0.4.2.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -15,19 +15,23 @@ Library Build-Depends: - base >= 4.6 && < 4.8, - array >= 0.4 && < 0.6, - deepseq == 1.3.*, + base >= 4.6 && < 4.9, + array >= 0.4 && < 0.6, + deepseq >= 1.3 && < 1.5, containers == 0.5.*, + text >= 1.0 && < 1.3, + pretty-show >= 1.6.8 && < 1.7, transformers == 0.4.*, - mtl == 2.2.*, - ddc-base == 0.4.1.*, - ddc-core == 0.4.1.*, - ddc-core-salt == 0.4.1.*, - ddc-core-simpl == 0.4.1.* + mtl == 2.2.1.*, + ddc-base == 0.4.2.*, + ddc-core == 0.4.2.*, + ddc-core-salt == 0.4.2.*, + ddc-core-simpl == 0.4.2.* Exposed-modules: DDC.Core.Tetra.Transform.Boxing + DDC.Core.Tetra.Transform.Curry + DDC.Core.Tetra.Check DDC.Core.Tetra.Compounds DDC.Core.Tetra.Convert DDC.Core.Tetra.Env @@ -35,13 +39,29 @@ DDC.Core.Tetra Other-modules: - DDC.Core.Tetra.Check - DDC.Core.Tetra.Error - DDC.Core.Tetra.Profile - - DDC.Core.Tetra.Convert.Base + DDC.Core.Tetra.Convert.Exp.Alt + DDC.Core.Tetra.Convert.Exp.Arg + DDC.Core.Tetra.Convert.Exp.Base + DDC.Core.Tetra.Convert.Exp.Ctor + DDC.Core.Tetra.Convert.Exp.Lets + DDC.Core.Tetra.Convert.Exp.Lit + DDC.Core.Tetra.Convert.Exp.PrimArith + DDC.Core.Tetra.Convert.Exp.PrimBoxing + DDC.Core.Tetra.Convert.Exp.PrimCall + DDC.Core.Tetra.Convert.Exp.PrimVector + DDC.Core.Tetra.Convert.Exp.PrimError + + DDC.Core.Tetra.Convert.Type.Base + DDC.Core.Tetra.Convert.Type.DaCon + DDC.Core.Tetra.Convert.Type.Data + DDC.Core.Tetra.Convert.Type.Kind + DDC.Core.Tetra.Convert.Type.Region + DDC.Core.Tetra.Convert.Type.Super + DDC.Core.Tetra.Convert.Type.Witness + DDC.Core.Tetra.Convert.Boxing DDC.Core.Tetra.Convert.Data + DDC.Core.Tetra.Convert.Error DDC.Core.Tetra.Convert.Exp DDC.Core.Tetra.Convert.Layout DDC.Core.Tetra.Convert.Type @@ -50,11 +70,20 @@ DDC.Core.Tetra.Prim.DaConTetra DDC.Core.Tetra.Prim.OpArith DDC.Core.Tetra.Prim.OpCast - DDC.Core.Tetra.Prim.OpStore + DDC.Core.Tetra.Prim.OpError + DDC.Core.Tetra.Prim.OpFun + DDC.Core.Tetra.Prim.OpVector DDC.Core.Tetra.Prim.TyConPrim DDC.Core.Tetra.Prim.TyConTetra + DDC.Core.Tetra.Transform.Curry.Call + DDC.Core.Tetra.Transform.Curry.Callable + DDC.Core.Tetra.Transform.Curry.CallSuper + DDC.Core.Tetra.Transform.Curry.CallThunk + DDC.Core.Tetra.Transform.Curry.Error + DDC.Core.Tetra.Profile + DDC.Core.Tetra.Error GHC-options: -Wall @@ -72,4 +101,4 @@ ParallelListComp DeriveDataTypeable ViewPatterns - + BangPatterns