diff --git a/DDC/Core/Tetra.hs b/DDC/Core/Tetra.hs --- a/DDC/Core/Tetra.hs +++ b/DDC/Core/Tetra.hs @@ -3,19 +3,42 @@ ( -- * Language profile profile + -- * Program Lexing + , lexModuleString + , lexExpString + + -- * Checking + , checkModule + + -- * Conversion + , saltOfTetraModule + -- * Names , Name (..) - , TyConPrim (..) - , OpPrimArith (..) - , OpPrimRef (..) + , TyConTetra (..) + , DaConTetra (..) + , OpStore (..) + , PrimTyCon (..) + , PrimArith (..) -- * Name Parsing , readName + , readTyConTetra + , readDaConTetra + , readOpStore + , readPrimTyCon + , readPrimArith - -- * Program Lexing - , lexModuleString - , lexExpString) + -- * Name Generation + , freshT + , freshX + -- * Errors + , Error(..)) + where import DDC.Core.Tetra.Prim import DDC.Core.Tetra.Profile +import DDC.Core.Tetra.Convert hiding (Error(..)) +import DDC.Core.Tetra.Check +import DDC.Core.Tetra.Error diff --git a/DDC/Core/Tetra/Check.hs b/DDC/Core/Tetra/Check.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Check.hs @@ -0,0 +1,43 @@ + +module DDC.Core.Tetra.Check + (checkModule) +where +import DDC.Core.Tetra.Compounds +import DDC.Core.Tetra.Error +import DDC.Core.Tetra.Prim +import DDC.Core.Module +import DDC.Type.Exp + + +-- | Perform Core Tetra specific checks on a module. +checkModule :: Module a Name -> Maybe (Error a) +checkModule mm + + -- Check that the 'Main' module exports a 'main' function. + | moduleName mm == ModuleName ["Main"] + = case lookup (NameVar "main") $ moduleExportValues mm of + + -- Main module does not export any main function. + Nothing + -> Just ErrorMainMissing + + -- Main function exports a main function with the correct mode. + Just (ExportSourceLocal _ tMain) + -> let -- .. and the type is ok. + check + | Just (t1, t2) <- takeTFun tMain + , t1 == tUnit + , Just (TyConSpec TcConSusp, [_tEff, tRet]) <- takeTyConApps t2 + , tRet == tUnit + = Nothing + + -- .. but it has an invalid type. + | otherwise + = Just (ErrorMainInvalidType tMain) + in check + + -- Main module exports + Just _ -> Just ErrorMainInvalidMode + + | otherwise + = Nothing 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,10 +1,33 @@ module DDC.Core.Tetra.Compounds ( module DDC.Core.Compounds.Annot + + -- * Types , tBool , tNat , tInt - , tWord) + , tWord + + , tBoxed + , tUnboxed + + -- * Expressions + , 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 + + + +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 ] + diff --git a/DDC/Core/Tetra/Convert.hs b/DDC/Core/Tetra/Convert.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert.hs @@ -0,0 +1,214 @@ +-- | Conversion of Disciple Lite to Disciple Salt. +-- +module DDC.Core.Tetra.Convert + ( saltOfTetraModule + , Error(..)) +where +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.Salt.Platform +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.Type.DataDef +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 + + +--------------------------------------------------------------------------------------------------- +-- | Convert a Core Tetra module to Core Salt. +-- +-- The input module needs to be: +-- well typed, +-- fully named with no deBruijn indices, +-- have all functions defined at top-level, +-- have type annotations on every bound variable and constructor, +-- be a-normalised, +-- have saturated function applications, +-- not have over-applied function applications. +-- If not then `Error`. +-- +-- The output code contains: +-- debruijn indices. +-- These then need to be eliminated before it will pass the Salt fragment +-- checks. +-- +saltOfTetraModule + :: Show a + => Platform -- ^ Platform specification. + -> A.Config -- ^ Runtime configuration. + -> 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. + -> Either (Error a) (Module a A.Name) -- ^ Salt module. + +saltOfTetraModule platform runConfig defs kenv tenv mm + = {-# SCC saltOfTetraModule #-} + evalCheck () $ convertM platform runConfig defs kenv tenv mm + + +--------------------------------------------------------------------------------------------------- +convertM + :: Show a + => Platform + -> A.Config + -> DataDefs E.Name + -> KindEnv E.Name + -> TypeEnv E.Name + -> Module (AnTEC a E.Name) E.Name + -> ConvertM a (Module a A.Name) + +convertM pp runConfig defs kenv tenv mm + = do + -- Convert signatures of exported functions. + tsExports' <- mapM (convertExportM defs) $ moduleExportValues mm + + -- Convert signatures of imported functions. + tsImports' <- mapM (convertImportM defs) $ moduleImportValues mm + + -- Convert the body of the module to Salt. + let ntsImports + = [BName n (typeOfImportSource 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 } + + -- Conver the body of the module itself. + x1 <- convertExpX penv kenv tenv' ExpTop + $ moduleBody mm + + -- 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. + let a = annotOfExp x1 + let (lts', _) = splitXLets x1 + let x2 = xLets a lts' (xUnit a) + + -- Build the output module. + let mm_salt + = ModuleCore + { moduleName = moduleName mm + + -- None of the types imported by Lite modules are relevant + -- to the Salt language. + , moduleExportTypes = [] + , moduleExportValues = tsExports' + + , moduleImportTypes = Map.toList $ A.runtimeImportKinds + , moduleImportValues = (Map.toList A.runtimeImportTypes) ++ tsImports' + + -- Data constructors and pattern matches should have been + -- flattenedinto primops, so we don't need the data type + -- definitions. + , moduleDataDefsLocal = [] + + , 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 + -- 'main' function. + mm_init <- case initRuntime runConfig mm_salt of + Nothing -> throw ErrorMainHasNoMain + Just mm' -> return mm' + + return $ mm_init + + +--------------------------------------------------------------------------------------------------- +-- | Convert an export spec. +convertExportM + :: DataDefs E.Name + -> (E.Name, ExportSource E.Name) + -> ConvertM a (A.Name, ExportSource A.Name) + +convertExportM defs (n, esrc) + = do n' <- convertBindNameM n + esrc' <- convertExportSourceM defs esrc + return (n', esrc') + + +-- Convert an export source. +convertExportSourceM + :: DataDefs E.Name + -> ExportSource E.Name + -> ConvertM a (ExportSource A.Name) + +convertExportSourceM defs esrc + = case esrc of + ExportSourceLocal n t + -> do n' <- convertBindNameM n + t' <- convertRepableT defs Env.empty t + return $ ExportSourceLocal n' t' + + ExportSourceLocalNoType n + -> do n' <- convertBindNameM n + return $ ExportSourceLocalNoType n' + + +--------------------------------------------------------------------------------------------------- +-- | Convert an import spec. +convertImportM + :: DataDefs E.Name + -> (E.Name, ImportSource E.Name) + -> ConvertM a (A.Name, ImportSource A.Name) + +convertImportM defs (n, isrc) + = do n' <- convertImportNameM n + isrc' <- convertImportSourceM defs isrc + return (n', isrc') + + +-- | Convert an imported name. +-- These can be variable names for values, +-- or variable or constructor names for type imports. +convertImportNameM :: E.Name -> ConvertM a A.Name +convertImportNameM n + = case n of + E.NameVar str -> return $ A.NameVar str + E.NameCon str -> return $ A.NameCon str + _ -> throw $ ErrorInvalidBinder n + + +-- | Convert an import source. +convertImportSourceM + :: DataDefs E.Name + -> ImportSource E.Name + -> ConvertM a (ImportSource A.Name) + +convertImportSourceM defs 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' + + ImportSourceSea str t + -> do t' <- convertRepableT defs Env.empty t + return $ ImportSourceSea str t' + + diff --git a/DDC/Core/Tetra/Convert/Base.hs b/DDC/Core/Tetra/Convert/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Base.hs @@ -0,0 +1,87 @@ + +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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Boxing.hs @@ -0,0 +1,170 @@ + +-- | Punned data type and constructor definitions for boxed numeric objects. +-- +-- Boxed numeric objects are treated abstractly by the source language, and +-- aren't really algebraic data, but we define them as such so that we can +-- re-use the to-salt conversion code for algebraic data. +-- +-- Each primitive numeric type like (Nat#) induces a data type and data +-- constructor of the same name. +-- +-- The data constructor has a single unboxed field (U# Nat#) and produces +-- a boxed result type (B# Nat#). Note that the name of the data type (Nat#) +-- is different from the result type (B# Nat#), which is unlike real algebraic +-- data types. +-- +module DDC.Core.Tetra.Convert.Boxing + ( isSomeRepType + , isBoxedRepType + , isUnboxedRepType + , isBoxableIndexType + , takeIndexOfBoxedRepType + , makeDataTypeForBoxableIndexType + , makeDataCtorForBoxableIndexType) +where +import DDC.Core.Tetra.Prim +import DDC.Core.Tetra.Compounds +import DDC.Type.DataDef +import DDC.Type.Exp + + +-- Predicates ----------------------------------------------------------------- +-- | Check if this is a representable type. +-- This is the union of `isBoxedRepType` and `isUnboxedRepType`. +isSomeRepType :: Type Name -> Bool +isSomeRepType tt + = isBoxedRepType tt || isUnboxedRepType tt + + +-- | Check if some representation type is boxed. +-- The type must have kind Data, otherwise bogus result. +-- +-- A "representation type" is the sort of type we get after applying the +-- Boxing transform, which works out how to represent everything. +-- +-- The boxed representation types are: +-- 1) 'a -> b' -- the function type +-- 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 +isBoxedRepType tt + | Just _ <- takeTFun tt + = True + + | TVar{} <- tt = True + | TForall{} <- tt = True + + -- Unit data type. + | Just (TyConSpec TcConUnit, _) <- takeTyConApps tt + = True + + -- User defined data types. + | Just (TyConBound (UName _) _, _) <- takeTyConApps tt + = True + + -- Boxed numeric types + | Just ( NameTyConTetra TyConTetraB + , [ti]) <- takePrimTyConApps tt + , isBoxableIndexType ti + = True + + | otherwise + = False + + +-- | Check if some representation type is unboxed. +-- The type must have kind Data, otherwise bogus result. +-- +-- A "representation type" is the sort of type we get after applying the +-- Boxing transform, which works out how to represent everything. +-- +-- The unboxed representation are are: +-- 1) 'U# T' -- unboxed numeric types, where T is a boxable type. +-- +isUnboxedRepType :: Type Name -> Bool +isUnboxedRepType tt + -- Unboxed numeric types. + | Just ( NameTyConTetra TyConTetraU + , [ti]) <- takePrimTyConApps tt + , isBoxableIndexType 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 + + | 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 + + | otherwise + = Nothing + + +-- Punned Defs ---------------------------------------------------------------- +-- | Generic data type definition for a primitive numeric type. +makeDataTypeForBoxableIndexType :: Type Name -> Maybe (DataType Name) +makeDataTypeForBoxableIndexType tt + | Just (n@NamePrimTyCon{}, []) <- takePrimTyConApps tt + = Just $ DataType + { dataTypeName = n + , dataTypeParams = [] + , dataTypeMode = DataModeLarge + , dataTypeIsAlgebraic = False } + + | otherwise + = Nothing + + +-- | Generic data constructor definition for a primtive numeric type. +makeDataCtorForBoxableIndexType :: Type Name -> Maybe (DataCtor Name) +makeDataCtorForBoxableIndexType tt + | Just (n@NamePrimTyCon{}, []) <- takePrimTyConApps tt + = Just $ DataCtor + { dataCtorName = n + , dataCtorTag = 0 + , dataCtorFieldTypes = [tUnboxed tt] + , dataCtorResultType = tBoxed tt + , dataCtorTypeName = n + , dataCtorTypeParams = [] } + + | otherwise + = Nothing + diff --git a/DDC/Core/Tetra/Convert/Data.hs b/DDC/Core/Tetra/Convert/Data.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Data.hs @@ -0,0 +1,158 @@ + +module DDC.Core.Tetra.Convert.Data + ( constructData + , destructData) +where +import DDC.Core.Tetra.Convert.Base +import DDC.Core.Tetra.Convert.Layout +import DDC.Core.Salt.Platform +import DDC.Core.Transform.LiftX +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 +import qualified DDC.Core.Salt.Compounds as A +import Data.Maybe + + +-- Construct ------------------------------------------------------------------ +-- | Build an expression that allocates and initialises a data object. +constructData + :: Show a + => Platform -- ^ Platform definition. + -> KindEnv E.Name -- ^ Kind environment. + -> TypeEnv E.Name -- ^ Type environment. + -> a -- ^ Annotation to use on expressions. + -> DataType E.Name -- ^ Data Type definition of object. + -> DataCtor E.Name -- ^ Constructor definition of object. + -> Type A.Name -- ^ Prime region variable. + -> [Exp a A.Name] -- ^ Field values. + -> [Type A.Name] -- ^ Field types. + -> ConvertM a (Exp a A.Name) + +constructData pp _kenv _tenv a _dataDef ctorDef rPrime xsFields tsFields + | Just HeapObjectBoxed <- heapObjectOfDataCtor pp ctorDef + = do + -- Allocate the object. + let arity = length tsFields + let bObject = BAnon (A.tPtr rPrime A.tObj) + let xAlloc = A.xAllocBoxed a rPrime (dataCtorTag ctorDef) + $ A.xNat a (fromIntegral arity) + + -- Statements to write each of the fields. + let xObject' = XVar a $ UIx 0 + let lsFields + = [ LLet (BNone A.tVoid) + (A.xSetFieldOfBoxed a + rPrime trField xObject' ix (liftX 1 xField)) + | ix <- [0..] + | xField <- xsFields + | trField <- tsFields ] + + return $ XLet a (LLet bObject xAlloc) + $ foldr (XLet a) xObject' lsFields + + + | Just HeapObjectRawSmall <- heapObjectOfDataCtor pp ctorDef + , Just size <- payloadSizeOfDataCtor pp ctorDef + = do + -- Allocate the object. + let bObject = BAnon (A.tPtr rPrime A.tObj) + let xAlloc = A.xAllocRawSmall 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 + $ XVar a (UIx 0) + + -- Get the offset of each field. + let Just offsets = fieldOffsetsOfDataCtor pp ctorDef + + -- Statements to write each of the fields. + 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)) + | tField <- tsFields + | offset <- offsets + | xField <- xsFields] + + return $ XLet a (LLet bObject xAlloc) + $ XLet a (LLet bPayload xPayload) + $ foldr (XLet a) xObject' lsFields + + | otherwise + = error $ unlines + [ "constructData: don't know how to construct a " + ++ (show $ dataCtorName ctorDef) + , " heapObject = " ++ (show $ heapObjectOfDataCtor pp ctorDef) + , " fields = " ++ (show $ dataCtorFieldTypes ctorDef) + , " size = " ++ (show $ payloadSizeOfDataCtor pp ctorDef) ] + + +-- Destruct ------------------------------------------------------------------- +-- | Wrap a expression in let-bindings that bind each of the fields of +-- of a data object. This is used when pattern matching in a case expression. +-- +-- We take a `Bound` for the scrutinee instead of a general expression because +-- we refer to it several times, and don't want to recompute it each time. +-- +destructData + :: Platform + -> a + -> DataCtor E.Name -- ^ Definition of the data constructor to unpack. + -> Bound A.Name -- ^ Bound of Scruitinee. + -> Type A.Name -- ^ Prime region. + -> [Bind A.Name] -- ^ Binders for each of the fields. + -> Exp a A.Name -- ^ Body expression that uses the field binders. + -> ConvertM a (Exp a A.Name) + +destructData pp a ctorDef uScrut trPrime bsFields xBody + | Just HeapObjectBoxed <- heapObjectOfDataCtor pp ctorDef + = do + -- Bind pattern variables to each of the fields. + let lsFields + = catMaybes + $ [ if isBNone bField + then Nothing + else Just $ LLet bField + (A.xGetFieldOfBoxed a trPrime tField + (XVar a uScrut) ix) + | bField <- bsFields + | tField <- map typeOfBind bsFields + | ix <- [0..] ] + + return $ foldr (XLet a) xBody lsFields + + | Just HeapObjectRawSmall <- heapObjectOfDataCtor pp ctorDef + , Just offsets <- fieldOffsetsOfDataCtor pp ctorDef + = 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) + + -- Bind pattern variables to the fields. + let uPayload = UIx 0 + let lsFields + = catMaybes + $ [ if isBNone bField + then Nothing + else Just $ LLet bField + (A.xPeekBuffer a trPrime tField + (XVar a uPayload) offset) + | bField <- bsFields + | tField <- map typeOfBind bsFields + | offset <- offsets ] + + return $ foldr (XLet a) xBody + $ LLet bPayload xPayload : lsFields + + | otherwise + = throw ErrorInvalidAlt diff --git a/DDC/Core/Tetra/Convert/Exp.hs b/DDC/Core/Tetra/Convert/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Exp.hs @@ -0,0 +1,770 @@ +-- | Conversion of Disciple Lite to Disciple Salt. +module DDC.Core.Tetra.Convert.Exp + ( TopEnv (..) + , ExpContext (..) + , convertExpX) +where +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.Type.Universe +import DDC.Type.DataDef +import DDC.Type.Env (KindEnv, TypeEnv) +import qualified DDC.Type.Env as Env + +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 + + +--------------------------------------------------------------------------------------------------- +-- | 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 + :: 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) + +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 + + 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." ] + + XVar a u + -> do let a' = annotTail a + u' <- convertValueU u + return $ XVar a' u' + + XCon a dc + -> do xx' <- convertCtorAppX penv kenv tenv 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 + -> throw $ ErrorUnsupported xx + $ 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 + -> 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'] + + + --------------------------------------------------- + -- 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' + + --------------------------------------------------- + -- 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'] + + + --------------------------------------------------- + -- 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. + 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 + else throw $ ErrorUnsupported xx + $ text "Partial application of primitive data constructors is not supported." + + + -- Fully applied user-defined data constructor application. + -- The types of these are in the defs list. + 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 + == length (dataCtorTypeParams dataCtor) + + length (dataCtorFieldTypes dataCtor) + then downCtorAppX 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." + + + --------------------------------------------------- + -- Saturated application of a top-level supercombinator or imported function. + -- This does not cover application of primops, the above case should + -- fire for these. + 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 + + -- 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' + + + --------------------------------------------------- + -- 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 + -> do -- Convert the bindings. + lts' <- convertLetsX penv kenv tenv 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 + + 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." ] + + + --------------------------------------------------- + -- 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 + -> do + -- Convert the scrutinee. + xScrut' <- convertExpX penv kenv tenv ExpArg xScrut + + -- Convert the alternatives. + alts' <- mapM (convertAlt penv kenv tenv (min ctx ExpBody) + a' uScrut tScrut) + alts + + return $ XCase a' xScrut' alts' + + + --------------------------------------------------- + -- Match against finite algebraic data. + -- The branch is against the constructor tag. + XCase (AnTEC tX _ _ a') xScrut@(XVar (AnTEC tScrut _ _ _) uScrut) alts + | TCon _ : _ <- takeTApps tScrut + , isSomeRepType tScrut + -> do + -- Convert scrutinee, and determine its prime region. + x' <- convertExpX penv kenv tenv ExpArg xScrut + tX' <- convertRepableT defs kenv tX + + tScrut' <- convertRepableT defs kenv tScrut + let tPrime = fromMaybe A.rTop + $ takePrimeRegion tScrut' + + -- Convert alternatives. + alts' <- mapM (convertAlt penv kenv tenv (min ctx ExpBody) + a' uScrut tScrut) + alts + + -- If the Tetra program does not have a default alternative + -- then add our own to the Salt program. We need this to handle + -- the case where the Tetra program does not cover all the + -- possible cases. + let hasDefaultAlt + = any isPDefault [p | AAlt p _ <- alts] + + let newDefaultAlt + | hasDefaultAlt = [] + | otherwise = [AAlt PDefault (A.xFail a' tX')] + + return $ XCase a' (A.xGetTag a' tPrime x') + $ alts' ++ newDefaultAlt + + + --------------------------------------------------- + -- Trying to matching against something that isn't a primitive numeric + -- type or alebraic data. + -- + -- We don't handle matching purely polymorphic data against the default + -- alterative, (\x. case x of { _ -> x}), because the type of the + -- scrutinee isn't constrained to be an algebraic data type. These dummy + -- expressions need to be eliminated before conversion. + XCase{} + -> throw $ ErrorUnsupported xx + $ text "Unsupported form of case expression" + + --------------------------------------------------- + -- Casts. + XCast _ _ x + -> convertExpX penv kenv tenv (min ctx ExpBody) x + + + -- We shouldn't find any naked types. + -- These are handled above in the XApp case. + XType{} + -> throw $ ErrorMalformed "Found a naked type argument." + + + -- We shouldn't find any naked witnesses. + 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 + :: 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. + -> 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 + + -- 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') + + -- 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') + + -- 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." ] + + -- Witness arguments are discarded. + | XWitness{} <- xx + = return $ Nothing + + -- Expression arguments. + | otherwise + = do x' <- convertExpX penv kenv tenv ExpArg xx + return $ Just x' + + +-- | 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 + + +--------------------------------------------------------------------------------------------------- +-- | 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." + + | otherwise + = throw $ ErrorMalformed "Invalid literal." + + +--------------------------------------------------------------------------------------------------- +-- [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/Layout.hs b/DDC/Core/Tetra/Convert/Layout.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Layout.hs @@ -0,0 +1,152 @@ + +-- | Layout of algebraic data. +module DDC.Core.Tetra.Convert.Layout + ( -- * Heap Objects + HeapObject(..) + , heapObjectOfDataCtor + + -- * Fields + , payloadSizeOfDataCtor + , fieldOffsetsOfDataCtor) +where +import DDC.Core.Tetra.Convert.Boxing +import DDC.Core.Tetra.Prim +import DDC.Core.Salt.Platform +import DDC.Type.Compounds +import DDC.Type.DataDef +import DDC.Type.Exp +import Control.Monad +import Data.Maybe +import qualified DDC.Core.Salt.Name as A + + +-- HeapObject ----------------------------------------------------------------- +-- | Enumerates the heap object formats that can be used to store +-- algebraic data. +-- +-- The layout of these is defined in the @ObjectNN.dce@ file of the runtime +-- system, where @NN@ is the word size of the machine. +data HeapObject + = HeapObjectBoxed + | HeapObjectMixed + | HeapObjectRaw + | HeapObjectRawSmall + deriving (Eq, Show) + + +-- | Decide which heap object to use to represent a data constructor. +heapObjectOfDataCtor :: Platform -> DataCtor Name -> Maybe HeapObject +heapObjectOfDataCtor pp ctor + + -- If all the fields are boxed objects then used a Boxed heap object, + -- as these just contain pointer fields. + | tsFields <- dataCtorFieldTypes ctor + , all isBoxedRepType tsFields + = Just HeapObjectBoxed + + -- All of the fixed size primitive 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 + , Just (NamePrimTyCon ptc, []) <- takePrimTyConApps tp + , isJust $ A.primTyConWidth pp ptc + = Just HeapObjectRawSmall + + | otherwise + = Nothing + + +-- Field Layout --------------------------------------------------------------- +-- | Get the size of the payload for this data constructor. +-- The payload holds all the fields, but does not include +-- header information such as the constructor tag. +-- +-- This doesn't add any padding for misaligned fields. +payloadSizeOfDataCtor :: Platform -> DataCtor Name -> Maybe Integer +payloadSizeOfDataCtor platform ctor + = liftM sum + $ sequence + $ map (fieldSizeOfType platform) + $ dataCtorFieldTypes ctor + + +-- | Given a constructor definition, +-- get the offset of each field in the payload of a heap object. +-- +-- We don't know the absolute offset from the beginning of the heap +-- object, because the size of the header is only known by the runtime +-- system. +-- +-- This doesn't add any padding for misaligned fields. +fieldOffsetsOfDataCtor :: Platform -> DataCtor Name -> Maybe [Integer] +fieldOffsetsOfDataCtor platform ctor + = liftM (init . scanl (+) 0) + $ sequence + $ map (fieldSizeOfType platform) + $ dataCtorFieldTypes ctor + + +-- | Get the raw size of a field of this type, without padding. +fieldSizeOfType :: Platform -> Type Name -> Maybe Integer +fieldSizeOfType platform tt + = case tt of + TVar{} -> Just $ platformAddrBytes platform + + TCon tc + -> case tc of + TyConBound (UPrim n _) _ -> fieldSizeOfPrim platform n + TyConBound _ _ -> Just $ platformAddrBytes platform + _ -> Nothing + + -- We're not supporting polymorphic fields yet. + TForall{} -> Nothing + + -- Assume anything that isn't a primitive constructor is + -- represented by a pointer. + TApp{} -> Just $ platformAddrBytes platform + + -- We shouldn't find any TSums, because field types always have + -- kind data. + TSum{} -> Nothing + + +-- | Get the raw size of a value with this type name. +fieldSizeOfPrim :: Platform -> Name -> Maybe Integer +fieldSizeOfPrim platform nn + = case nn of + NameDaConTetra{} -> Just $ platformAddrBytes platform + NamePrimTyCon tc -> fieldSizeOfPrimTyCon platform tc + _ -> Nothing + + +-- | Get the raw size of a value with this primitive type constructor. +fieldSizeOfPrimTyCon :: Platform -> PrimTyCon -> Maybe Integer +fieldSizeOfPrimTyCon platform tc + = case tc of + -- It might make sense to represent these as zero bytes, + -- 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 + PrimTyConNat -> Just $ platformNatBytes platform + PrimTyConInt -> Just $ platformNatBytes platform + PrimTyConTag -> Just $ platformTagBytes platform + PrimTyConBool -> Just $ 1 + + PrimTyConWord bits + | bits `rem` 8 == 0 -> Just $ fromIntegral $ bits `div` 8 + | otherwise -> Nothing + + PrimTyConFloat bits + | bits `rem` 8 == 0 -> Just $ fromIntegral $ bits `div` 8 + | otherwise -> Nothing + + -- Vectors don't appear as raw fields. + PrimTyConVec{} -> Nothing + + -- Strings shouldn't appear as raw fields, only pointers to them. + PrimTyConString -> Nothing + diff --git a/DDC/Core/Tetra/Convert/Type.hs b/DDC/Core/Tetra/Convert/Type.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Convert/Type.hs @@ -0,0 +1,541 @@ + +module DDC.Core.Tetra.Convert.Type + ( -- * Kind conversion. + convertK + + -- * Type conversion. + , convertRegionT + , convertIndexT + , convertCapabilityT + , convertDataT + , convertRepableT + + -- * Data constructor conversion. + , convertDaCon + + -- * Bind and Bound conversion. + , convertTypeB + , convertTypeU + + , convertValueB + , convertRepableB + , convertCapabilityB + , convertValueU + + -- * Names + , convertBindNameM + + -- * Prime regions + , saltPrimeRegionOfDataType + , saltDataTypeOfArgType) +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) + 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 @@ -27,29 +27,45 @@ primDataDefs = fromListDataDefs -- Primitive ----------------------------------------------- - -- Bool - [ DataDef (NameTyConPrim TyConPrimBool) + -- Bool# + $ [ makeDataDefAlg (NamePrimTyCon PrimTyConBool) [] (Just [ (NameLitBool True, []) , (NameLitBool False, []) ]) - -- Nat - , DataDef (NameTyConPrim TyConPrimNat) [] Nothing + -- Nat# + , makeDataDefAlg (NamePrimTyCon PrimTyConNat) [] Nothing - -- Int - , DataDef (NameTyConPrim TyConPrimInt) [] Nothing + -- Int# + , makeDataDefAlg (NamePrimTyCon PrimTyConInt) [] Nothing - -- WordN - , DataDef (NameTyConPrim (TyConPrimWord 64)) [] Nothing - , DataDef (NameTyConPrim (TyConPrimWord 32)) [] Nothing - , DataDef (NameTyConPrim (TyConPrimWord 16)) [] Nothing - , DataDef (NameTyConPrim (TyConPrimWord 8)) [] Nothing + -- WordN# + , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 64)) [] Nothing + , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 32)) [] Nothing + , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 16)) [] Nothing + , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 8)) [] Nothing - -- Ref - , DataDef (NameTyConPrim TyConPrimRef) [] Nothing + -- Ref# + , makeDataDefAbs (NameTyConTetra TyConTetraRef) [] ] + -- Tuple + -- Hard-code maximum tuple arity to 32. + -- We don't have a way of avoiding the upper bound. + ++ [ makeTupleDataDef arity + | arity <- [2..32] ] + +-- | Make a tuple data def for the given tuple arity. +makeTupleDataDef :: Int -> DataDef Name +makeTupleDataDef n + = makeDataDefAlg + (NameTyConTetra (TyConTetraTuple n)) + (replicate n (BAnon kData)) + (Just [ ( NameDaConTetra (DaConTetraTuple n) + , (reverse [tIx kData i | i <- [0..n - 1]]))]) + + -- Sorts --------------------------------------------------------------------- -- | Sort environment containing sorts of primitive kinds. primSortEnv :: Env Name @@ -74,7 +90,8 @@ kindOfPrimName :: Name -> Maybe (Kind Name) kindOfPrimName nn = case nn of - NameTyConPrim tc -> Just $ kindTyConPrim tc + NameTyConTetra tc -> Just $ kindTyConTetra tc + NamePrimTyCon tc -> Just $ kindPrimTyCon tc _ -> Nothing @@ -89,8 +106,10 @@ typeOfPrimName :: Name -> Maybe (Type Name) typeOfPrimName dc = case dc of - NameOpPrimArith p -> Just $ typeOpPrimArith p - NameOpPrimRef p -> Just $ typeOpPrimRef p + NameDaConTetra p -> Just $ typeDaConTetra p + NameOpStore p -> Just $ typeOpStore p + NamePrimArith p -> Just $ typePrimArith p + NamePrimCast p -> Just $ typePrimCast p NameLitBool _ -> Just $ tBool NameLitNat _ -> Just $ tNat diff --git a/DDC/Core/Tetra/Error.hs b/DDC/Core/Tetra/Error.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Error.hs @@ -0,0 +1,33 @@ + +module DDC.Core.Tetra.Error + (Error (..)) +where +import DDC.Core.Tetra.Prim +import DDC.Core.Pretty +import DDC.Type.Exp + + +-- | Fragment specific errors. +data Error a + -- | Main module does not export a 'main' function. + = ErrorMainMissing + + -- | Main module exports a 'main' function in an invalid way. + | ErrorMainInvalidMode + + -- | Main module exports a 'main' function with an invalid type. + | ErrorMainInvalidType (Type Name) + deriving Show + + +instance Pretty (Error a) where + ppr ErrorMainMissing + = vcat [ text "Main module does not export a 'main' function." ] + + ppr (ErrorMainInvalidMode) + = vcat [ text "Invalid export mode for main function in Main module." ] + + ppr (ErrorMainInvalidType t) + = 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 @@ -2,29 +2,55 @@ module DDC.Core.Tetra.Prim ( -- * Names and lexing. Name (..) + , isNameHole + , isNameLit , readName + , takeTypeOfLitName + , takeTypeOfPrimOpName + -- * Baked-in type constructors. + , TyConTetra (..) + , readTyConTetra + , kindTyConTetra + + -- * Baked-in data constructors. + , DaConTetra (..) + , readDaConTetra + , typeDaConTetra + + -- * Baked-in store operators. + , OpStore (..) + , readOpStore + , typeOpStore + -- * Primitive type constructors. - , TyConPrim (..) - , kindTyConPrim + , PrimTyCon (..) + , readPrimTyCon + , kindPrimTyCon -- * Primitive arithmetic operators. - , OpPrimArith (..) - , typeOpPrimArith + , PrimArith (..) + , readPrimArith + , typePrimArith - -- * Mutable references. - , OpPrimRef (..) - , typeOpPrimRef) + -- * Primitive numeric casts. + , PrimCast (..) + , readPrimCast + , typePrimCast) where import DDC.Core.Tetra.Prim.Base +import DDC.Core.Tetra.Prim.TyConTetra import DDC.Core.Tetra.Prim.TyConPrim -import DDC.Core.Tetra.Prim.OpPrimArith -import DDC.Core.Tetra.Prim.OpPrimRef +import DDC.Core.Tetra.Prim.DaConTetra +import DDC.Core.Tetra.Prim.OpStore +import DDC.Core.Tetra.Prim.OpArith +import DDC.Core.Tetra.Prim.OpCast import DDC.Core.Salt.Name ( readLitPrimNat , readLitPrimInt , readLitPrimWordOfBits) +import DDC.Type.Exp import DDC.Base.Pretty import Control.DeepSeq import Data.Char @@ -36,49 +62,72 @@ NameVar s -> rnf s NameCon s -> rnf s - NameTyConPrim con -> rnf con - NameOpPrimArith con -> rnf con - NameOpPrimRef con -> rnf con + NameTyConTetra con -> rnf con + NameDaConTetra con -> rnf con + NameOpStore op -> rnf op + + NamePrimTyCon 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 + NameHole -> () + instance Pretty Name where ppr nn = case nn of NameVar v -> text v NameCon c -> text c - NameTyConPrim tc -> ppr tc - NameOpPrimArith op -> ppr op - NameOpPrimRef op -> ppr op + NameTyConTetra tc -> ppr tc + NameDaConTetra dc -> ppr dc + NameOpStore op -> ppr op - NameLitBool True -> text "True" - NameLitBool False -> text "False" - NameLitNat i -> integer i - NameLitInt i -> integer i <> text "i" - NameLitWord i bits -> integer i <> text "w" <> int bits + NamePrimTyCon op -> ppr op + NamePrimArith op -> ppr op + 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 "#" + NameHole -> text "?" + + -- | Read the name of a variable, constructor or literal. readName :: String -> Maybe Name readName str + -- Baked-in names. + | Just p <- readTyConTetra str + = Just $ NameTyConTetra p + + | Just p <- readDaConTetra str + = Just $ NameDaConTetra p + + | Just p <- readOpStore str + = Just $ NameOpStore p + -- Primitive names. - | Just p <- readTyConPrim str - = Just $ NameTyConPrim p + | Just p <- readPrimTyCon str + = Just $ NamePrimTyCon p - | Just p <- readOpPrimArith str - = Just $ NameOpPrimArith p + | Just p <- readPrimArith str + = Just $ NamePrimArith p - | Just p <- readOpPrimRef str - = Just $ NameOpPrimRef p + | 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 @@ -93,6 +142,10 @@ , elem bits [8, 16, 32, 64] = Just $ NameLitWord val bits + -- Holes + | str == "?" + = Just $ NameHole + -- Constructors. | c : _ <- str , isUpper c @@ -105,3 +158,25 @@ | otherwise = Nothing + + +-- | Get the type associated with a literal name. +takeTypeOfLitName :: Name -> Maybe (Type Name) +takeTypeOfLitName nn + = case nn of + NameLitBool{} -> Just tBool + NameLitNat{} -> Just tNat + NameLitInt{} -> Just tInt + NameLitWord _ bits -> Just (tWord bits) + _ -> Nothing + + +-- | Take the type of a primitive operator. +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 + 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 @@ -1,11 +1,21 @@ module DDC.Core.Tetra.Prim.Base ( Name (..) - , TyConPrim (..) - , OpPrimArith (..) - , OpPrimRef (..)) + , isNameHole + , isNameLit + + , TyConTetra (..) + , DaConTetra (..) + , OpStore (..) + , PrimTyCon (..) + , PrimArith (..) + , PrimCast (..)) where import Data.Typeable +import DDC.Core.Salt.Name + ( PrimTyCon (..) + , PrimArith (..) + , PrimCast (..)) -- | Names of things used in Disciple Core Tetra. @@ -16,15 +26,24 @@ -- | A user defined constructor. | NameCon String + -- | Baked-in type constructors. + | NameTyConTetra TyConTetra + + -- | Baked-in data constructors. + | NameDaConTetra DaConTetra + + -- | Baked-in operators. + | NameOpStore OpStore + -- Machine primitives ------------------ -- | A primitive type constructor. - | NameTyConPrim TyConPrim + | NamePrimTyCon PrimTyCon -- | Primitive arithmetic, logic, comparison and bit-wise operators. - | NameOpPrimArith OpPrimArith + | NamePrimArith PrimArith - -- | Mutable references. - | NameOpPrimRef OpPrimRef + -- | Primitive numeric casting operators. + | NamePrimCast PrimCast -- Literals ----------------------------- -- | A boolean literal. @@ -38,73 +57,64 @@ -- | A word literal. | NameLitWord Integer Int + + -- Inference ---------------------------- + -- | Hole used during type inference. + | NameHole deriving (Eq, Ord, Show, Typeable) --- TyConPrim ------------------------------------------------------------------ --- | Primitive type constructors. -data TyConPrim - -- | @Bool@ unboxed booleans. - = TyConPrimBool +-- | Check whether a name is `NameHole`. +isNameHole :: Name -> Bool +isNameHole nn + = case nn of + NameHole -> True + _ -> False - -- | @Nat@ natural numbers. - -- Big enough to count every addressable byte in the store. - | TyConPrimNat - -- | @Int@ signed integers. - | TyConPrimInt +-- | 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 - -- | @WordN@ machine words of the given width. - | TyConPrimWord Int - -- | A mutable reference. - | TyConPrimRef - deriving (Eq, Ord, Show) +-- TyConTetra ---------------------------------------------------------------- +-- | Baked-in type constructors. +data TyConTetra + -- | @Ref#@. Mutable reference. + = TyConTetraRef + -- | @TupleN#@. Tuples. + | TyConTetraTuple Int --- OpPrimArith ---------------------------------------------------------------- --- | Primitive arithmetic, logic, and comparison opretors. --- We expect the backend/machine to be able to implement these directly. --- --- For the Shift Right operator, the type that it is used at determines --- whether it is an arithmetic (with sign-extension) or logical --- (no sign-extension) shift. -data OpPrimArith - -- numeric - = OpPrimArithNeg -- ^ Negation - | OpPrimArithAdd -- ^ Addition - | OpPrimArithSub -- ^ Subtraction - | OpPrimArithMul -- ^ Multiplication - | OpPrimArithDiv -- ^ Division - | OpPrimArithMod -- ^ Modulus - | OpPrimArithRem -- ^ Remainder + -- | @B#@. Boxing type constructor. + -- Used to represent boxed numeric values. + | TyConTetraB - -- comparison - | OpPrimArithEq -- ^ Equality - | OpPrimArithNeq -- ^ Negated Equality - | OpPrimArithGt -- ^ Greater Than - | OpPrimArithGe -- ^ Greater Than or Equal - | OpPrimArithLt -- ^ Less Than - | OpPrimArithLe -- ^ Less Than or Equal + -- | @U#@. Unboxed type constructor. + -- Used to represent unboxed numeric values. + | TyConTetraU + deriving (Eq, Ord, Show) - -- boolean - | OpPrimArithAnd -- ^ Boolean And - | OpPrimArithOr -- ^ Boolean Or - -- bitwise - | OpPrimArithShl -- ^ Shift Left - | OpPrimArithShr -- ^ Shift Right - | OpPrimArithBAnd -- ^ Bit-wise And - | OpPrimArithBOr -- ^ Bit-wise Or - | OpPrimArithBXOr -- ^ Bit-wise eXclusive Or +-- DaConTetra ---------------------------------------------------------------- +-- | Data Constructors. +data DaConTetra + -- | @TN#@. Tuple data constructors. + = DaConTetraTuple Int deriving (Eq, Ord, Show) --- OpPrimRef ------------------------------------------------------------------ +-- OpStore ------------------------------------------------------------------- -- | Mutable References. -data OpPrimRef - = OpPrimRefAllocRef -- ^ Allocate a reference. - | OpPrimRefReadRef -- ^ Read a reference. - | OpPrimRefWriteRef -- ^ Write to a reference. +data OpStore + = OpStoreAllocRef -- ^ Allocate a reference. + | OpStoreReadRef -- ^ Read a reference. + | OpStoreWriteRef -- ^ Write to a reference. deriving (Eq, Ord, Show) diff --git a/DDC/Core/Tetra/Prim/DaConTetra.hs b/DDC/Core/Tetra/Prim/DaConTetra.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Prim/DaConTetra.hs @@ -0,0 +1,42 @@ + +module DDC.Core.Tetra.Prim.DaConTetra + ( typeDaConTetra + , readDaConTetra) +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.Base.Pretty +import Control.DeepSeq +import Data.Char +import Data.List + + +instance NFData DaConTetra + +instance Pretty DaConTetra where + ppr dc + = case dc of + DaConTetraTuple n -> text "T" <> int n <> text "#" + + +-- | Read the name of a baked-in data constructor. +readDaConTetra :: String -> Maybe DaConTetra +readDaConTetra str + | Just rest <- stripPrefix "T" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , arity <- read ds + = Just $ DaConTetraTuple arity + + | otherwise + = Nothing + + +-- | Yield the type of a baked-in data constructor. +typeDaConTetra :: DaConTetra -> Type Name +typeDaConTetra (DaConTetraTuple n) + = tForalls (replicate n kData) + $ \args -> foldr tFun (tTupleN args) args + diff --git a/DDC/Core/Tetra/Prim/OpArith.hs b/DDC/Core/Tetra/Prim/OpArith.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Prim/OpArith.hs @@ -0,0 +1,63 @@ + +module DDC.Core.Tetra.Prim.OpArith + ( readPrimArith + , typePrimArith) +where +import DDC.Core.Tetra.Prim.Base +import DDC.Type.Compounds +import DDC.Type.Exp +import DDC.Core.Salt.Name (readPrimArith) + + + +-- | 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 + + -- 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 + + -- Boolean Operators. + PrimArithAnd -> tForall kData $ \tb + -> tb `tFun` tb `tFun` tb + + PrimArithOr -> tForall kData $ \tb + -> tb `tFun` tb `tFun` tb + + -- 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 + + diff --git a/DDC/Core/Tetra/Prim/OpCast.hs b/DDC/Core/Tetra/Prim/OpCast.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Prim/OpCast.hs @@ -0,0 +1,24 @@ + +module DDC.Core.Tetra.Prim.OpCast + ( readPrimCast + , typePrimCast) +where +import DDC.Core.Tetra.Prim.Base +import DDC.Type.Compounds +import DDC.Type.Exp +import DDC.Core.Salt.Name (readPrimCast) + + +-- | Take the type of a primitive numeric cast operator. +typePrimCast :: PrimCast -> Type Name +typePrimCast op + = case op of + PrimCastConvert + -> tForalls [kData, kData] $ \[t1, t2] -> t1 `tFun` t2 + + PrimCastPromote + -> tForalls [kData, kData] $ \[t1, t2] -> t1 `tFun` t2 + + PrimCastTruncate + -> tForalls [kData, kData] $ \[t1, t2] -> t1 `tFun` t2 + diff --git a/DDC/Core/Tetra/Prim/OpPrimArith.hs b/DDC/Core/Tetra/Prim/OpPrimArith.hs deleted file mode 100644 --- a/DDC/Core/Tetra/Prim/OpPrimArith.hs +++ /dev/null @@ -1,88 +0,0 @@ - -module DDC.Core.Tetra.Prim.OpPrimArith - ( readOpPrimArith - , typeOpPrimArith) -where -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 -import Data.List - - --- OpPrimArith ---------------------------------------------------------------- -instance NFData OpPrimArith - -instance Pretty OpPrimArith where - ppr op - = let Just (_, n) = find (\(p, _) -> op == p) opPrimArithNames - in (text n) - - --- | Read a primitive operator. -readOpPrimArith :: String -> Maybe OpPrimArith -readOpPrimArith str - = case find (\(_, n) -> str == n) opPrimArithNames of - Just (p, _) -> Just p - _ -> Nothing - - --- | Names of primitve operators. -opPrimArithNames :: [(OpPrimArith, String)] -opPrimArithNames - = [ (OpPrimArithNeg, "neg#") - , (OpPrimArithAdd, "add#") - , (OpPrimArithSub, "sub#") - , (OpPrimArithMul, "mul#") - , (OpPrimArithDiv, "div#") - , (OpPrimArithRem, "rem#") - , (OpPrimArithMod, "mod#") - , (OpPrimArithEq , "eq#" ) - , (OpPrimArithNeq, "neq#") - , (OpPrimArithGt , "gt#" ) - , (OpPrimArithGe , "ge#" ) - , (OpPrimArithLt , "lt#" ) - , (OpPrimArithLe , "le#" ) - , (OpPrimArithAnd, "and#") - , (OpPrimArithOr , "or#" ) - , (OpPrimArithShl, "shl#") - , (OpPrimArithShr, "shr#") - , (OpPrimArithBAnd, "band#") - , (OpPrimArithBOr, "bor#") - , (OpPrimArithBXOr, "bxor#") ] - - --- | Take the type of a primitive arithmetic operator. -typeOpPrimArith :: OpPrimArith -> Type Name -typeOpPrimArith op - = case op of - -- Numeric - OpPrimArithNeg -> tForall kData $ \t -> t `tFunPE` t - OpPrimArithAdd -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - OpPrimArithSub -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - OpPrimArithMul -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - OpPrimArithDiv -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - OpPrimArithMod -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - OpPrimArithRem -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - - -- Comparison - OpPrimArithEq -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool - OpPrimArithNeq -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool - OpPrimArithGt -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool - OpPrimArithLt -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool - OpPrimArithLe -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool - OpPrimArithGe -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool - - -- Boolean - OpPrimArithAnd -> tBool `tFunPE` tBool `tFunPE` tBool - OpPrimArithOr -> tBool `tFunPE` tBool `tFunPE` tBool - - -- Bitwise - OpPrimArithShl -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - OpPrimArithShr -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - OpPrimArithBAnd -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - OpPrimArithBOr -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - OpPrimArithBXOr -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - diff --git a/DDC/Core/Tetra/Prim/OpPrimRef.hs b/DDC/Core/Tetra/Prim/OpPrimRef.hs deleted file mode 100644 --- a/DDC/Core/Tetra/Prim/OpPrimRef.hs +++ /dev/null @@ -1,57 +0,0 @@ - -module DDC.Core.Tetra.Prim.OpPrimRef - ( readOpPrimRef - , typeOpPrimRef) -where -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 -import Data.List - - --- OpPrimArith ---------------------------------------------------------------- -instance NFData OpPrimRef - -instance Pretty OpPrimRef where - ppr op - = let Just (_, n) = find (\(p, _) -> op == p) opPrimRefNames - in (text n) - - --- | Read a primitive operator. -readOpPrimRef :: String -> Maybe OpPrimRef -readOpPrimRef str - = case find (\(_, n) -> str == n) opPrimRefNames of - Just (p, _) -> Just p - _ -> Nothing - - --- | Names of primitve operators. -opPrimRefNames :: [(OpPrimRef, String)] -opPrimRefNames - = [ (OpPrimRefAllocRef, "allocRef#") - , (OpPrimRefReadRef, "readRef#") - , (OpPrimRefWriteRef, "writeRef#") ] - - --- | Take the type of a primitive arithmetic operator. -typeOpPrimRef :: OpPrimRef -> Type Name -typeOpPrimRef op - = case op of - OpPrimRefAllocRef - -> tForalls [kRegion, kData] - $ \[tR, tA] -> tA - `tFun` tSusp (tAlloc tR) (tRef tR tA) - - OpPrimRefReadRef - -> tForalls [kRegion, kData] - $ \[tR, tA] -> tRef tR tA - `tFun` tSusp (tRead tR) tA - - OpPrimRefWriteRef - -> tForalls [kRegion, kData] - $ \[tR, tA] -> tRef tR tA `tFun` tA - `tFun` tSusp (tWrite tR) tUnit diff --git a/DDC/Core/Tetra/Prim/OpStore.hs b/DDC/Core/Tetra/Prim/OpStore.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Prim/OpStore.hs @@ -0,0 +1,56 @@ + +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/TyConPrim.hs b/DDC/Core/Tetra/Prim/TyConPrim.hs --- a/DDC/Core/Tetra/Prim/TyConPrim.hs +++ b/DDC/Core/Tetra/Prim/TyConPrim.hs @@ -1,102 +1,54 @@ -module DDC.Core.Tetra.Prim.TyConPrim - ( TyConPrim (..) - , readTyConPrim - , kindTyConPrim +module DDC.Core.Tetra.Prim.TyConPrim + ( PrimTyCon (..) + , readPrimTyCon + , kindPrimTyCon , tBool , tNat , tInt - , tWord - , tRef) + , tWord) where import DDC.Core.Tetra.Prim.Base import DDC.Core.Compounds.Annot import DDC.Core.Exp.Simple -import DDC.Base.Pretty -import Control.DeepSeq -import Data.List -import Data.Char - - -instance NFData TyConPrim where - rnf tc - = case tc of - TyConPrimWord i -> rnf i - _ -> () - - -instance Pretty TyConPrim where - ppr tc - = case tc of - TyConPrimBool -> text "Bool" - TyConPrimNat -> text "Nat" - TyConPrimInt -> text "Int" - TyConPrimWord bits -> text "Word" <> int bits - TyConPrimRef -> text "Ref" - - --- | Read a primitive type constructor. --- --- Words are limited to 8, 16, 32, or 64 bits. --- --- Floats are limited to 32 or 64 bits. -readTyConPrim :: String -> Maybe TyConPrim -readTyConPrim str - | str == "Bool" = Just $ TyConPrimBool - | str == "Nat" = Just $ TyConPrimNat - | str == "Int" = Just $ TyConPrimInt - - -- WordN - | Just rest <- stripPrefix "Word" str - , (ds, "") <- span isDigit rest - , not $ null ds - , n <- read ds - , elem n [8, 16, 32, 64] - = Just $ TyConPrimWord n - - | str == "Ref" = Just $ TyConPrimRef - - | otherwise - = Nothing +import DDC.Core.Salt.Name (readPrimTyCon) -- | Yield the kind of a type constructor. -kindTyConPrim :: TyConPrim -> Kind Name -kindTyConPrim tc +kindPrimTyCon :: PrimTyCon -> Kind Name +kindPrimTyCon tc = case tc of - TyConPrimBool -> kData - TyConPrimNat -> kData - TyConPrimInt -> kData - TyConPrimWord _ -> kData - TyConPrimRef -> kRegion `kFun` kData `kFun` kData + 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 -- Compounds ------------------------------------------------------------------ -- | Primitive `Bool` type. tBool :: Type Name -tBool = TCon (TyConBound (UPrim (NameTyConPrim TyConPrimBool) kData) kData) +tBool = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConBool) kData) kData) -- | Primitive `Nat` type. tNat :: Type Name -tNat = TCon (TyConBound (UPrim (NameTyConPrim TyConPrimNat) kData) kData) +tNat = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConNat) kData) kData) -- | Primitive `Int` type. tInt :: Type Name -tInt = TCon (TyConBound (UPrim (NameTyConPrim TyConPrimInt) kData) kData) +tInt = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConInt) kData) kData) -- | Primitive `WordN` type of the given width. tWord :: Int -> Type Name tWord bits - = TCon (TyConBound (UPrim (NameTyConPrim (TyConPrimWord bits)) kData) kData) - - --- | Primitive `Ref` type. -tRef :: Region Name -> Type Name -> Type Name -tRef tR tA - = tApps (TCon (TyConBound (UPrim (NameTyConPrim TyConPrimRef) k) k)) - [tR, tA] - where k = kRegion `kFun` kData `kFun` kData + = TCon (TyConBound (UPrim (NamePrimTyCon (PrimTyConWord bits)) kData) kData) diff --git a/DDC/Core/Tetra/Prim/TyConTetra.hs b/DDC/Core/Tetra/Prim/TyConTetra.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Prim/TyConTetra.hs @@ -0,0 +1,86 @@ + +module DDC.Core.Tetra.Prim.TyConTetra + ( kindTyConTetra + , readTyConTetra + , tRef + , tTupleN + , tBoxed + , tUnboxed) +where +import DDC.Core.Tetra.Prim.Base +import DDC.Core.Compounds.Annot +import DDC.Core.Exp.Simple +import DDC.Base.Pretty +import Control.DeepSeq +import Data.List +import Data.Char + + +instance NFData TyConTetra + +instance Pretty TyConTetra where + ppr tc + = case tc of + TyConTetraRef -> text "Ref#" + TyConTetraTuple n -> text "Tuple" <> int n <> text "#" + TyConTetraB -> text "B#" + TyConTetraU -> text "U#" + + +-- | Read the name of a baked-in type constructor. +readTyConTetra :: String -> Maybe TyConTetra +readTyConTetra str + | Just rest <- stripPrefix "Tuple" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , arity <- read ds + = Just $ TyConTetraTuple arity + + | otherwise + = case str of + "Ref#" -> Just TyConTetraRef + "B#" -> Just TyConTetraB + "U#" -> Just TyConTetraU + _ -> Nothing + + +-- | Take the kind of a baked-in type constructor. +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 + TyConTetraU -> 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 an unboxed representation type. +tUnboxed :: Type Name -> Type Name +tUnboxed t = tApp (tConTyConTetra TyConTetraU) t + + +-- Utils ---------------------------------------------------------------------- +tConTyConTetra :: TyConTetra -> Type Name +tConTyConTetra tcf + = let k = kindTyConTetra tcf + u = UPrim (NameTyConTetra tcf) k + tc = TyConBound u k + in TCon tc 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 @@ -17,20 +17,17 @@ import DDC.Type.Env (Env) import qualified DDC.Type.Env as Env --- | Language profile for Disciple Core Flow. +-- | Language profile for Disciple Core Tetra. profile :: Profile Name profile = Profile { profileName = "Tetra" , profileFeatures = features , profilePrimDataDefs = primDataDefs - , profilePrimSupers = primSortEnv , profilePrimKinds = primKindEnv , profilePrimTypes = primTypeEnv - - -- We don't need to distinguish been boxed and unboxed - -- because we allow unboxed instantiation. - , profileTypeIsUnboxed = const False } + , profileTypeIsUnboxed = const False + , profileNameIsHole = Just isNameHole } features :: Features @@ -40,6 +37,7 @@ , featuresTrackedClosures = False , featuresFunctionalEffects = False , featuresFunctionalClosures = False + , featuresEffectCapabilities = True , featuresPartialPrims = True , featuresPartialApplication = True , featuresGeneralApplication = True diff --git a/DDC/Core/Tetra/Transform/Boxing.hs b/DDC/Core/Tetra/Transform/Boxing.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Tetra/Transform/Boxing.hs @@ -0,0 +1,193 @@ + +module DDC.Core.Tetra.Transform.Boxing + (boxingModule) +where +import DDC.Core.Tetra.Compounds +import DDC.Core.Tetra.Prim +import DDC.Core.Transform.Boxing +import DDC.Core.Module +import DDC.Core.Exp + + +-- | Manage boxing of numeric values in a module. +boxingModule :: Show a => Module a Name -> Module a Name +boxingModule mm + = boxing config 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 + , configValueTypeOfLitName = takeTypeOfLitName + , configValueTypeOfPrimOpName = takeTypeOfPrimOpName + , configValueTypeOfForeignName = const Nothing + , configBoxedOfValue = boxedOfValue + , configValueOfBoxed = valueOfBoxed + , configBoxedOfUnboxed = boxedOfUnboxed + , configUnboxedOfBoxed = unboxedOfBoxed } + + +-- | 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. + -- + | 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 + + +-- | Check whether this is a boxed representation type. +isUnboxedType :: Type Name -> Bool +isUnboxedType tt + | Just (n, _) <- takePrimTyConApps tt + , NameTyConTetra TyConTetraU <- n + = True + + | otherwise = False + + +-- | 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 + | 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 + | Just (NamePrimTyCon tc, []) <- takePrimTyConApps tt + = case tc of + PrimTyConBool -> Just $ tUnboxed tBool + PrimTyConNat -> Just $ tUnboxed tNat + PrimTyConInt -> Just $ tUnboxed tInt + PrimTyConWord bits -> Just $ tUnboxed (tWord bits) + _ -> Nothing + + | otherwise = 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 + + +-- | 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 + + | 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 + + +-- | 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 + + | otherwise = 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 + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2013 The Disciplined Disciple Compiler Strike Force +Copyrite (K) 2007-2014 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy @@ -13,18 +13,4 @@ The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - -------------------------------------------------------------------------------- -Under Australian law copyright is free and automatic. -By contributing to DDC authors grant all rights they have regarding their -contributions to the other members of the Disciplined Disciple Compiler Strike -Force, past, present and future, as well as placing their contributions under -the above license. - -Use "darcs show authors" to get a list of Strike Force members. - -------------------------------------------------------------------------------- -Redistributions of libraries in ./external are governed by their own licenses: - - - TinyPTC GNU Lesser General Public License - 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.3.2.1 +Version: 0.4.1.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -15,36 +15,52 @@ Library Build-Depends: - base == 4.6.*, + base >= 4.6 && < 4.8, + array >= 0.4 && < 0.6, deepseq == 1.3.*, containers == 0.5.*, - array == 0.4.*, transformers == 0.3.*, mtl == 2.1.*, - ddc-base == 0.3.2.*, - ddc-core == 0.3.2.*, - ddc-core-salt == 0.3.2.*, - ddc-core-simpl == 0.3.2.* + ddc-base == 0.4.1.*, + ddc-core == 0.4.1.*, + ddc-core-salt == 0.4.1.*, + ddc-core-simpl == 0.4.1.* Exposed-modules: - DDC.Core.Tetra - + DDC.Core.Tetra.Transform.Boxing DDC.Core.Tetra.Compounds + DDC.Core.Tetra.Convert DDC.Core.Tetra.Env DDC.Core.Tetra.Prim - DDC.Core.Tetra.Profile + 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.Boxing + DDC.Core.Tetra.Convert.Data + DDC.Core.Tetra.Convert.Exp + DDC.Core.Tetra.Convert.Layout + DDC.Core.Tetra.Convert.Type + DDC.Core.Tetra.Prim.Base - DDC.Core.Tetra.Prim.OpPrimArith - DDC.Core.Tetra.Prim.OpPrimRef + DDC.Core.Tetra.Prim.DaConTetra + DDC.Core.Tetra.Prim.OpArith + DDC.Core.Tetra.Prim.OpCast + DDC.Core.Tetra.Prim.OpStore DDC.Core.Tetra.Prim.TyConPrim + DDC.Core.Tetra.Prim.TyConTetra + GHC-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures + -fno-warn-missing-methods -fno-warn-unused-do-bind Extensions: