ddc-core-tetra 0.3.2.1 → 0.4.1.1
raw patch · 26 files changed
+2948/−359 lines, 26 filesdep ~arraydep ~basedep ~ddc-base
Dependency ranges changed: array, base, ddc-base, ddc-core, ddc-core-salt, ddc-core-simpl
Files
- DDC/Core/Tetra.hs +29/−6
- DDC/Core/Tetra/Check.hs +43/−0
- DDC/Core/Tetra/Compounds.hs +24/−1
- DDC/Core/Tetra/Convert.hs +214/−0
- DDC/Core/Tetra/Convert/Base.hs +87/−0
- DDC/Core/Tetra/Convert/Boxing.hs +170/−0
- DDC/Core/Tetra/Convert/Data.hs +158/−0
- DDC/Core/Tetra/Convert/Exp.hs +770/−0
- DDC/Core/Tetra/Convert/Layout.hs +152/−0
- DDC/Core/Tetra/Convert/Type.hs +541/−0
- DDC/Core/Tetra/Env.hs +35/−16
- DDC/Core/Tetra/Error.hs +33/−0
- DDC/Core/Tetra/Prim.hs +103/−28
- DDC/Core/Tetra/Prim/Base.hs +69/−59
- DDC/Core/Tetra/Prim/DaConTetra.hs +42/−0
- DDC/Core/Tetra/Prim/OpArith.hs +63/−0
- DDC/Core/Tetra/Prim/OpCast.hs +24/−0
- DDC/Core/Tetra/Prim/OpPrimArith.hs +0/−88
- DDC/Core/Tetra/Prim/OpPrimRef.hs +0/−57
- DDC/Core/Tetra/Prim/OpStore.hs +56/−0
- DDC/Core/Tetra/Prim/TyConPrim.hs +23/−71
- DDC/Core/Tetra/Prim/TyConTetra.hs +86/−0
- DDC/Core/Tetra/Profile.hs +4/−6
- DDC/Core/Tetra/Transform/Boxing.hs +193/−0
- LICENSE +1/−15
- ddc-core-tetra.cabal +28/−12
DDC/Core/Tetra.hs view
@@ -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
+ DDC/Core/Tetra/Check.hs view
@@ -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
DDC/Core/Tetra/Compounds.hs view
@@ -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 ]+
+ DDC/Core/Tetra/Convert.hs view
@@ -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'++
+ DDC/Core/Tetra/Convert/Base.hs view
@@ -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." ]+
+ DDC/Core/Tetra/Convert/Boxing.hs view
@@ -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+
+ DDC/Core/Tetra/Convert/Data.hs view
@@ -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
+ DDC/Core/Tetra/Convert/Exp.hs view
@@ -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.+--
+ DDC/Core/Tetra/Convert/Layout.hs view
@@ -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+
+ DDC/Core/Tetra/Convert/Type.hs view
@@ -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)+
DDC/Core/Tetra/Env.hs view
@@ -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
+ DDC/Core/Tetra/Error.hs view
@@ -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" ]
DDC/Core/Tetra/Prim.hs view
@@ -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+
DDC/Core/Tetra/Prim/Base.hs view
@@ -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)
+ DDC/Core/Tetra/Prim/DaConTetra.hs view
@@ -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+
+ DDC/Core/Tetra/Prim/OpArith.hs view
@@ -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++
+ DDC/Core/Tetra/Prim/OpCast.hs view
@@ -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+
− DDC/Core/Tetra/Prim/OpPrimArith.hs
@@ -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-
− DDC/Core/Tetra/Prim/OpPrimRef.hs
@@ -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
+ DDC/Core/Tetra/Prim/OpStore.hs view
@@ -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
DDC/Core/Tetra/Prim/TyConPrim.hs view
@@ -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)
+ DDC/Core/Tetra/Prim/TyConTetra.hs view
@@ -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
DDC/Core/Tetra/Profile.hs view
@@ -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
+ DDC/Core/Tetra/Transform/Boxing.hs view
@@ -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+
LICENSE view
@@ -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-
ddc-core-tetra.cabal view
@@ -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: