diff --git a/DDC/Core/Lite.hs b/DDC/Core/Lite.hs deleted file mode 100644 --- a/DDC/Core/Lite.hs +++ /dev/null @@ -1,39 +0,0 @@ - --- | Disciple Core Lite. --- --- This is a desugared version of Disciple Core that has all the polymorphism --- of System-F2 along with algebraic data types. It does not yet support --- user-defined data types, but has Units, Ints, Pairs and Lists baked in. --- --- Lite exposes arithmetic primops like @add#@ and @or#@, but no store or --- control primops. Code written in Lite cannot corrupt the heap, assuming --- the implementation of the Salt primitives it uses (and compiler) is --- correct. --- -module DDC.Core.Lite - ( -- * Language profile - profile - - -- * Conversion - , saltOfLiteModule - , Error (..) - - -- * Names - , Name (..) - , DataTyCon (..) - , PrimTyCon (..) - , PrimDaCon (..) - , PrimArith (..) - , PrimCast (..) - - -- * Name Parsing - , readName - - -- * Program Lexing - , lexModuleString - , lexExpString) - -where -import DDC.Core.Lite.Name -import DDC.Core.Lite.Profile -import DDC.Core.Lite.Convert diff --git a/DDC/Core/Lite/Compounds.hs b/DDC/Core/Lite/Compounds.hs deleted file mode 100644 --- a/DDC/Core/Lite/Compounds.hs +++ /dev/null @@ -1,90 +0,0 @@ - -module DDC.Core.Lite.Compounds - ( tBoolU, tBool - , tNatU, tNat, dcNatU, xNatU - , tIntU, tInt - , tWordU - , tPair - , tList) -where -import DDC.Core.Lite.Name -import DDC.Core.Compounds -import DDC.Core.Exp - - --- Bools ---------------------------------------------------------------------- --- | Application of the Bool type constructor. -tBool :: Region Name -> Type Name -tBool r1 - = TApp (TCon tcBool) r1 - where tcBool = TyConBound (UPrim (NameDataTyCon DataTyConBool) kBool) kBool - kBool = kFun kRegion kData - - --- | Unboxed `Bool#` type constructor. -tBoolU :: Type Name -tBoolU = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConBool) kData) kData) - - --- Nats ----------------------------------------------------------------------- --- | The Nat# type constructor. -tNatU :: Type Name -tNatU = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConNat) kData) kData) - - --- | A Literal Nat# data constructor. -dcNatU :: Integer -> DaCon Name -dcNatU i = DaConPrim (NameLitNat i) tNatU - - --- | A literal Nat# -xNatU :: a -> Integer -> Exp a Name -xNatU a i = XCon a (dcNatU i) - - --- | Application of the Nat type constructor. -tNat :: Region Name -> Type Name -tNat r1 - = TApp (TCon tcNat) r1 - where tcNat = TyConBound (UPrim (NameDataTyCon DataTyConNat) kNat) kNat - kNat = kFun kRegion kData - - --- Ints ----------------------------------------------------------------------- --- | Unboxed `Int#` type constructor. -tIntU :: Type Name -tIntU = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConInt) kData) kData) - - --- | Application of the Int type constructor. -tInt :: Region Name -> Type Name -tInt r1 - = TApp (TCon tcInt) r1 - where tcInt = TyConBound (UPrim (NameDataTyCon DataTyConInt) kInt) kInt - kInt = kFun kRegion kData - - --- Words ---------------------------------------------------------------------- --- | Unboxed `WordN#` type constructor of the given width. -tWordU :: Int -> Type Name -tWordU bits - = TCon (TyConBound (UPrim (NamePrimTyCon (PrimTyConWord bits)) kData) kData) - - --- Pairs ---------------------------------------------------------------------- --- | Application of the Pair type constructor. -tPair :: Region Name -> Type Name -> Type Name -> Type Name -tPair tR tA tB - = tApps (TCon tcPair) [tR, tA, tB] - where tcPair = TyConBound (UPrim (NameDataTyCon DataTyConPair) kPair) kPair - kPair = kFuns [kRegion, kData, kData] kData - - --- Lists ---------------------------------------------------------------------- --- | Application of the List type constructor. -tList :: Region Name -> Type Name -> Type Name -tList tR tA - = tApps (TCon tcList) [tR, tA] - where tcList = TyConBound (UPrim (NameDataTyCon DataTyConList) kList) kList - kList = kRegion `kFun` kData `kFun` kData - diff --git a/DDC/Core/Lite/Convert.hs b/DDC/Core/Lite/Convert.hs deleted file mode 100644 --- a/DDC/Core/Lite/Convert.hs +++ /dev/null @@ -1,645 +0,0 @@ - --- | Conversion of Disciple Lite to Disciple Salt. --- -module DDC.Core.Lite.Convert - ( saltOfLiteModule - , Error(..)) -where -import DDC.Core.Lite.Convert.Data -import DDC.Core.Lite.Convert.Type -import DDC.Core.Lite.Convert.Base -import DDC.Core.Salt.Convert.Init -import DDC.Core.Salt.Platform -import DDC.Core.Module -import DDC.Core.Compounds -import DDC.Core.Predicates -import DDC.Core.Exp -import DDC.Type.Universe -import DDC.Type.DataDef -import DDC.Control.Monad.Check (throw, evalCheck) -import DDC.Core.Check (AnTEC(..)) -import DDC.Type.Env (KindEnv, TypeEnv) -import qualified DDC.Core.Lite.Name as L -import qualified DDC.Core.Salt.Runtime as S -import qualified DDC.Core.Salt.Name as S -import qualified DDC.Core.Salt.Compounds as S -import qualified DDC.Type.Env as Env -import qualified Data.Map as Map -import Control.Monad -import Data.Maybe - - --- | Convert a Disciple Core Lite module to Disciple Core Salt. --- --- Case expressions on algebraic data values are converted into ones that just --- check the tag, while data constructors are unfolded into explicit allocation --- and field initialization primops. --- --- 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. --- If not then `Error`. --- --- The output code contains: --- debruijn indices. --- These then need to be eliminated before it will pass the Salt fragment --- checks. --- -saltOfLiteModule - :: Show a - => Platform -- ^ Platform specification. - -> S.Config -- ^ Runtime configuration. - -> DataDefs L.Name -- ^ Data type definitions. - -> KindEnv L.Name -- ^ Kind environment. - -> TypeEnv L.Name -- ^ Type environment. - -> Module (AnTEC a L.Name) L.Name -- ^ Lite module to convert. - -> Either (Error a) (Module a S.Name) -- ^ Salt module. - -saltOfLiteModule platform runConfig defs kenv tenv mm - = {-# SCC saltOfLiteModule #-} - evalCheck () $ convertM platform runConfig defs kenv tenv mm - - --- Module ----------------------------------------------------------------------------------------- -convertM - :: Show a - => Platform - -> S.Config - -> DataDefs L.Name - -> KindEnv L.Name - -> TypeEnv L.Name - -> Module (AnTEC a L.Name) L.Name - -> ConvertM a (Module a S.Name) - -convertM pp runConfig defs kenv tenv mm - = do - -- Convert signatures of exported functions. - tsExports' <- mapM convertExportM $ moduleExportValues mm - - -- Convert signatures of imported functions. - tsImports' <- mapM convertImportM $ moduleImportValues mm - - -- Convert the body of the module to Salt. - let ntsImports = [BName n (typeOfImportSource isrc) - | (n, isrc) <- moduleImportTypes mm] - let tenv' = Env.extends ntsImports tenv - x1 <- convertExpX ExpTop pp defs kenv tenv' $ 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 S.runtimeImportKinds - , moduleImportValues = (Map.toList S.runtimeImportTypes) ++ tsImports' - - -- Data constructors and pattern matches should have been flattened - -- into 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 - - --- Exports ---------------------------------------------------------------------------------------- --- | Convert an export spec. -convertExportM - :: (L.Name, ExportSource L.Name) - -> ConvertM a (S.Name, ExportSource S.Name) - -convertExportM (n, esrc) - = do n' <- convertBindNameM n - esrc' <- convertExportSourceM esrc - return (n', esrc') - - --- | Convert an export source specifier. -convertExportSourceM - :: ExportSource L.Name - -> ConvertM a (ExportSource S.Name) - -convertExportSourceM isrc - = case isrc of - ExportSourceLocal n t - -> do n' <- convertBindNameM n - t' <- convertT Env.empty t - return $ ExportSourceLocal n' t' - - ExportSourceLocalNoType n - -> do n' <- convertBindNameM n - return $ ExportSourceLocalNoType n' - - --- Imports ---------------------------------------------------------------------------------------- --- | Convert an import spec. -convertImportM - :: (L.Name, ImportSource L.Name) - -> ConvertM a (S.Name, ImportSource S.Name) - -convertImportM (n, isrc) - = do n' <- convertBindNameM n - isrc' <- convertImportSourceM isrc - return (n', isrc') - - --- | Convert an import source specifier. -convertImportSourceM - :: ImportSource L.Name - -> ConvertM a (ImportSource S.Name) - -convertImportSourceM isrc - = case isrc of - ImportSourceAbstract t - -> do t' <- convertT Env.empty t - return $ ImportSourceAbstract t' - - ImportSourceModule mn n t - -> do t' <- convertT Env.empty t - n' <- convertBindNameM n - return $ ImportSourceModule mn n' t' - - ImportSourceSea str t - -> do t' <- convertT Env.empty t - return $ ImportSourceSea str t' - - --- Exp -------------------------------------------------------------------------------------------- --- | 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 we can only --- have value variables, types and witnesses as function arguments, not general --- expressions. -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 - => ExpContext -- ^ What context we're converting in. - -> Platform -- ^ Platform specification. - -> DataDefs L.Name -- ^ Data type definitions. - -> KindEnv L.Name -- ^ Kind environment. - -> TypeEnv L.Name -- ^ Type environment. - -> Exp (AnTEC a L.Name) L.Name -- ^ Expression to convert. - -> ConvertM a (Exp a S.Name) - -convertExpX ctx pp defs kenv tenv xx - = let downArgX = convertExpX ExpArg pp defs kenv tenv - downCtorAppX = convertCtorAppX pp defs kenv tenv - in case xx of - - XVar _ UIx{} - -> throw $ ErrorMalformed - $ "Cannot convert program with anonymous value binders." - - XVar a u - -> do let a' = annotTail a - u' <- convertU u - return $ XVar a' u' - - XCon a u - -> do let a' = annotTail a - xx' <- convertCtor pp defs kenv tenv a' u - return xx' - - - -- Type abstractions can only appear at the top-level of a function. - -- Keep region and data type lambdas, but ditch the others. - XLAM a b x - | ExpFun <- ctx - , (isRegionKind $ typeOfBind b) - || (isDataKind $ typeOfBind b) - -> do let a' = annotTail a - b' <- convertB kenv b - - let kenv' = Env.extend b kenv - x' <- convertExpX ctx pp defs kenv' tenv x - - return $ XLAM a' b' x' - - | ExpFun <- ctx - -> do let kenv' = Env.extend b kenv - convertExpX ctx pp defs kenv' tenv x - - | otherwise - -> throw $ ErrorMalformed - $ "Cannot convert XLAM in this context " ++ show ctx - - - -- Value 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) - (convertB kenv b) - (convertExpX ctx pp defs kenv tenv' x) - - Just UniverseWitness - -> liftM3 XLam - (return $ annotTail a) - (convertB kenv b) - (convertExpX ctx pp defs kenv tenv' x) - - _ -> throw $ ErrorMalformed - $ "Invalid universe for XLam binder: " ++ show b - | otherwise - -> throw $ ErrorMalformed - $ "Cannot convert XLam in this context " ++ show ctx - - - -- Data constructor applications. - XApp a xa xb - | (x1, xsArgs) <- takeXApps1 xa xb - , XCon _ dc <- x1 - -> downCtorAppX a dc xsArgs - - -- Primitive operations. - XApp a xa xb - | (x1, xsArgs) <- takeXApps1 xa xb - , XVar _ UPrim{} <- x1 - -> do x1' <- downArgX x1 - xsArgs' <- mapM downArgX xsArgs - - return $ xApps (annotTail a) x1' xsArgs' - - -- ISSUE #283: Lite to Salt transform doesn't check for partial application - -- This only works for full application. - -- At least check for the other cases. - -- - -- Function application. - XApp (AnTEC _t _ _ a') xa xb - | (x1, xsArgs) <- takeXApps1 xa xb - -> do x1' <- downArgX x1 - xsArgs' <- mapM downArgX xsArgs - return $ xApps a' x1' xsArgs' - - - -- let-expressions. - XLet a lts x2 - | ctx <= ExpBind - -> do -- Convert the bindings. - lts' <- convertLetsX pp defs 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 ExpBody pp defs kenv' tenv' x2 - - return $ XLet (annotTail a) lts' x2' - - XLet{} - -> throw $ ErrorNotNormalized "Unexpected let-expression." - - - -- 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 - , L.NamePrimTyCon _ <- nType - -> do xScrut' <- convertExpX ExpArg pp defs kenv tenv xScrut - alts' <- mapM (convertAlt (min ctx ExpBody) pp defs kenv tenv 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 - -> do x' <- convertExpX ExpArg pp defs kenv tenv xScrut - tX' <- convertT kenv tX - alts' <- mapM (convertAlt (min ctx ExpBody) pp defs kenv tenv a' uScrut tScrut) - alts - - let asDefault - | any isPDefault [p | AAlt p _ <- alts] - = [] - - | otherwise - = [AAlt PDefault (S.xFail a' tX')] - - tScrut' <- convertT kenv tScrut - let tPrime = fromMaybe S.rTop - $ takePrimeRegion tScrut' - - return $ XCase a' (S.xGetTag a' tPrime x') - $ alts' ++ asDefault - - -- Trying to matching against something that isn't primitive or - -- algebraic data. - XCase{} - -> throw $ ErrorNotNormalized ("Invalid case expression.") - - - -- Casts. - XCast _ _ x - -> convertExpX (min ctx ExpBody) pp defs kenv tenv x - - - -- Types can only appear as the arguments in function applications. - XType (AnTEC _ _ _ a') t - | ExpArg <- ctx -> liftM (XType a') (convertT kenv t) - | otherwise -> throw $ ErrorNotNormalized ("Unexpected type expresison.") - - - -- Witnesses can only appear as the arguments to function applications. - XWitness (AnTEC _ _ _ a') w - | ExpArg <- ctx -> liftM (XWitness a') (convertWitnessX kenv w) - | otherwise -> throw $ ErrorNotNormalized ("Unexpected witness expression.") - - - ---------------------------------------------------------------------------------------------------- --- | Convert a let-binding to Salt. -convertLetsX - :: Show a - => Platform -- ^ Platform specification. - -> DataDefs L.Name -- ^ Data type definitions. - -> KindEnv L.Name -- ^ Kind environment. - -> TypeEnv L.Name -- ^ Type environment. - -> Lets (AnTEC a L.Name) L.Name -- ^ Expression to convert. - -> ConvertM a (Lets a S.Name) - -convertLetsX pp defs kenv tenv lts - = case lts of - LRec bxs - -> do let tenv' = Env.extends (map fst bxs) tenv - let (bs, xs) = unzip bxs - bs' <- mapM (convertB kenv) bs - xs' <- mapM (convertExpX ExpFun pp defs kenv tenv') xs - return $ LRec $ zip bs' xs' - - LLet b x1 - -> do let tenv' = Env.extend b tenv - b' <- convertB kenv b - x1' <- convertExpX ExpBind pp defs kenv tenv' x1 - return $ LLet b' x1' - - LPrivate b mt bs - -> do b' <- mapM (convertB kenv) b - let kenv' = Env.extends b kenv - bs' <- mapM (convertB kenv') bs - mt' <- case mt of - Nothing -> return Nothing - Just t -> liftM Just $ convertT kenv t - return $ LPrivate b' mt' bs' - - LWithRegion{} - -> throw $ ErrorMalformed "LWithRegion should not appear in Lite code." - - ---------------------------------------------------------------------------------------------------- --- | Convert a witness expression to Salt -convertWitnessX - :: Show a - => KindEnv L.Name -- ^ Kind enviornment - -> Witness (AnTEC a L.Name) L.Name -- ^ Witness to convert. - -> ConvertM a (Witness a S.Name) - -convertWitnessX kenv ww - = let down = convertWitnessX kenv - in case ww of - WVar a n -> liftM (WVar $ annotTail a) (convertU n) - WCon a wc -> liftM (WCon $ annotTail a) (convertWiConX kenv wc) - WApp a w1 w2 -> liftM2 (WApp $ annotTail a) (down w1) (down w2) - WJoin a w1 w2 -> liftM2 (WApp $ annotTail a) (down w1) (down w2) - WType a t -> liftM (WType $ annotTail a) (convertT kenv t) - - -convertWiConX - :: Show a - => KindEnv L.Name -- ^ Kind environment. - -> WiCon L.Name -- ^ Witness constructor to convert. - -> ConvertM a (WiCon S.Name) - -convertWiConX kenv wicon - = case wicon of - WiConBuiltin w - -> return $ WiConBuiltin w - - WiConBound n t - -> liftM2 WiConBound - (convertU n) - (convertT kenv t) - - ---------------------------------------------------------------------------------------------------- --- | Convert a data constructor application to Salt. -convertCtorAppX - :: Show a - => Platform -- ^ Platform specification. - -> DataDefs L.Name -- ^ Data type definitions. - -> KindEnv L.Name -- ^ Kind environment. - -> TypeEnv L.Name -- ^ Type environment. - -> AnTEC a L.Name -- ^ Annot from deconstructed app node. - -> DaCon L.Name -- ^ Data constructor being applied. - -> [Exp (AnTEC a L.Name) L.Name] - -> ConvertM a (Exp a S.Name) - -convertCtorAppX pp defs kenv tenv (AnTEC _ _ _ a) dc xsArgs - - -- Pass through unboxed literals. - | Just (L.NameLitBool b) <- takeNameOfDaCon dc - , [] <- xsArgs - = return $ S.xBool a b - - | Just (L.NameLitNat i) <- takeNameOfDaCon dc - , [] <- xsArgs - = return $ S.xNat a i - - | Just (L.NameLitInt i) <- takeNameOfDaCon dc - , [] <- xsArgs - = return $ S.xInt a i - - | Just (L.NameLitWord i bits) <- takeNameOfDaCon dc - , [] <- xsArgs - = return $ S.xWord a i bits - - -- Handle the unit constructor. - | DaConUnit <- dc - = do return $ S.xAllocBoxed a S.rTop 0 (S.xNat a 0) - - -- Construct algbraic data that has a finite number of data constructors. - | Just nCtor <- takeNameOfDaCon dc - , Just ctorDef <- Map.lookup nCtor $ dataDefsCtors defs - , Just dataDef <- Map.lookup (dataCtorTypeName ctorDef) $ dataDefsTypes defs - = do - -- Get the prime region variable that holds the outermost constructor. - -- For types like Unit, there is no prime region, so put them in the - -- top-level region of the program. - rPrime - <- case xsArgs of - [] - -> return S.rTop - - XType _ (TVar u) : _ - | Just tu <- Env.lookup u kenv - -> if isRegionKind tu - then do u' <- convertU u - return $ TVar u' - else return S.rTop - - _ -> throw $ ErrorMalformed "Prime region variable is not in scope." - - - -- Convert the types of each field. - let makeFieldType x - = let a' = annotOfExp x - in liftM Just $ convertT kenv (annotType a') - - xsArgs' <- mapM (convertExpX ExpArg pp defs kenv tenv) xsArgs - tsArgs' <- mapM makeFieldType xsArgs - constructData pp kenv tenv a - dataDef ctorDef - rPrime xsArgs' tsArgs' - - --- If this fails then the provided constructor args list is probably malformed. --- This shouldn't happen in type-checked code. -convertCtorAppX _ _ _ _ _ _nCtor _xsArgs - = throw $ ErrorMalformed "Invalid constructor application." - - --- Alt -------------------------------------------------------------------------------------------- --- | Convert a Lite alternative to Salt. -convertAlt - :: Show a - => ExpContext - -> Platform -- ^ Platform specification. - -> DataDefs L.Name -- ^ Data type declarations. - -> KindEnv L.Name -- ^ Kind environment. - -> TypeEnv L.Name -- ^ Type environment. - -> a -- ^ Annotation from case expression. - -> Bound L.Name -- ^ Bound of scrutinee. - -> Type L.Name -- ^ Type of scrutinee - -> Alt (AnTEC a L.Name) L.Name -- ^ Alternative to convert. - -> ConvertM a (Alt a S.Name) - -convertAlt ctx pp defs kenv tenv a uScrut tScrut alt - = case alt of - AAlt PDefault x - -> do x' <- convertExpX ctx pp defs kenv tenv x - return $ AAlt PDefault x' - - -- Match against literal unboxed values. - AAlt (PData dc []) x - | Just nCtor <- takeNameOfDaCon dc - , case nCtor of - L.NameLitInt{} -> True - L.NameLitWord{} -> True - L.NameLitBool{} -> True - _ -> False - - -> do dc' <- convertDC kenv dc - xBody1 <- convertExpX ctx pp defs kenv tenv x - return $ AAlt (PData dc' []) xBody1 - - -- 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 ctx pp defs kenv tenv x - let dcTag = DaConPrim (S.NameLitTag 0) S.tTag - return $ AAlt (PData dcTag []) xBody - - -- Match against algebraic data with a finite number - -- of data constructors. - AAlt (PData dc bsFields) x - | Just nCtor <- takeNameOfDaCon dc - , Just ctorDef <- Map.lookup nCtor $ dataDefsCtors defs - -> do - let tenv' = Env.extends bsFields tenv - uScrut' <- convertU uScrut - - -- Get the tag of this alternative. - let iTag = fromIntegral $ dataCtorTag ctorDef - let dcTag = DaConPrim (S.NameLitTag iTag) S.tTag - - -- Get the address of the payload. - bsFields' <- mapM (convertB kenv) bsFields - - -- Convert the right of the alternative. - xBody1 <- convertExpX ctx pp defs kenv tenv' x - - -- Add let bindings to unpack the constructor. - tScrut' <- convertT kenv tScrut - let Just trPrime = takePrimeRegion tScrut' - xBody2 <- destructData pp a uScrut' ctorDef trPrime - bsFields' xBody1 - return $ AAlt (PData dcTag []) xBody2 - - AAlt{} - -> throw ErrorInvalidAlt - - --- Data Constructor ------------------------------------------------------------------------------- --- | Expand out code to build a data constructor. -convertCtor - :: Show a - => Platform -- ^ Platform specification. - -> DataDefs L.Name -- ^ Data type definitions. - -> KindEnv L.Name -- ^ Kind environment. - -> TypeEnv L.Name -- ^ Type environment. - -> a -- ^ Annotation to attach to exp nodes. - -> DaCon L.Name -- ^ Data constructor to convert. - -> ConvertM a (Exp a S.Name) - -convertCtor pp defs kenv tenv a dc - | DaConUnit <- dc - = return $ S.xAllocBoxed a S.rTop 0 (S.xNat a 0) - - | Just n <- takeNameOfDaCon dc - = case n of - -- Literal values. - L.NameLitBool v -> return $ S.xBool a v - L.NameLitNat i -> return $ S.xNat a i - L.NameLitInt i -> return $ S.xInt a i - L.NameLitWord i bits -> return $ S.xWord a i bits - - -- A Zero-arity data constructor. - nCtor - | Just ctorDef <- Map.lookup nCtor $ dataDefsCtors defs - , Just dataDef <- Map.lookup (dataCtorTypeName ctorDef) - $ dataDefsTypes defs - -> do -- Put zero-arity data constructors in the top-level region. - let rPrime = S.rTop - constructData pp kenv tenv a dataDef ctorDef rPrime [] [] - - _ -> throw $ ErrorMalformed "Invalid constructor." - - | otherwise - = throw $ ErrorMalformed "Invalid constructor." - diff --git a/DDC/Core/Lite/Convert/Base.hs b/DDC/Core/Lite/Convert/Base.hs deleted file mode 100644 --- a/DDC/Core/Lite/Convert/Base.hs +++ /dev/null @@ -1,79 +0,0 @@ - -module DDC.Core.Lite.Convert.Base - ( ConvertM - , Error (..)) -where -import DDC.Core.Exp -import DDC.Base.Pretty -import DDC.Core.Check (AnTEC(..)) -import qualified DDC.Core.Lite.Name as L -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 L.Name) L.Name) - - -- | The program wasn't in a-normal form. - | ErrorNotNormalized String - - -- | The program has bottom (missing) type annotations. - | ErrorBotAnnot - - -- | Found an unexpected type sum. - | ErrorUnexpectedSum - - -- | An invalid name used in a binding position - | ErrorInvalidBinder L.Name - - -- | An invalid name used in a bound position - | ErrorInvalidBound (Bound L.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) ] - - ErrorNotNormalized str - -> vcat [ text "Module is not in a-normal form." - , text str ] - - ErrorBotAnnot - -> vcat [ text "Found bottom type annotation." - , text " Code should be type-checked before converting Lite -> Salt" ] - - ErrorUnexpectedSum - -> vcat [ text "Unexpected type sum."] - - ErrorInvalidBinder n - -> vcat [ text "Invalid name used in bidner " <> ppr n ] - - ErrorInvalidBound n - -> vcat [ text "Invalid name used in bound occurrence " <> ppr n ] - - ErrorInvalidAlt - -> vcat [ text "Invalid alternative" ] - - ErrorMainHasNoMain - -> vcat [ text "Main module has no 'main' function" ] - diff --git a/DDC/Core/Lite/Convert/Data.hs b/DDC/Core/Lite/Convert/Data.hs deleted file mode 100644 --- a/DDC/Core/Lite/Convert/Data.hs +++ /dev/null @@ -1,179 +0,0 @@ - -module DDC.Core.Lite.Convert.Data - ( constructData - , destructData) -where -import DDC.Core.Lite.Convert.Type -import DDC.Core.Lite.Convert.Base -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.Lite.Layout as L -import qualified DDC.Core.Lite.Name as L -import qualified DDC.Core.Salt.Runtime as O -import qualified DDC.Core.Salt.Name as O -import qualified DDC.Core.Salt.Compounds as O -import Data.Maybe - - --- Construct ------------------------------------------------------------------ --- | Build an expression that allocates and initialises a data constructor. --- object. -constructData - :: Show a - => Platform -- ^ Platform definition. - -> KindEnv L.Name -- ^ Kind environment. - -> TypeEnv L.Name -- ^ Type environment. - -> a -- ^ Annotation to use on expressions. - -> DataType L.Name -- ^ Data Type definition of object. - -> DataCtor L.Name -- ^ Constructor definition of object. - -> Type O.Name -- ^ Prime region variable. - -> [Exp a O.Name] -- ^ Field values. - -> [Maybe (Type O.Name)] -- ^ Field types. - -> ConvertM a (Exp a O.Name) - -constructData pp kenv _tenv a dataDef ctorDef rPrime xsArgs tsArgs - | Just L.HeapObjectBoxed <- L.heapObjectOfDataCtor pp ctorDef - = do - -- We want to write the fields into the newly allocated object. - -- The xsArgs list also contains type arguments, so we need to - -- drop these off first. - let xsFields = drop (length $ dataTypeParams dataDef) xsArgs - - -- Get the regions each of the objects are in. - let Just tsFields = sequence - $ drop (length $ dataTypeParams dataDef) tsArgs - - -- Allocate the object. - let arity = length tsFields - let bObject = BAnon (O.tPtr rPrime O.tObj) - let xAlloc = O.xAllocBoxed a rPrime (dataCtorTag ctorDef) - $ O.xNat a (fromIntegral arity) - - -- Statements to write each of the fields. - let xObject' = XVar a $ UIx 0 - let lsFields - = [ LLet (BNone O.tVoid) - (O.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 L.HeapObjectRawSmall <- L.heapObjectOfDataCtor pp ctorDef - , Just size <- L.payloadSizeOfDataCtor pp ctorDef - = do - -- Allocate the object. - let bObject = BAnon (O.tPtr rPrime O.tObj) - let xAlloc = O.xAllocRawSmall a rPrime (dataCtorTag ctorDef) - $ O.xNat a size - - -- Take a pointer to its payload. - let bPayload = BAnon (O.tPtr rPrime (O.tWord 8)) - let xPayload = O.xPayloadOfRawSmall a rPrime - $ XVar a (UIx 0) - - -- Convert the field types. - tsFields <- mapM (convertT kenv) $ dataCtorFieldTypes ctorDef - - -- We want to write the fields into the newly allocated object. - -- The xsArgs list also contains type arguments, so we need to - -- drop these off first. - let xsFields = drop (length $ dataTypeParams dataDef) xsArgs - - -- Get the offset of each field. - let Just offsets = L.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 O.tVoid) - (O.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 $ L.heapObjectOfDataCtor pp ctorDef) - , " fields = " ++ (show $ dataCtorFieldTypes ctorDef) - , " size = " ++ (show $ L.payloadSizeOfDataCtor pp ctorDef) ] - - --- Destruct ------------------------------------------------------------------- --- | Wrap a expression in let-bindings that binds the fields of a data --- construct object. --- This is used when pattern matching in a case expression. -destructData - :: Platform - -> a - -> Bound O.Name -- ^ Bound of Scruitinee. - -> DataCtor L.Name -- ^ Definition of the data constructor to unpack. - -> Type O.Name -- ^ Prime region. - -> [Bind O.Name] -- ^ Binders for each of the fields. - -> Exp a O.Name -- ^ Body expression that uses the field binders. - -> ConvertM a (Exp a O.Name) - -destructData pp a uScrut ctorDef trPrime bsFields xBody - - | Just L.HeapObjectBoxed <- L.heapObjectOfDataCtor pp ctorDef - = do - - -- Bind pattern variables to each of the fields. - let lsFields - = catMaybes - $ [ if isBNone bField - then Nothing - else Just $ LLet bField - (O.xGetFieldOfBoxed a trPrime tField - (XVar a uScrut) ix) - | bField <- bsFields - | tField <- map typeOfBind bsFields - | ix <- [0..] ] - - return $ foldr (XLet a) xBody lsFields - - | Just L.HeapObjectRawSmall <- L.heapObjectOfDataCtor pp ctorDef - , Just offsets <- L.fieldOffsetsOfDataCtor pp ctorDef - = do - -- Get the address of the payload. - let bPayload = BAnon (O.tPtr trPrime (O.tWord 8)) - let xPayload = O.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 - (O.xPeekBuffer a trPrime tField - (XVar a uPayload) offset) - | bField <- bsFields - | tField <- map typeOfBind bsFields - | offset <- offsets ] - - return $ foldr (XLet a) xBody - $ LLet bPayload xPayload - : lsFields - - - | otherwise - = throw ErrorInvalidAlt - diff --git a/DDC/Core/Lite/Convert/Type.hs b/DDC/Core/Lite/Convert/Type.hs deleted file mode 100644 --- a/DDC/Core/Lite/Convert/Type.hs +++ /dev/null @@ -1,218 +0,0 @@ - -module DDC.Core.Lite.Convert.Type - ( convertT - , convertPrimT - - , convertDC - , convertB - , convertU - - , convertBindNameM - , convertBoundNameM) -where -import DDC.Core.Lite.Convert.Base -import DDC.Core.Exp -import DDC.Type.Env -import DDC.Type.Compounds -import DDC.Type.Predicates -import DDC.Control.Monad.Check (throw) -import qualified DDC.Core.Lite.Name as L -import qualified DDC.Core.Salt.Name as O -import qualified DDC.Core.Salt.Compounds as O -import qualified DDC.Core.Salt.Runtime as O -import qualified DDC.Type.Env as Env -import Control.Monad - - -convertT :: KindEnv L.Name -> Type L.Name -> ConvertM a (Type O.Name) -convertT = convertT' False - - -convertPrimT :: Type L.Name -> ConvertM a (Type O.Name) -convertPrimT = convertT' True Env.empty - - --- Type ----------------------------------------------------------------------- --- | Convert the type of a user-defined function or argument. --- --- The types of primops have quantifiers that quantify over unboxed types. --- For example: @add# :: [a : *]. a -> a -> a@ --- When converting these types we need to keep the quantifier, as well --- as the named type variable. --- --- When converting user types, we instead strip quantifiers and replace --- type variables by a generic pointer type: - --- @ --- head :: [r : %]. [a : *]. List r a -> a --- => head :: [r : %]. Ptr# r Obj -> Ptr# _ Obj --- @ --- --- We don't know what the primary region of the returned value is, --- so fill in its region varible with a hole '_'. --- ---- Instead of using type variables of kind *, we could convert these into --- region quantifiers and pass the head region instead: --- @head :: [r1 r2 : %]. Ptr# r1 Obj -> Ptr# r2 Obj@ --- I'm not sure which is better. --- -convertT' - :: Bool -- ^ Whether this is the type of a primop. - -> KindEnv L.Name -- ^ Kind environment. - -> Type L.Name -- ^ Type to convert. - -> ConvertM a (Type O.Name) - -convertT' isPrimType kenv tt - = let down = convertT' isPrimType kenv - in case tt of - -- Convert type variables and constructors. - TVar u - -> case Env.lookup u kenv of - Just t - | isRegionKind t || isDataKind t - -> liftM TVar $ convertU u - - | otherwise - -> error $ "ddc-core-salt.convertT: unexpected var kind " ++ show tt - - Nothing - -> error $ "ddc-core-salt.convertT: type var not in kind environment " ++ show tt - - - -- Convert unapplied type constructors. - TCon tc - -> convertTyCon tc - - -- Strip off effect and closure quantifiers. - -- The Salt fragment doesn't care about these. - TForall b t - | isRegionKind (typeOfBind b) - || isDataKind (typeOfBind b) - -> let kenv' = Env.extend b kenv - in liftM2 TForall (convertB kenv' b) - (convertT' isPrimType kenv' t) - - | otherwise - -> let kenv' = Env.extend b kenv - in convertT' isPrimType kenv' t - - -- Convert applications. - TApp{} - -- Strip off effect and closure information. - | Just (t1, _, _, t2) <- takeTFunEC tt - -> liftM2 tFunPE (down t1) (down t2) - - -- Witness application are passed through to Salt. - | Just (tc@(TyConWitness _), args) <- takeTyConApps tt - -> liftM2 tApps (convertTyCon tc) (mapM down args) - - -- Convert pointers to primitive values. - | Just (tcPtr, [tR, tArg]) <- takeTyConApps tt - , TyConBound (UPrim (L.NamePrimTyCon O.PrimTyConPtr) _) _ <- tcPtr - -> do tR' <- down tR - tArg' <- down tArg - return $ O.tPtr tR' tArg' - - -- Boxed data values are represented in generic form. - | Just (_, tR : _args) <- takeTyConApps tt - -> do tR' <- down tR - return $ O.tPtr tR' O.tObj - - | otherwise - -> throw $ ErrorMalformed "Bad type-type application." - - -- We shouldn't find any TSums in the type of data. - TSum{} - | isBot tt -> throw $ ErrorBotAnnot - | otherwise -> throw $ ErrorUnexpectedSum - - --- | Convert a simple type constructor to a Salt type. -convertTyCon :: TyCon L.Name -> ConvertM a (Type O.Name) -convertTyCon tc - = case tc of - -- Higher universe constructors are passed through unharmed. - TyConSort c -> return $ TCon $ TyConSort c - TyConKind c -> return $ TCon $ TyConKind c - TyConWitness c -> return $ TCon $ TyConWitness c - - -- Handle baked-in unit and function constructors. - TyConSpec TcConFunEC -> return $ TCon $ TyConSpec TcConFunEC - TyConSpec TcConUnit -> return $ O.tPtr O.rTop O.tObj - - -- Convert primitive unboxed TyCons to Salt form. - TyConBound (UPrim n _) _ - -> convertTyConPrim n - - -- Boxed data values are represented in generic form. - _ -> error "ddc-core-salt.convertTyCon: cannot convert type" - - --- | Convert a primitive type constructor to Salt form. -convertTyConPrim :: L.Name -> ConvertM a (Type O.Name) -convertTyConPrim n - = case n of - L.NamePrimTyCon pc - -> return $ TCon $ TyConBound (UPrim (O.NamePrimTyCon pc) kData) kData - _ -> error $ "ddc-core-salt.convertTyConPrim: unknown prim name " ++ show n - - --- Names ---------------------------------------------------------------------- -convertDC - :: KindEnv L.Name - -> DaCon L.Name - -> ConvertM a (DaCon O.Name) - -convertDC kenv dc - = case dc of - DaConUnit - -> return DaConUnit - - DaConPrim n t - -> do n' <- convertBoundNameM n - t' <- convertT kenv t - return $ DaConPrim - { daConName = n' - , daConType = t' } - - DaConBound n - -> do n' <- convertBoundNameM n - return $ DaConBound - { daConName = n' } - - -convertB :: KindEnv L.Name -> Bind L.Name -> ConvertM a (Bind O.Name) -convertB kenv bb - = case bb of - BNone t -> liftM BNone (convertT kenv t) - BAnon t -> liftM BAnon (convertT kenv t) - BName n t -> liftM2 BName (convertBindNameM n) (convertT kenv t) - - -convertU :: Bound L.Name -> ConvertM a (Bound O.Name) -convertU uu - = case uu of - UIx i -> liftM UIx (return i) - UName n -> liftM UName (convertBoundNameM n) - UPrim n t -> liftM2 UPrim (convertBoundNameM n) (convertPrimT t) - - -convertBindNameM :: L.Name -> ConvertM a O.Name -convertBindNameM nn - = case nn of - L.NameVar str -> return $ O.NameVar str - _ -> throw $ ErrorInvalidBinder nn - - -convertBoundNameM :: L.Name -> ConvertM a O.Name -convertBoundNameM nn - = case nn of - L.NameVar str -> return $ O.NameVar str - L.NamePrimArith op -> return $ O.NamePrimOp (O.PrimArith op) - L.NamePrimCast op -> return $ O.NamePrimOp (O.PrimCast op) - L.NameLitBool val -> return $ O.NameLitBool val - L.NameLitNat val -> return $ O.NameLitNat val - L.NameLitInt val -> return $ O.NameLitInt val - L.NameLitWord val bits -> return $ O.NameLitWord val bits - _ -> error $ "ddc-core-salt.convertBoundNameM: cannot convert name " ++ show nn - diff --git a/DDC/Core/Lite/Env.hs b/DDC/Core/Lite/Env.hs deleted file mode 100644 --- a/DDC/Core/Lite/Env.hs +++ /dev/null @@ -1,293 +0,0 @@ - -module DDC.Core.Lite.Env - ( primDataDefs - , primKindEnv - , primTypeEnv - , isBoxedType) -where -import DDC.Core.Lite.Compounds -import DDC.Core.Lite.Name -import DDC.Type.DataDef -import DDC.Type.Compounds -import DDC.Type.Exp -import DDC.Type.Env (Env) -import qualified DDC.Type.Env as Env - - --- DataDefs ------------------------------------------------------------------- --- | Data type definitions --- --- > Type Constructors --- > ---- ------------------------------ --- > Bool# True# False# --- > Nat# 0# 1# 2# ... --- > Int# ... -2i# -1i# 0i# 1i# 2i# ... --- > Tag# (none, convert from Nat#) --- > Word{8,16,32,64}# 42w8# 123w64# ... --- > Float{32,64}# (none, convert from Int#) --- > --- > Unit () --- > Bool B# --- > Nat N# --- > Int I# --- > Pair Pr --- > List Nil Cons --- -primDataDefs :: DataDefs Name -primDataDefs - = fromListDataDefs - -- Unboxed -------------------------------------------------- - -- We need these so that we can match against unboxed patterns - -- in case expressions. - -- Bool# - [ makeDataDefAlg (NamePrimTyCon PrimTyConBool) - [] - (Just [ (NameLitBool True, []) - , (NameLitBool False, []) ]) - - -- Nat# - , makeDataDefAlg (NamePrimTyCon PrimTyConNat) [] Nothing - - -- Int# - , makeDataDefAlg (NamePrimTyCon PrimTyConInt) [] Nothing - - -- WordN# - , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 64)) [] Nothing - , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 32)) [] Nothing - , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 16)) [] Nothing - , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 8)) [] Nothing - - -- Boxed ---------------------------------------------------- - -- Unit - , makeDataDefAlg - (NameDataTyCon DataTyConUnit) - [] - (Just [ ( NamePrimDaCon PrimDaConUnit - , []) ]) - - -- Bool - , makeDataDefAlg - (NameDataTyCon DataTyConBool) - [BAnon kRegion] - (Just [ ( NamePrimDaCon PrimDaConBoolU - , [tBoolU]) ]) - - -- Nat - , makeDataDefAlg - (NameDataTyCon DataTyConNat) - [BAnon kRegion] - (Just [ ( NamePrimDaCon PrimDaConNatU - , [tNatU]) ]) - - -- Int - , makeDataDefAlg - (NameDataTyCon DataTyConInt) - [BAnon kRegion] - (Just [ ( NamePrimDaCon PrimDaConIntU - , [tIntU]) ]) - - -- Pair - , makeDataDefAlg - (NameDataTyCon DataTyConPair) - [BAnon kRegion, BAnon kData, BAnon kData] - (Just [ ( NamePrimDaCon PrimDaConPr - , [tIx kData 1, tIx kData 0]) ]) - - -- List - , makeDataDefAlg - (NameDataTyCon DataTyConList) - [BAnon kRegion, BAnon kData] - (Just [ (NamePrimDaCon PrimDaConNil, [tUnit]) - , (NamePrimDaCon PrimDaConCons, - [tIx kData 0, tList (tIx kRegion 1) (tIx kData 0)])]) - ] - - --- Kinds ---------------------------------------------------------------------- --- | Kind environment containing kinds of primitive data types. -primKindEnv :: Env Name -primKindEnv = Env.setPrimFun kindOfPrimName Env.empty - - --- | Take the kind of a primitive name. -kindOfPrimTyCon :: PrimTyCon -> Kind Name -kindOfPrimTyCon tc - = case tc of - PrimTyConVoid -> kData - PrimTyConPtr -> (kRegion `kFun` kData `kFun` kData) - PrimTyConAddr -> kData - PrimTyConBool -> kData - PrimTyConNat -> kData - PrimTyConInt -> kData - PrimTyConWord _ -> kData - PrimTyConFloat _ -> kData - PrimTyConTag -> kData - PrimTyConString -> kData - PrimTyConVec _ -> kData `kFun` kData - - --- | Take the kind of a primitive name. --- --- Returns `Nothing` if the name isn't primitive. --- -kindOfPrimName :: Name -> Maybe (Kind Name) -kindOfPrimName nn - = case nn of - -- Console - NameEffectTyCon EffectTyConConsole - -> Just $ kEffect - - -- Unit - NameDataTyCon DataTyConUnit - -> Just $ kData - - -- Bool - NameDataTyCon DataTyConBool - -> Just $ kFun kRegion kData - - -- Int - NameDataTyCon DataTyConInt - -> Just $ kFun kRegion kData - - -- Nat - NameDataTyCon DataTyConNat - -> Just $ kFun kRegion kData - - -- Pair - NameDataTyCon DataTyConPair - -> Just $ kRegion `kFun` kData `kFun` kData `kFun` kData - - -- List - NameDataTyCon DataTyConList - -> Just $ kRegion `kFun` kData `kFun` kData - - -- Primitive type constructors. - NamePrimTyCon tc - -> Just $ kindOfPrimTyCon tc - - _ -> Nothing - - --- Types ---------------------------------------------------------------------- --- | Type environment containing types of primitive operators. -primTypeEnv :: Env Name -primTypeEnv = Env.setPrimFun typeOfPrimName Env.empty - - --- | Take the type of a name, --- or `Nothing` if this is not a value name. -typeOfPrimName :: Name -> Maybe (Type Name) -typeOfPrimName dc - = case dc of - -- B# - NamePrimDaCon PrimDaConBoolU - -> Just $ tForall kRegion $ \tR - -> tFunEC tBoolU (tAlloc tR) - (tBot kClosure) - $ tBool tR - - -- N# - NamePrimDaCon PrimDaConNatU - -> Just $ tForall kRegion $ \tR - -> tFunEC tNatU (tAlloc tR) - (tBot kClosure) - $ tNat tR - - -- I# - NamePrimDaCon PrimDaConIntU - -> Just $ tForall kRegion $ \tR - -> tFunEC tIntU (tAlloc tR) - (tBot kClosure) - $ tInt tR - - -- Unit - NamePrimDaCon PrimDaConUnit - -> Just $ tUnit - - -- Pair - NamePrimDaCon PrimDaConPr - -> Just $ tForalls [kRegion, kData, kData] $ \[tR, tA, tB] - -> tFunEC tA (tBot kEffect) - (tBot kClosure) - $ tFunEC tB (tSum kEffect [tAlloc tR]) - (tSum kClosure [tDeepUse tA]) - $ tPair tR tA tB - - -- List - NamePrimDaCon PrimDaConNil - -> Just $ tForalls [kRegion, kData] $ \[tR, tA] - -> tFunEC tUnit (tAlloc tR) - (tBot kClosure) - $ tList tR tA - - NamePrimDaCon PrimDaConCons - -> Just $ tForalls [kRegion, kData] $ \[tR, tA] - -> tFunEC tA (tBot kEffect) - (tBot kClosure) - $ tFunEC (tList tR tA) (tSum kEffect [tAlloc tR]) - (tSum kClosure [tDeepUse tA]) - $ tList tR tA - - -- Primitive arithmetic operators - NamePrimArith p - -> Just $ typeOfPrimArith p - - -- Unboxed Literals - NameLitBool _ -> Just $ tBoolU - NameLitNat _ -> Just $ tNatU - NameLitInt _ -> Just $ tIntU - NameLitWord _ bits -> Just $ tWordU bits - - _ -> Nothing - - --- | Take the type of a primitive arithmetic operator. -typeOfPrimArith :: PrimArith -> Type Name -typeOfPrimArith op - = case op of - -- Numeric - PrimArithNeg -> tForall kData $ \t -> t `tFunPE` t - PrimArithAdd -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithSub -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithMul -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithDiv -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithMod -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithRem -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - - -- Comparison - PrimArithEq -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU - PrimArithNeq -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU - PrimArithGt -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU - PrimArithLt -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU - PrimArithLe -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU - PrimArithGe -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU - - -- Boolean - PrimArithAnd -> tBoolU `tFunPE` tBoolU `tFunPE` tBoolU - PrimArithOr -> tBoolU `tFunPE` tBoolU `tFunPE` tBoolU - - -- Bitwise - PrimArithShl -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithShr -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithBAnd -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithBOr -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithBXOr -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - - --- Unboxed -------------------------------------------------------------------- --- | Check if a type represents a boxed data type, --- where type variables are treated as boxed. -isBoxedType :: Type Name -> Bool -isBoxedType tt - | TVar _ <- tt = True - | TForall _ t <- tt = isBoxedType t - | TSum{} <- tt = False - - | otherwise - = case takeTyConApps tt of - Nothing -> False - Just (TyConSpec TcConUnit, _) -> True - Just (TyConBound (UName (NameDataTyCon _)) _, _) -> True - Just (TyConBound (UPrim (NameDataTyCon _) _) _, _) -> True - _ -> False - diff --git a/DDC/Core/Lite/Layout.hs b/DDC/Core/Lite/Layout.hs deleted file mode 100644 --- a/DDC/Core/Lite/Layout.hs +++ /dev/null @@ -1,148 +0,0 @@ - --- | Layout of algebraic data. -module DDC.Core.Lite.Layout - ( -- * Heap Objects - HeapObject(..) - , heapObjectOfDataCtor - - -- * Fields - , payloadSizeOfDataCtor - , fieldOffsetsOfDataCtor) -where -import DDC.Core.Lite.Name -import DDC.Core.Lite.Env -import DDC.Core.Salt.Platform -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 isBoxedType 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. - | [TCon tc] <- dataCtorFieldTypes ctor - , TyConBound (UPrim n _) _ <- tc - , NamePrimTyCon ptc <- n - , 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 - - -fieldSizeOfPrim :: Platform -> Name -> Maybe Integer -fieldSizeOfPrim platform nn - = case nn of - NameDataTyCon{} -> Just $ platformAddrBytes platform - NamePrimTyCon tc -> fieldSizeOfPrimTyCon platform tc - _ -> Nothing - -fieldSizeOfPrimTyCon :: Platform -> PrimTyCon -> Maybe Integer -fieldSizeOfPrimTyCon platform tc - = case tc of - -- It might make sense to represent these as zero bytes, - -- but I can't think of reason to have them in data type definitions. - PrimTyConVoid -> Nothing - - -- Pointer tycon shouldn't appear by itself. - PrimTyConPtr -> Nothing - - PrimTyConAddr -> Just $ platformAddrBytes platform - PrimTyConNat -> Just $ platformNatBytes platform - PrimTyConInt -> Just $ platformNatBytes platform - PrimTyConTag -> Just $ platformTagBytes platform - PrimTyConBool -> Just $ 1 - - PrimTyConWord bits - | bits `rem` 8 == 0 -> Just $ fromIntegral $ bits `div` 8 - | otherwise -> Nothing - - PrimTyConFloat bits - | bits `rem` 8 == 0 -> Just $ fromIntegral $ bits `div` 8 - | otherwise -> Nothing - - -- Vectors don't appear as raw fields. - PrimTyConVec{} -> Nothing - - -- Strings shouldn't appear as raw fields, only pointers to them. - PrimTyConString -> Nothing - diff --git a/DDC/Core/Lite/Name.hs b/DDC/Core/Lite/Name.hs deleted file mode 100644 --- a/DDC/Core/Lite/Name.hs +++ /dev/null @@ -1,264 +0,0 @@ - -module DDC.Core.Lite.Name - ( Name (..) - - -- * Baked in global effect type constructors. - , EffectTyCon (..) - - -- * Baked in Algebraic Data Types - , DataTyCon (..) - , PrimDaCon (..) - - -- * Primitive Type Constructors - , PrimTyCon (..) - - -- * Primitive Operators - , PrimArith (..) - , PrimCast (..) - - -- * Name Parsing - , readName) -where -import DDC.Core.Salt.Name.PrimTyCon -import DDC.Core.Salt.Name.PrimArith -import DDC.Core.Salt.Name.PrimCast -import DDC.Core.Salt.Name.Lit -import DDC.Base.Pretty -import Control.DeepSeq -import Data.Typeable -import Data.Char - - --- | Names of things used in Disciple Core Lite. -data Name - -- | User defined variables. - = NameVar String - - -- | A user defined constructor. - | NameCon String - - -- | Baked in effect type constructors. - | NameEffectTyCon EffectTyCon - - -- | Baked in data type constructors. - | NameDataTyCon DataTyCon - - -- | A primitive data constructor. - | NamePrimDaCon PrimDaCon - - -- | A primitive type constructor. - | NamePrimTyCon PrimTyCon - - -- | Primitive arithmetic, logic, comparison and bit-wise operators. - | NamePrimArith PrimArith - - -- | Primitive casting between numeric types. - | NamePrimCast PrimCast - - -- | An unboxed boolean literal - | NameLitBool Bool - - -- | An unboxed natural literal. - | NameLitNat Integer - - -- | An unboxed integer literal. - | NameLitInt Integer - - -- | An unboxed word literal - | NameLitWord Integer Int - deriving (Eq, Ord, Show, Typeable) - - -instance NFData Name where - rnf nn - = case nn of - NameVar s -> rnf s - NameCon s -> rnf s - NameEffectTyCon con -> rnf con - NameDataTyCon con -> rnf con - NamePrimDaCon con -> rnf con - NamePrimTyCon con -> rnf con - NamePrimArith con -> rnf con - NamePrimCast c -> rnf c - NameLitBool b -> rnf b - NameLitNat n -> rnf n - NameLitInt i -> rnf i - NameLitWord i bits -> rnf i `seq` rnf bits - - -instance Pretty Name where - ppr nn - = case nn of - NameVar v -> text v - NameCon c -> text c - NameEffectTyCon con -> ppr con - NameDataTyCon dc -> ppr dc - NamePrimTyCon tc -> ppr tc - NamePrimDaCon dc -> ppr dc - 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 "#" - - --- | Read the name of a variable, constructor or literal. -readName :: String -> Maybe Name -readName str - | Just name <- readEffectTyCon str - = Just $ NameEffectTyCon name - - | Just name <- readDataTyCon str - = Just $ NameDataTyCon name - - | Just name <- readPrimTyCon str - = Just $ NamePrimTyCon name - - | Just name <- readPrimDaCon str - = Just $ NamePrimDaCon name - - -- PrimArith - | Just p <- readPrimArith str - = Just $ NamePrimArith p - - -- PrimCast - | Just p <- readPrimCast str - = Just $ NamePrimCast p - - -- Literal unit value. - | str == "()" - = Just $ NamePrimDaCon PrimDaConUnit - - -- Literal Bools - | str == "True#" = Just $ NameLitBool True - | str == "False#" = Just $ NameLitBool False - - -- Literal Nat - | Just val <- readLitPrimNat str - = Just $ NameLitNat val - - -- Literal Ints - | Just val <- readLitPrimInt str - = Just $ NameLitInt val - - -- Literal Words - | Just (val, bits) <- readLitPrimWordOfBits str - , elem bits [8, 16, 32, 64] - = Just $ NameLitWord val bits - - -- Constructors. - | c : _ <- str - , isUpper c - = Just $ NameCon str - - -- Variables. - | c : _ <- str - , isLower c - = Just $ NameVar str - - | otherwise - = Nothing - - --- EffectTyCon ---------------------------------------------------------------- --- | Baked-in effect type constructors. -data EffectTyCon - = EffectTyConConsole -- ^ @Console@ type constructor. - deriving (Eq, Ord, Show) - -instance NFData EffectTyCon - -instance Pretty EffectTyCon where - ppr tc - = case tc of - EffectTyConConsole -> text "Console" - - --- | Read a baked-in effect type constructor. -readEffectTyCon :: String -> Maybe EffectTyCon -readEffectTyCon str - = case str of - "Console" -> Just EffectTyConConsole - _ -> Nothing - - --- DataTyCon ------------------------------------------------------------------ --- | Baked-in data type constructors. -data DataTyCon - = DataTyConUnit -- ^ @Unit@ type constructor. - | DataTyConBool -- ^ @Bool@ type constructor. - | DataTyConNat -- ^ @Nat@ type constructor. - | DataTyConInt -- ^ @Int@ type constructor. - | DataTyConPair -- ^ @Pair@ type constructor. - | DataTyConList -- ^ @List@ type constructor. - deriving (Eq, Ord, Show) - -instance NFData DataTyCon - -instance Pretty DataTyCon where - ppr dc - = case dc of - DataTyConUnit -> text "Unit" - DataTyConBool -> text "Bool" - DataTyConNat -> text "Nat" - DataTyConInt -> text "Int" - DataTyConPair -> text "Pair" - DataTyConList -> text "List" - - --- | Read a baked-in data type constructor. -readDataTyCon :: String -> Maybe DataTyCon -readDataTyCon str - = case str of - "Unit" -> Just DataTyConUnit - "Bool" -> Just DataTyConBool - "Nat" -> Just DataTyConNat - "Int" -> Just DataTyConInt - "Pair" -> Just DataTyConPair - "List" -> Just DataTyConList - _ -> Nothing - - --- PrimDaCon ------------------------------------------------------------------ --- | Baked-in data constructors. -data PrimDaCon - = PrimDaConUnit -- ^ Unit data constructor @()@. - | PrimDaConBoolU -- ^ @B#@ data constructor. - | PrimDaConNatU -- ^ @N#@ data constructor. - | PrimDaConIntU -- ^ @I#@ data constructor. - | PrimDaConPr -- ^ @Pr@ data construct (pairs). - | PrimDaConNil -- ^ @Nil@ data constructor (lists). - | PrimDaConCons -- ^ @Cons@ data constructor (lists). - deriving (Show, Eq, Ord) - -instance NFData PrimDaCon - -instance Pretty PrimDaCon where - ppr dc - = case dc of - PrimDaConBoolU -> text "B#" - PrimDaConNatU -> text "N#" - PrimDaConIntU -> text "I#" - - PrimDaConUnit -> text "()" - PrimDaConPr -> text "Pr" - PrimDaConNil -> text "Nil" - PrimDaConCons -> text "Cons" - - --- | Read a Baked-in data constructor. -readPrimDaCon :: String -> Maybe PrimDaCon -readPrimDaCon str - = case str of - "B#" -> Just PrimDaConBoolU - "N#" -> Just PrimDaConNatU - "I#" -> Just PrimDaConIntU - - "()" -> Just PrimDaConUnit - "Pr" -> Just PrimDaConPr - "Nil" -> Just PrimDaConNil - "Cons" -> Just PrimDaConCons - _ -> Nothing - diff --git a/DDC/Core/Lite/Profile.hs b/DDC/Core/Lite/Profile.hs deleted file mode 100644 --- a/DDC/Core/Lite/Profile.hs +++ /dev/null @@ -1,76 +0,0 @@ - --- | Language profile for Disciple Core Lite. -module DDC.Core.Lite.Profile - ( profile - , lexModuleString - , lexExpString) -where -import DDC.Core.Lite.Env -import DDC.Core.Lite.Name -import DDC.Core.Fragment -import DDC.Core.Lexer -import DDC.Data.Token - - --- | Profile for Disciple Core Lite. -profile :: Profile Name -profile - = Profile - { profileName = "Lite" - , profileFeatures = features - , profilePrimDataDefs = primDataDefs - , profilePrimKinds = primKindEnv - , profilePrimTypes = primTypeEnv - , profileTypeIsUnboxed = const False - , profileNameIsHole = Nothing } - - -features :: Features -features - = Features - { featuresTrackedEffects = True - , featuresTrackedClosures = True - , featuresFunctionalEffects = True - , featuresFunctionalClosures = True - , featuresEffectCapabilities = False - , featuresPartialPrims = False - , featuresPartialApplication = True - , featuresGeneralApplication = True - , featuresNestedFunctions = True - , featuresDebruijnBinders = True - , featuresUnboundLevel0Vars = False - - -- We allow unboxed instantiation in Lite, though all all - -- polymorphic functions applied to unboxed types will need - -- to be specialised before Salt will accept the code. - , featuresUnboxedInstantiation = True - - , featuresNameShadowing = False - , featuresUnusedBindings = True - , featuresUnusedMatches = False } - - --- | Lex a string to tokens, using primitive names. --- --- The first argument gives the starting source line number. -lexModuleString :: String -> Int -> String -> [Token (Tok Name)] -lexModuleString sourceName lineStart str - = map rn $ lexModuleWithOffside sourceName lineStart str - where rn (Token strTok sp) - = case renameTok readName strTok of - Just t' -> Token t' sp - Nothing -> Token (KJunk "lexical error") sp - - --- | Lex a string to tokens, using primitive names. --- --- The first argument gives the starting source line number. -lexExpString :: String -> Int -> String -> [Token (Tok Name)] -lexExpString sourceName lineStart str - = map rn $ lexExp sourceName lineStart str - where rn (Token strTok sp) - = case renameTok readName strTok of - Just t' -> Token t' sp - Nothing -> Token (KJunk "lexical error") sp - - diff --git a/DDC/Core/Salt.hs b/DDC/Core/Salt.hs --- a/DDC/Core/Salt.hs +++ b/DDC/Core/Salt.hs @@ -1,4 +1,3 @@ - -- | Disciple Core Salt. -- -- This is what happens to 'C' when you leave it out in the sun for too long. @@ -16,35 +15,54 @@ ( -- * Language profile profile - -- * Conversion - , seaOfSaltModule - , Error(..) - -- * Names , Name (..) , PrimTyCon (..) - , PrimOp (..) - , PrimCast (..) - , primCastPromoteIsValid - , primCastTruncateIsValid + -- ** Primitive Values + , PrimVal (..) + , pattern NamePrimOp + , pattern NamePrimLit + -- ** Primitive Operators + , PrimOp (..) + , PrimArith (..) , PrimCall (..) - + , PrimCast (..) , PrimControl (..) - , PrimStore (..) - , PrimArith (..) + , primCastPromoteIsValid + , primCastTruncateIsValid + -- ** Primitive Literals + , PrimLit (..) + , pattern NameLitVoid + , pattern NameLitBool + , pattern NameLitNat + , pattern NameLitInt + , pattern NameLitSize + , pattern NameLitWord + , pattern NameLitFloat + , pattern NameLitTextLit + , pattern NameLitTag + -- * Name parsing , readName + , takeNameVar -- * Program lexing , lexModuleString - , lexExpString) + , lexExpString + -- * Conversion + , seaOfSaltModule + , Error(..) + + -- * Salt expressions + , module DDC.Core.Salt.Exp) where import DDC.Core.Salt.Name import DDC.Core.Salt.Profile import DDC.Core.Salt.Convert +import DDC.Core.Salt.Exp diff --git a/DDC/Core/Salt/Compounds.hs b/DDC/Core/Salt/Compounds.hs --- a/DDC/Core/Salt/Compounds.hs +++ b/DDC/Core/Salt/Compounds.hs @@ -1,71 +1,45 @@ module DDC.Core.Salt.Compounds - ( tVoid - , tBool, xBool - , tNat, xNat - , tInt, xInt - , tWord, xWord - , tTag, xTag - , tObj + ( -- * Types + tVoid, tBool, tNat, tInt, tSize, tWord, tFloat , tAddr , tPtr, takeTPtr - , tString) -where -import DDC.Core.Salt.Name -import DDC.Core.Exp -import DDC.Core.Compounds - - --- Types ---------------------------------------------------------------------- -tVoid, tBool, tNat, tInt, tTag, tAddr, tString :: Type Name -tVoid = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConVoid) kData) kData) -tBool = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConBool) kData) kData) -tNat = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConNat) kData) kData) -tInt = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConInt) kData) kData) -tTag = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConTag) kData) kData) -tAddr = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConAddr) kData) kData) -tString = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConString) kData) kData) - - -tWord :: Int -> Type Name -tWord bits = TCon (TyConBound (UPrim (NamePrimTyCon (PrimTyConWord bits)) kData) kData) - - -tObj :: Type Name -tObj = TCon (TyConBound (UPrim NameObjTyCon kData) kData) - - -tPtr :: Region Name -> Type Name -> Type Name -tPtr r t = TApp (TApp (TCon tcPtr) r) t - where tcPtr = TyConBound (UPrim (NamePrimTyCon PrimTyConPtr) kPtr) kPtr - kPtr = kRegion `kFun` kData `kFun` kData - -takeTPtr :: Type Name -> Maybe (Region Name, Type Name) -takeTPtr tt - = case tt of - TApp (TApp (TCon tc) r) t - | TyConBound (UPrim (NamePrimTyCon PrimTyConPtr) _) _ <- tc - -> Just (r, t) - - _ -> Nothing - --- Expressions ---------------------------------------------------------------- -xBool :: a -> Bool -> Exp a Name -xBool a b = XCon a (DaConPrim (NameLitBool b) tBool) - - -xNat :: a -> Integer -> Exp a Name -xNat a i = XCon a (DaConPrim (NameLitNat i) tNat) + , tTextLit + , tTag + , tObj + -- * Values + -- ** Literals + , xBool, xNat, xInt, xSize, xWord, xFloat, xTag, xTextLit -xInt :: a -> Integer -> Exp a Name -xInt a i = XCon a (DaConPrim (NameLitInt i) tInt) + -- ** Primitive arithmetic operators. + , xNeg + , xAdd, xSub, xMul, xDiv, xMod, xRem + , xEq, xNeq, xLt, xGt, xLe, xGe + , xAnd, xOr + , xShl, xShr, xBAnd, xBOr, xBXOr + -- ** Primitive cast operators. + , xConvert + , xPromote + , xTruncate -xWord :: a -> Integer -> Int -> Exp a Name -xWord a i bits = XCon a (DaConPrim (NameLitWord i bits) (tWord bits)) + -- ** Primitive control operators. + , xFail + , xReturn + -- ** Primitive store operators. + , xStoreSize, xStoreSize2 + , xCreate + , xRead, xWrite + , xPeek, xPeekBounded, xPoke, xPokeBounded + , xCastPtr) +where +import DDC.Core.Salt.Compounds.Lit +import DDC.Core.Salt.Compounds.PrimArith +import DDC.Core.Salt.Compounds.PrimCast +import DDC.Core.Salt.Compounds.PrimStore +import DDC.Core.Salt.Compounds.PrimControl +import DDC.Core.Salt.Compounds.PrimTyCon -xTag :: a -> Integer -> Exp a Name -xTag a i = XCon a (DaConPrim (NameLitTag i) tTag) diff --git a/DDC/Core/Salt/Compounds/Lit.hs b/DDC/Core/Salt/Compounds/Lit.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Compounds/Lit.hs @@ -0,0 +1,49 @@ + +module DDC.Core.Salt.Compounds.Lit + ( xBool + , xNat, xInt, xSize + , xWord, xFloat, xTag + , xTextLit) +where +import DDC.Core.Salt.Compounds.PrimTyCon +import DDC.Core.Salt.Name +import DDC.Core.Exp +import Data.Text (Text) + + +xBool :: a -> Bool -> Exp a Name +xBool a b = XCon a (DaConPrim (NameLitBool b) tBool) + + +xNat :: a -> Integer -> Exp a Name +xNat a i = XCon a (dcNat i) + + +xInt :: a -> Integer -> Exp a Name +xInt a i = XCon a (DaConPrim (NameLitInt i) tInt) + + +xSize :: a -> Integer -> Exp a Name +xSize a i = XCon a (DaConPrim (NameLitSize i) tSize) + + +xWord :: a -> Integer -> Int -> Exp a Name +xWord a i bits = XCon a (DaConPrim (NameLitWord i bits) (tWord bits)) + + +xFloat :: a -> Double -> Int -> Exp a Name +xFloat a i bits = XCon a (DaConPrim (NameLitFloat i bits) (tFloat bits)) + + +xTag :: a -> Integer -> Exp a Name +xTag a i = XCon a (DaConPrim (NameLitTag i) tTag) + + +-- | A Literal @Nat#@ data constructor. +dcNat :: Integer -> DaCon Name +dcNat i = DaConPrim (NameLitNat i) tNat + + +-- | A Text literal. +xTextLit :: a -> Text -> Exp a Name +xTextLit a tx = XCon a (DaConPrim (NameLitTextLit tx) tTextLit) diff --git a/DDC/Core/Salt/Compounds/PrimArith.hs b/DDC/Core/Salt/Compounds/PrimArith.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Compounds/PrimArith.hs @@ -0,0 +1,88 @@ + +-- | Construct applications of primitive arithmetic operators. +module DDC.Core.Salt.Compounds.PrimArith + ( xNeg + , xAdd, xSub, xMul, xDiv, xMod, xRem + , xEq, xNeq, xLt, xGt, xLe, xGe + , xAnd, xOr + , xShl, xShr, xBAnd, xBOr, xBXOr + , typeOfPrimArith ) +where +import DDC.Core.Salt.Compounds.PrimTyCon +import DDC.Core.Salt.Name +import DDC.Core.Exp.Annot + + +xNeg = xOp1 PrimArithNeg + +xAdd = xOp2 PrimArithAdd +xSub = xOp2 PrimArithSub +xMul = xOp2 PrimArithMul +xDiv = xOp2 PrimArithDiv +xMod = xOp2 PrimArithMod +xRem = xOp2 PrimArithRem + +xEq = xOp2 PrimArithEq +xNeq = xOp2 PrimArithNeq +xLt = xOp2 PrimArithLt +xGt = xOp2 PrimArithGt +xLe = xOp2 PrimArithLe +xGe = xOp2 PrimArithGe + +xAnd = xOp2 PrimArithAnd +xOr = xOp2 PrimArithOr + +xShl = xOp2 PrimArithShl +xShr = xOp2 PrimArithShr +xBAnd = xOp2 PrimArithBAnd +xBOr = xOp2 PrimArithBOr +xBXOr = xOp2 PrimArithBXOr + + +xOp1 :: PrimArith -> a -> Type Name -> Exp a Name -> Exp a Name +xOp1 p a tElem x1 + = let u = UPrim (NamePrimOp $ PrimArith $ p) + (typeOfPrimArith p) + in xApps a (XVar a u) [XType a tElem, x1] + + +xOp2 :: PrimArith -> a -> Type Name -> Exp a Name -> Exp a Name -> Exp a Name +xOp2 p a tElem x1 x2 + = let u = UPrim (NamePrimOp $ PrimArith $ p) + (typeOfPrimArith p) + in xApps a (XVar a u) [XType a tElem, x1, x2] + + +-- | Take the type of a primitive operator. +typeOfPrimArith :: PrimArith -> Type Name +typeOfPrimArith op + = case op of + -- Numeric + 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 + + -- Comparison + PrimArithEq -> tForall kData $ \t -> t `tFun` t `tFun` tBool + PrimArithNeq -> tForall kData $ \t -> t `tFun` t `tFun` tBool + PrimArithGt -> tForall kData $ \t -> t `tFun` t `tFun` tBool + PrimArithLt -> tForall kData $ \t -> t `tFun` t `tFun` tBool + PrimArithLe -> tForall kData $ \t -> t `tFun` t `tFun` tBool + PrimArithGe -> tForall kData $ \t -> t `tFun` t `tFun` tBool + + -- Boolean + PrimArithAnd -> tBool `tFun` tBool `tFun` tBool + PrimArithOr -> tBool `tFun` tBool `tFun` tBool + + -- Bitwise + 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 + + diff --git a/DDC/Core/Salt/Compounds/PrimCast.hs b/DDC/Core/Salt/Compounds/PrimCast.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Compounds/PrimCast.hs @@ -0,0 +1,53 @@ + +-- | Construct applications of primitive cast operators. +module DDC.Core.Salt.Compounds.PrimCast + ( xConvert + , xPromote + , xTruncate + + , typeOfPrimCast ) +where +import DDC.Core.Salt.Name +import DDC.Core.Exp.Annot + + +-- | All the Prim Cast vars have this form. +xPrimCast a p + = XVar a (UPrim (NamePrimOp $ PrimCast p) (typeOfPrimCast p)) + + +-- | Convert a value to a similarly sized type. +xConvert :: a -> Type Name -> Type Name -> Exp a Name -> Exp a Name +xConvert a t1 t2 x + = xApps a (xPrimCast a PrimCastConvert) + [XType a t1, XType a t2, x] + + +-- | Promote a value to a wider type. +xPromote :: a -> Type Name -> Type Name -> Exp a Name -> Exp a Name +xPromote a t1 t2 x + = xApps a (xPrimCast a PrimCastPromote) + [XType a t1, XType a t2, x] + + +-- | Truncate a value to a narrower type. +xTruncate :: a -> Type Name -> Type Name -> Exp a Name -> Exp a Name +xTruncate a t1 t2 x + = xApps a (xPrimCast a PrimCastTruncate) + [XType a t1, XType a t2, x] + + +-- | Take the type of a primitive cast. +typeOfPrimCast :: PrimCast -> Type Name +typeOfPrimCast cc + = case cc of + PrimCastConvert + -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFun` t1 + + PrimCastPromote + -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFun` t1 + + PrimCastTruncate + -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFun` t1 + + diff --git a/DDC/Core/Salt/Compounds/PrimControl.hs b/DDC/Core/Salt/Compounds/PrimControl.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Compounds/PrimControl.hs @@ -0,0 +1,37 @@ + +-- | Construct applications of primitive control operators. +module DDC.Core.Salt.Compounds.PrimControl + ( xFail + , xReturn + , typeOfPrimControl) +where +import DDC.Core.Salt.Name +import DDC.Core.Exp.Annot + + +-- | All the Prim Control vars have this form. +xPrimControl a p + = XVar a (UPrim (NamePrimOp $ PrimControl p) (typeOfPrimControl p)) + + +-- | Fail with an internal error. +xFail :: a -> Type Name -> Exp a Name +xFail a t + = xApps a (xPrimControl a PrimControlFail) + [XType a t] + + +-- | Return a value. +xReturn :: a -> Type Name -> Exp a Name -> Exp a Name +xReturn a t x + = xApps a (xPrimControl a PrimControlReturn) + [XType a t, x] + + +typeOfPrimControl :: PrimControl -> Type Name +typeOfPrimControl pc + = case pc of + PrimControlFail -> tForall kData $ \t -> t + PrimControlReturn -> tForall kData $ \t -> t `tFun` t + + diff --git a/DDC/Core/Salt/Compounds/PrimStore.hs b/DDC/Core/Salt/Compounds/PrimStore.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Compounds/PrimStore.hs @@ -0,0 +1,167 @@ + +-- | Construct applications of primitive store operators. +module DDC.Core.Salt.Compounds.PrimStore + ( xStoreSize, xStoreSize2 + , xCreate + , xRead, xWrite + , xPeek, xPeekBounded, xPoke, xPokeBounded + , xCastPtr + + , typeOfPrimStore) +where +import DDC.Core.Salt.Compounds.PrimTyCon +import DDC.Core.Salt.Name +import DDC.Core.Exp.Annot + + +-- | All the Prim Store vars have this form. +xPrimStore a p + = XVar a (UPrim (NamePrimOp $ PrimStore p) (typeOfPrimStore p)) + + +-- | Take the number of bytes needed to store a value of a primitive type. +xStoreSize :: a -> Type Name -> Exp a Name +xStoreSize a tElem + = xApps a (xPrimStore a PrimStoreSize) + [XType a tElem] + + +-- | Log2 of the number of bytes needed to store a value of primitive type. +xStoreSize2 :: a -> Type Name -> Exp a Name +xStoreSize2 a tElem + = xApps a (xPrimStore a PrimStoreSize2) + [XType a tElem] + +-- | Create the heap. +xCreate :: a -> Exp a Name -> Exp a Name +xCreate a xLength + = xApps a (xPrimStore a PrimStoreCreate) + [xLength] + + +-- | Read a value from an address plus offset. +xRead :: a -> Type Name -> Exp a Name -> Exp a Name -> Exp a Name +xRead a tField xAddr xOffset + = xApps a (xPrimStore a PrimStoreRead) + [ XType a tField, xAddr, xOffset ] + + +-- | Write a value to an address plus offset. +xWrite :: a -> Type Name -> Exp a Name -> Exp a Name -> Exp a Name -> Exp a Name +xWrite a tField xAddr xOffset xVal + = xApps a (xPrimStore a PrimStoreWrite) + [ XType a tField, xAddr, xOffset, xVal ] + + +-- | Peek a value from a buffer pointer plus offset. +xPeek :: a -> Type Name -> Type Name -> Exp a Name -> Exp a Name -> Exp a Name +xPeek a r t xPtr xOffset + = xApps a (xPrimStore a PrimStorePeek) + [ XType a r, XType a t, xPtr, xOffset ] + + +-- | Peek a value from a buffer pointer plus offset. +xPeekBounded + :: a -> Type Name -> Type Name + -> Exp a Name -> Exp a Name -> Exp a Name -> Exp a Name +xPeekBounded a r t xPtr xOffset xLimit + = xApps a (xPrimStore a PrimStorePeekBounded) + [ XType a r, XType a t, xPtr, xOffset, xLimit ] + + +-- | Poke a value from a buffer pointer plus offset. +xPoke :: a -> Type Name -> Type Name + -> Exp a Name -> Exp a Name -> Exp a Name -> Exp a Name +xPoke a r t xPtr xOffset xVal + = xApps a (xPrimStore a PrimStorePoke) + [ XType a r, XType a t, xPtr, xOffset, xVal] + + +-- | Poke a value from a buffer pointer plus offset. +xPokeBounded + :: a -> Type Name -> Type Name + -> Exp a Name -> Exp a Name -> Exp a Name -> Exp a Name -> Exp a Name +xPokeBounded a r t xPtr xOffset xLimit xVal + = xApps a (xPrimStore a PrimStorePokeBounded) + [ XType a r, XType a t, xPtr, xOffset, xLimit, xVal] + + +-- | Cast a pointer to a different element ype. +xCastPtr :: a -> Type Name -> Type Name -> Type Name -> Exp a Name -> Exp a Name +xCastPtr a r toType fromType xPtr + = xApps a (xPrimStore a PrimStoreCastPtr) + [ XType a r, XType a toType, XType a fromType, xPtr ] + + +-- | Take the type of a primitive projection. +typeOfPrimStore :: PrimStore -> Type Name +typeOfPrimStore jj + = case jj of + PrimStoreSize + -> tForall kData $ \_ -> tNat + + PrimStoreSize2 + -> tForall kData $ \_ -> tNat + + PrimStoreCreate + -> tNat `tFun` tVoid + + PrimStoreCheck + -> tNat `tFun` tBool + + PrimStoreRecover + -> tNat `tFun` tVoid + + PrimStoreAlloc + -> tNat `tFun` tAddr + + PrimStoreRead + -> tForall kData + $ \t -> tAddr `tFun` tNat `tFun` t + + PrimStoreWrite + -> tForall kData + $ \t -> tAddr `tFun` tNat `tFun` t `tFun` tVoid + + PrimStorePlusAddr + -> tAddr `tFun` tNat `tFun` tAddr + + PrimStoreMinusAddr + -> tAddr `tFun` tNat `tFun` tAddr + + PrimStorePeek + -> tForalls [kRegion, kData] + $ \[r,t] -> tPtr r t `tFun` tNat `tFun` t + + PrimStorePoke + -> tForalls [kRegion, kData] + $ \[r,t] -> tPtr r t `tFun` tNat `tFun` t `tFun` tVoid + + PrimStorePeekBounded + -> tForalls [kRegion, kData] + $ \[r,t] -> tPtr r t `tFun` tNat `tFun` tNat `tFun` t + + PrimStorePokeBounded + -> tForalls [kRegion, kData] + $ \[r,t] -> tPtr r t `tFun` tNat `tFun` tNat `tFun` t `tFun` tVoid + + PrimStorePlusPtr + -> tForalls [kRegion, kData] + $ \[r,t] -> tPtr r t `tFun` tNat `tFun` tPtr r t + + PrimStoreMinusPtr + -> tForalls [kRegion, kData] + $ \[r,t] -> tPtr r t `tFun` tNat `tFun` tPtr r t + + PrimStoreMakePtr + -> tForalls [kRegion, kData] + $ \[r,t] -> tAddr `tFun` tPtr r t + + PrimStoreTakePtr + -> tForalls [kRegion, kData] + $ \[r,t] -> tPtr r t `tFun` tAddr + + PrimStoreCastPtr + -> tForalls [kRegion, kData, kData] + $ \[r,t1,t2] -> tPtr r t2 `tFun` tPtr r t1 + diff --git a/DDC/Core/Salt/Compounds/PrimTyCon.hs b/DDC/Core/Salt/Compounds/PrimTyCon.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Compounds/PrimTyCon.hs @@ -0,0 +1,53 @@ + +-- | Construct applications of primitive type constructors. +module DDC.Core.Salt.Compounds.PrimTyCon + ( tVoid, tBool, tNat, tInt, tSize, tWord, tFloat + , tAddr + , tPtr, takeTPtr + , tTextLit + , tTag + + , tObj) +where +import DDC.Core.Salt.Name +import DDC.Core.Exp.Annot + + +tVoid, tBool, tNat, tInt, tSize, tTag, tAddr, tTextLit :: Type Name +tVoid = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConVoid) kData) kData) +tBool = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConBool) kData) kData) +tNat = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConNat) kData) kData) +tInt = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConInt) kData) kData) +tSize = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConSize) kData) kData) +tAddr = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConAddr) kData) kData) +tTag = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConTag) kData) kData) +tTextLit = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConTextLit) kData) kData) + + +tWord :: Int -> Type Name +tWord bits = TCon (TyConBound (UPrim (NamePrimTyCon (PrimTyConWord bits)) kData) kData) + + +tFloat :: Int -> Type Name +tFloat bits = TCon (TyConBound (UPrim (NamePrimTyCon (PrimTyConFloat bits)) kData) kData) + + +-- Pointer +tPtr :: Region Name -> Type Name -> Type Name +tPtr r t = TApp (TApp (TCon tcPtr) r) t + where tcPtr = TyConBound (UPrim (NamePrimTyCon PrimTyConPtr) kPtr) kPtr + kPtr = kRegion `kFun` kData `kFun` kData + +takeTPtr :: Type Name -> Maybe (Region Name, Type Name) +takeTPtr tt + = case tt of + TApp (TApp (TCon tc) r) t + | TyConBound (UPrim (NamePrimTyCon PrimTyConPtr) _) _ <- tc + -> Just (r, t) + + _ -> Nothing + + +tObj :: Type Name +tObj = TCon (TyConBound (UPrim NameObjTyCon kData) kData) + diff --git a/DDC/Core/Salt/Convert.hs b/DDC/Core/Salt/Convert.hs --- a/DDC/Core/Salt/Convert.hs +++ b/DDC/Core/Salt/Convert.hs @@ -24,9 +24,8 @@ import DDC.Core.Salt.Convert.Base import DDC.Core.Salt.Name import DDC.Core.Salt.Platform -import DDC.Core.Compounds import DDC.Core.Module as C -import DDC.Core.Exp +import DDC.Core.Exp.Annot import DDC.Base.Pretty import DDC.Control.Monad.Check (throw, evalCheck) import qualified DDC.Type.Env as Env @@ -91,7 +90,7 @@ -> convSuperTypeM Env.empty misrc Nothing nSuper tSuper) [ (Just isrc, nSuper, tSuper) | (nSuper, isrc) <- C.moduleImportValues mm - , let tSuper = typeOfImportSource isrc ] + , let tSuper = typeOfImportValue isrc ] let cExterns | not withPrelude = empty @@ -127,14 +126,14 @@ -- This is the code for locally defined functions. -- Build the top-level kind environment. - let kenv = Env.fromList - $ [ BName n (typeOfImportSource isrc) - | (n, isrc) <- moduleImportTypes mm ] + let kenv = Env.fromList + $ [ BName n (kindOfImportType isrc) + | (n, isrc) <- moduleImportTypes mm ] -- Build the top-level type environment. - let tenv = Env.fromList - $ [ BName n (typeOfImportSource isrc) - | (n, isrc) <- moduleImportValues mm ] + let tenv = Env.fromList + $ [ BName n (typeOfImportValue isrc) + | (n, isrc) <- moduleImportValues mm ] -- Convert all the super definitions to C code. let convSuperM' (BName n t) x diff --git a/DDC/Core/Salt/Convert/Exp.hs b/DDC/Core/Salt/Convert/Exp.hs --- a/DDC/Core/Salt/Convert/Exp.hs +++ b/DDC/Core/Salt/Convert/Exp.hs @@ -12,10 +12,8 @@ import DDC.Core.Salt.Convert.Type import DDC.Core.Salt.Name import DDC.Core.Salt.Platform -import DDC.Core.Predicates -import DDC.Core.Compounds import DDC.Core.Module -import DDC.Core.Exp +import DDC.Core.Exp.Annot import DDC.Type.Env (KindEnv, TypeEnv) import DDC.Base.Pretty import DDC.Control.Monad.Check (throw) @@ -72,7 +70,7 @@ XApp{} -- At the top-level of a function body then the last statement - -- expliticlty passes control. + -- explicitly passes control. | ContextTop <- context -> case takeXPrimApps xx of Just (NamePrimOp p, xs) @@ -147,6 +145,17 @@ in convBlockM config context kenv' tenv' x -- Case-expression. + -- Prettier printing if it only one default case + XCase _ _x [AAlt PDefault x1] + -> do convBlockM config context kenv tenv x1 + + -- Case-expression. + -- Special case for units. + -- There may be other cases, but it can only be a dead default + XCase _ _x (AAlt (PData DaConUnit []) x1 : _) + -> do convBlockM config context kenv tenv x1 + + -- Case-expression. -- Prettier printing for case-expression that just checks for failure. XCase _ x [ AAlt (PData dc []) x1 , AAlt PDefault xFail] @@ -168,8 +177,8 @@ -- Prettier printing for if-then-else. XCase _ x [ AAlt (PData dc1 []) x1 , AAlt (PData dc2 []) x2 ] - | Just (NameLitBool True) <- takeNameOfDaCon dc1 - , Just (NameLitBool False) <- takeNameOfDaCon dc2 + | Just (NamePrimLit (PrimLitBool True)) <- takeNameOfDaCon dc1 + , Just (NamePrimLit (PrimLitBool False)) <- takeNameOfDaCon dc2 -> do x' <- convRValueM config kenv tenv x x1' <- convBlockM config context kenv tenv x1 x2' <- convBlockM config context kenv tenv x2 @@ -264,23 +273,27 @@ -- cases on float literals into a sequence of boolean checks. convDaConName :: Name -> Maybe Doc convDaConName nn - = case nn of - NameLitBool True -> Just $ int 1 - NameLitBool False -> Just $ int 0 + | NamePrimVal (PrimValLit lit) <- nn + = case lit of + PrimLitBool True -> Just $ int 1 + PrimLitBool False -> Just $ int 0 - NameLitNat i -> Just $ integer i + PrimLitNat i -> Just $ integer i - NameLitInt i -> Just $ integer i + PrimLitInt i -> Just $ integer i - NameLitWord i bits + PrimLitWord i bits | elem bits [8, 16, 32, 64] -> Just $ integer i - NameLitTag i -> Just $ integer i + PrimLitTag i -> Just $ integer i _ -> Nothing + | otherwise + = Nothing + -- RValue ----------------------------------------------------------------------------------------- -- | Convert an Right-value to C source text. convRValueM @@ -299,18 +312,21 @@ -> return $ n' -- Literals + XCon _ DaConUnit + -> return $ integer 0 + XCon _ dc - | DaConPrim n _ <- dc - -> case n of - NameLitBool b + | DaConPrim (NamePrimLit p) _ <- dc + -> case p of + PrimLitBool b | b -> return $ integer 1 | otherwise -> return $ integer 0 - NameLitNat i -> return $ integer i - NameLitInt i -> return $ integer i - NameLitWord i _ -> return $ integer i - NameLitTag i -> return $ integer i - NameLitVoid -> return $ text "void" + PrimLitNat i -> return $ integer i + PrimLitInt i -> return $ integer i + PrimLitWord i _ -> return $ integer i + PrimLitTag i -> return $ integer i + PrimLitVoid -> return $ text "void" _ -> throw $ ErrorRValueInvalid xx -- Primop application. diff --git a/DDC/Core/Salt/Convert/Init.hs b/DDC/Core/Salt/Convert/Init.hs --- a/DDC/Core/Salt/Convert/Init.hs +++ b/DDC/Core/Salt/Convert/Init.hs @@ -7,8 +7,7 @@ import DDC.Core.Salt.Runtime import DDC.Core.Salt.Name import DDC.Core.Module -import DDC.Core.Exp -import DDC.Core.Compounds +import DDC.Core.Exp.Annot import Data.List @@ -37,7 +36,7 @@ -- | Type of the POSIX main function. posixMainType :: Type Name posixMainType - = tFunPE tInt (tFunPE (tPtr rTop tString) tInt) + = tFun tInt (tFun (tPtr rTop (tWord 8)) tInt) -- | Patch the list of export definitions to export our wrapper instead @@ -98,11 +97,12 @@ -- which is the entry point to the executable. makeMainEntryX :: Config -> a -> Exp a Name makeMainEntryX config a - = XLam a (BName (NameVar "argc") tInt) - $ XLam a (BName (NameVar "argv") (tPtr rTop tString)) - $ XLet a (LLet (BNone tVoid) (xCreate a (configHeapSize config))) - $ XLet a (LLet (BNone (tPtr rTop tObj)) + = XLam a (BName (NameVar "argc") tInt) + $ XLam a (BName (NameVar "argv") (tPtr rTop (tWord 8))) + $ XLet a (LLet (BNone tVoid) (xCreate a (xNat a (configHeapSize config)))) + $ XLet a (LLet (BNone (tBot kData)) (xApps a (XVar a (UName (NameVar "_main"))) - [xAllocBoxed a rTop 0 (xNat a 0)])) + [xU])) (xInt a 0) + where xU = xAllocBoxed a rTop 0 (xNat a 0) diff --git a/DDC/Core/Salt/Convert/Name.hs b/DDC/Core/Salt/Convert/Name.hs --- a/DDC/Core/Salt/Convert/Name.hs +++ b/DDC/Core/Salt/Convert/Name.hs @@ -21,31 +21,34 @@ -- | Convert the Salt name of a supercombinator to a name we can use when -- defining the C function. seaNameOfSuper - :: Maybe (ImportSource Name) -- ^ How the super is imported + :: Maybe (ImportValue Name) -- ^ How the super is imported -> Maybe (ExportSource Name) -- ^ How the super is exported -> Name -- ^ Name of the super. -> Maybe Doc -seaNameOfSuper mImport mExport (NameVar str) +seaNameOfSuper mImport mExport nm -- Super is defined in this module and not exported. - | Nothing <- mImport - , Nothing <- mExport - = Just $ text $ "_DDC_" ++ sanitizeName str + | Nothing <- mImport + , Nothing <- mExport + , Just str <- takeNameVar nm + = Just $ text $ sanitizeName str -- Super is defined in this module and exported to C land. - | Nothing <- mImport - , Just _ <- mExport + | Nothing <- mImport + , Just _ <- mExport + , Just str <- takeNameVar nm = Just $ text $ sanitizeName str -- Super is imported from another module and not exported. - | Just (ImportSourceModule _ _ _) <- mImport - , Nothing <- mExport - = Just $ text $ "_DDC_" ++ sanitizeName str + | Just ImportValueModule{} <- mImport + , Nothing <- mExport + , Just str <- takeNameVar nm + = Just $ text $ sanitizeName str -- Super is imported from C-land and not exported. - | Just (ImportSourceSea strSea _) <- mImport - , Nothing <- mExport + | Just (ImportValueSea strSea _) <- mImport + , Nothing <- mExport = Just $ text strSea -- ISSUE #320: Handle all the import/export combinations. @@ -54,18 +57,14 @@ -- produce a wrapper to conver the names. | otherwise = Nothing - -seaNameOfSuper _ _ _ - = Nothing - -- | Convert the Salt name of a local variable to a name we can use in the -- body of a C function. seaNameOfLocal :: Name -> Maybe Doc seaNameOfLocal nn - = case nn of - NameVar str -> Just $ text $ "_" ++ sanitizeGlobal str + = case takeNameVar nn of + Just str -> Just $ text $ "_" ++ sanitizeGlobal str _ -> Nothing diff --git a/DDC/Core/Salt/Convert/Prim.hs b/DDC/Core/Salt/Convert/Prim.hs --- a/DDC/Core/Salt/Convert/Prim.hs +++ b/DDC/Core/Salt/Convert/Prim.hs @@ -21,7 +21,6 @@ PrimTyConFloat bits -> Just $ text "float" <> int bits <> text "_t" PrimTyConAddr -> Just $ text "addr_t" PrimTyConTag -> Just $ text "tag_t" - PrimTyConString -> Just $ text "string_t" _ -> Nothing @@ -74,10 +73,11 @@ PrimStoreMinusAddr -> text "_MINUSADDr" PrimStorePeek -> text "_PEEK" PrimStorePoke -> text "_POKE" + PrimStorePeekBounded -> text "_PEEKBOUNDED" + PrimStorePokeBounded -> text "_POKEBOUNDED" PrimStorePlusPtr -> text "_PLUSPTR" PrimStoreMinusPtr -> text "_MINUSPTR" PrimStoreMakePtr -> text "_MAKEPTR" PrimStoreTakePtr -> text "_TAKEPTR" PrimStoreCastPtr -> text "_CASTPTR" - diff --git a/DDC/Core/Salt/Convert/Super.hs b/DDC/Core/Salt/Convert/Super.hs --- a/DDC/Core/Salt/Convert/Super.hs +++ b/DDC/Core/Salt/Convert/Super.hs @@ -8,10 +8,8 @@ import DDC.Core.Salt.Name import DDC.Core.Salt.Platform import DDC.Core.Collect -import DDC.Core.Predicates -import DDC.Core.Compounds import DDC.Core.Module -import DDC.Core.Exp +import DDC.Core.Exp.Annot import DDC.Type.Env (KindEnv, TypeEnv) import DDC.Base.Pretty import DDC.Control.Monad.Check (throw) diff --git a/DDC/Core/Salt/Convert/Type.hs b/DDC/Core/Salt/Convert/Type.hs --- a/DDC/Core/Salt/Convert/Type.hs +++ b/DDC/Core/Salt/Convert/Type.hs @@ -7,10 +7,8 @@ import DDC.Core.Salt.Convert.Base import DDC.Core.Salt.Convert.Name import DDC.Core.Salt.Name -import DDC.Core.Predicates -import DDC.Core.Compounds import DDC.Core.Module as C -import DDC.Core.Exp +import DDC.Core.Exp.Annot import DDC.Type.Env (KindEnv) import DDC.Base.Pretty import DDC.Control.Monad.Check (throw) @@ -36,6 +34,10 @@ -> throw $ ErrorTypeInvalid tt TCon{} + | TCon (TyConSpec TcConUnit) <- tt + -> return $ text "Obj*" + + | TCon (TyConBound (UPrim (NamePrimTyCon tc) _) _) <- tt , Just doc <- convPrimTyCon tc -> return doc @@ -58,7 +60,7 @@ -- | Convert a Salt function type to a C source prototype. convSuperTypeM :: KindEnv Name - -> Maybe (ImportSource Name) + -> Maybe (ImportValue Name) -> Maybe (ExportSource Name) -> Name -- ^ Local name of super. -> Type Name -- ^ Function type. diff --git a/DDC/Core/Salt/Env.hs b/DDC/Core/Salt/Env.hs --- a/DDC/Core/Salt/Env.hs +++ b/DDC/Core/Salt/Env.hs @@ -4,13 +4,19 @@ ( primDataDefs , primKindEnv , primTypeEnv + , typeOfPrimOp , typeOfPrimArith , typeOfPrimCast , typeOfPrimCall , typeOfPrimControl , typeOfPrimStore + , typeOfPrimLit , typeIsUnboxed) where +import DDC.Core.Salt.Compounds.PrimArith +import DDC.Core.Salt.Compounds.PrimCast +import DDC.Core.Salt.Compounds.PrimControl +import DDC.Core.Salt.Compounds.PrimStore import DDC.Core.Salt.Compounds import DDC.Core.Salt.Name import DDC.Type.DataDef @@ -29,37 +35,47 @@ -- > Bool# True# False# -- > Nat# 0# 1# 2# ... -- > Int# ... -2i# -1i# 0i# 1i# 2i# ... --- > Tag# (none, convert from Nat#) +-- > Size# 0s# 1s# 2s# ... -- > Word{8,16,32,64}# 42w8# 123w64# ... -- > Float{32,64}# (none, convert from Int#) --- +-- > Tag# (none, convert from Nat#) +-- primDataDefs :: DataDefs Name primDataDefs = fromListDataDefs - -- Bool + -- Bool# [ makeDataDefAlg (NamePrimTyCon PrimTyConBool) [] - (Just [ (NameLitBool True, []) - , (NameLitBool False, []) ]) - -- Nat - , makeDataDefAlg (NamePrimTyCon PrimTyConNat) [] Nothing + (Just [ (NamePrimLit (PrimLitBool True), []) + , (NamePrimLit (PrimLitBool False), []) ]) + -- Nat# + , makeDataDefAlg (NamePrimTyCon PrimTyConNat) [] Nothing - -- Int - , makeDataDefAlg (NamePrimTyCon PrimTyConInt) [] Nothing + -- Int# + , makeDataDefAlg (NamePrimTyCon PrimTyConInt) [] Nothing - -- Tag - , makeDataDefAlg (NamePrimTyCon PrimTyConTag) [] Nothing + -- Size# + , makeDataDefAlg (NamePrimTyCon PrimTyConSize) [] Nothing - -- Word 8, 16, 32, 64 + -- Word# 8, 16, 32, 64 , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 8)) [] Nothing , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 16)) [] Nothing , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 32)) [] Nothing , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 64)) [] Nothing - -- Float 32, 64 - , makeDataDefAbs (NamePrimTyCon (PrimTyConFloat 32)) [] - , makeDataDefAbs (NamePrimTyCon (PrimTyConFloat 64)) [] + -- Float# 32, 64 + , makeDataDefAlg (NamePrimTyCon (PrimTyConFloat 32)) [] Nothing + , makeDataDefAlg (NamePrimTyCon (PrimTyConFloat 64)) [] Nothing + + -- Tag# + , makeDataDefAlg (NamePrimTyCon PrimTyConTag) [] Nothing + + -- TextLit# + , makeDataDefAlg (NamePrimTyCon PrimTyConTextLit) [] Nothing + + -- Ptr# + , makeDataDefAlg (NamePrimTyCon PrimTyConPtr) [] Nothing ] @@ -76,6 +92,7 @@ = case nn of NameObjTyCon -> Just $ kData NamePrimTyCon tc -> Just $ kindOfPrimTyCon tc + NameVar "rT" -> Just $ kRegion _ -> Nothing @@ -90,13 +107,14 @@ PrimTyConBool -> kData PrimTyConNat -> kData PrimTyConInt -> kData + PrimTyConSize -> kData PrimTyConWord _ -> kData PrimTyConFloat _ -> kData PrimTyConAddr -> kData PrimTyConPtr -> kRegion `kFun` kData `kFun` kData PrimTyConTag -> kData - PrimTyConString -> kData PrimTyConVec _ -> kData `kFun` kData + PrimTyConTextLit -> kData -- Types ---------------------------------------------------------------------- @@ -110,19 +128,14 @@ typeOfName :: Name -> Maybe (Type Name) typeOfName nn = case nn of - NamePrimOp p -> Just $ typeOfPrim p - NameLitVoid -> Just $ tVoid - NameLitBool _ -> Just $ tBool - NameLitNat _ -> Just $ tNat - NameLitInt _ -> Just $ tInt - NameLitWord _ bits -> Just $ tWord bits - NameLitTag _ -> Just $ tTag - _ -> Nothing + NamePrimOp p -> Just $ typeOfPrimOp p + NamePrimLit lit -> Just $ typeOfPrimLit lit + _ -> Nothing --- | Take the type of a primitive. -typeOfPrim :: PrimOp -> Type Name -typeOfPrim pp +-- | Take the type of a primitive operator. +typeOfPrimOp :: PrimOp -> Type Name +typeOfPrimOp pp = case pp of PrimArith op -> typeOfPrimArith op PrimCast cc -> typeOfPrimCast cc @@ -131,53 +144,19 @@ PrimStore ps -> typeOfPrimStore ps --- PrimOps -------------------------------------------------------------------- --- | Take the type of a primitive operator. -typeOfPrimArith :: PrimArith -> Type Name -typeOfPrimArith op - = case op of - -- Numeric - PrimArithNeg -> tForall kData $ \t -> t `tFunPE` t - PrimArithAdd -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithSub -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithMul -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithDiv -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithMod -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithRem -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - - -- Comparison - PrimArithEq -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool - PrimArithNeq -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool - PrimArithGt -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool - PrimArithLt -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool - PrimArithLe -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool - PrimArithGe -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool - - -- Boolean - PrimArithAnd -> tBool `tFunPE` tBool `tFunPE` tBool - PrimArithOr -> tBool `tFunPE` tBool `tFunPE` tBool - - -- Bitwise - PrimArithShl -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithShr -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithBAnd -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithBOr -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - PrimArithBXOr -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t - - --- PrimCast ------------------------------------------------------------------- --- | Take the type of a primitive cast. -typeOfPrimCast :: PrimCast -> Type Name -typeOfPrimCast cc - = case cc of - PrimCastConvert - -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFunPE` t1 - - PrimCastPromote - -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFunPE` t1 - - PrimCastTruncate - -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFunPE` t1 +-- | Take the type of a primitive literal. +typeOfPrimLit :: PrimLit -> Type Name +typeOfPrimLit lit + = case lit of + PrimLitVoid -> tVoid + PrimLitBool _ -> tBool + PrimLitNat _ -> tNat + PrimLitInt _ -> tInt + PrimLitSize _ -> tSize + PrimLitWord _ bits -> tWord bits + PrimLitFloat _ bits -> tFloat bits + PrimLitTextLit _ -> tTextLit + PrimLitTag _ -> tTag -- PrimCall ------------------------------------------------------------------- @@ -185,85 +164,31 @@ typeOfPrimCall :: PrimCall -> Type Name typeOfPrimCall cc = case cc of - PrimCallTail arity -> makePrimCallType arity + PrimCallStd arity + -> makePrimCallStdType arity + PrimCallTail arity + -> makePrimCallTailType arity + -- | Make the type of the @callN#@ and @tailcallN@ primitives. -makePrimCallType :: Int -> Type Name -makePrimCallType arity - = let tSuper = foldr tFunPE +makePrimCallStdType :: Int -> Type Name +makePrimCallStdType arity + = let Just t = tFunOfList ([tAddr] ++ replicate arity tAddr ++ [tAddr]) + in t + + +-- | Make the type of the @callN#@ and @tailcallN@ primitives. +makePrimCallTailType :: Int -> Type Name +makePrimCallTailType arity + = let tSuper = foldr tFun (TVar (UIx 0)) (reverse [TVar (UIx i) | i <- [1..arity]]) - tCall = foldr TForall (tSuper `tFunPE` tSuper) + tCall = foldr TForall (tSuper `tFun` tSuper) [BAnon k | k <- replicate (arity + 1) kData] in tCall - - --- PrimControl ---------------------------------------------------------------- -typeOfPrimControl :: PrimControl -> Type Name -typeOfPrimControl pc - = case pc of - PrimControlFail -> tForall kData $ \t -> t - PrimControlReturn -> tForall kData $ \t -> t `tFunPE` t - - --- PrimStore ------------------------------------------------------------------ --- | Take the type of a primitive projection. -typeOfPrimStore :: PrimStore -> Type Name -typeOfPrimStore jj - = case jj of - PrimStoreSize - -> tForall kData $ \_ -> tNat - - PrimStoreSize2 - -> tForall kData $ \_ -> tNat - - PrimStoreCreate - -> tNat `tFunPE` tVoid - - PrimStoreCheck - -> tNat `tFunPE` tBool - - PrimStoreRecover - -> tNat `tFunPE` tVoid - - PrimStoreAlloc - -> tNat `tFunPE` tAddr - - PrimStoreRead - -> tForall kData $ \t -> tAddr `tFunPE` tNat `tFunPE` t - - PrimStoreWrite - -> tForall kData $ \t -> tAddr `tFunPE` tNat `tFunPE` t `tFunPE` tVoid - - PrimStorePlusAddr - -> tAddr `tFunPE` tNat `tFunPE` tAddr - - PrimStoreMinusAddr - -> tAddr `tFunPE` tNat `tFunPE` tAddr - - PrimStorePeek - -> tForalls [kRegion, kData] $ \[r,t] -> tPtr r t `tFunPE` tNat `tFunPE` t - - PrimStorePoke - -> tForalls [kRegion, kData] $ \[r,t] -> tPtr r t `tFunPE` tNat `tFunPE` t `tFunPE` tVoid - - PrimStorePlusPtr - -> tForalls [kRegion, kData] $ \[r,t] -> tPtr r t `tFunPE` tNat `tFunPE` tPtr r t - - PrimStoreMinusPtr - -> tForalls [kRegion, kData] $ \[r,t] -> tPtr r t `tFunPE` tNat `tFunPE` tPtr r t - - PrimStoreMakePtr - -> tForalls [kRegion, kData] $ \[r,t] -> tAddr `tFunPE` tPtr r t - - PrimStoreTakePtr - -> tForalls [kRegion, kData] $ \[r,t] -> tPtr r t `tFunPE` tAddr - - PrimStoreCastPtr - -> tForalls [kRegion, kData, kData] $ \[r,t1,t2] -> tPtr r t2 `tFunPE` tPtr r t1 ------------------------------------------------------------------------------- diff --git a/DDC/Core/Salt/Exp.hs b/DDC/Core/Salt/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Exp.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE TypeFamilies #-} + +module DDC.Core.Salt.Exp + ( module DDC.Core.Exp.Generic.Exp + , FromAnnot (..) + , ErrorFromAnnot (..) + + , Annot, Bind, Bound, Prim + , Exp, Abs, Arg, Lets, Alt, Pat, Cast, Witness, WiCon + , Type) +where +import DDC.Core.Exp.Generic.Exp +import qualified DDC.Core.Exp.Generic.Exp as G +import qualified DDC.Core.Salt.Name as A +import qualified DDC.Core.Exp.Annot.Exp as N +import qualified DDC.Type.Exp as C + + +--------------------------------------------------------------------------------------------------- +-- Type synonyms for the Salt fragment. +type instance GAnnot A.Name = () +type instance GBind A.Name = C.Bind A.Name +type instance GBound A.Name = C.Bound A.Name +type instance GPrim A.Name = A.PrimOp + +type Annot = GAnnot A.Name +type Bind = GBind A.Name +type Bound = GBound A.Name +type Prim = GPrim A.Name +type Exp = GExp A.Name +type Abs = GAbs A.Name +type Arg = GArg A.Name +type Lets = GLets A.Name +type Alt = GAlt A.Name +type Pat = GPat A.Name +type Cast = GCast A.Name +type Witness = GWitness A.Name +type WiCon = GWiCon A.Name + +type Type = C.Type A.Name + + +--------------------------------------------------------------------------------------------------- +-- | Convert annotated version of the Core language to the Salt fragment. +class FromAnnot c1 c2 | c1 -> c2 where + fromAnnot :: c1 -> Either ErrorFromAnnot c2 + + +-- | Things that can go wrong when converting Salt code. +data ErrorFromAnnot + -- | Found a type that isn't part of a function application. + = ErrorFromAnnotFoundNakedType + + -- | Found a witness that isn't part of a function application. + | ErrorFromAnnotFoundNakedWitness + + +instance FromAnnot (N.Exp a A.Name) Exp where + fromAnnot xx + = case xx of + N.XVar _ (C.UPrim (A.NamePrimVal (A.PrimValOp op)) _) + -> G.XPrim <$> pure op + + N.XVar _ u + -> G.XVar <$> fromAnnot u + + N.XCon _ c + -> G.XCon <$> fromAnnot c + + N.XLAM _ b x + -> G.XAbs <$> (G.ALAM <$> fromAnnot b) <*> fromAnnot x + + N.XLam _ b x + -> G.XAbs <$> (G.ALam <$> fromAnnot b) <*> fromAnnot x + + N.XApp _ x1 (N.XType _ t) + -> G.XApp <$> fromAnnot x1 <*> (G.RType <$> fromAnnot t) + + N.XApp _ x1 (N.XWitness _ w) + -> G.XApp <$> fromAnnot x1 <*> (G.RWitness <$> fromAnnot w) + + N.XApp _ x1 x2 + -> G.XApp <$> fromAnnot x1 <*> (G.RExp <$> fromAnnot x2) + + N.XLet _ lts x + -> G.XLet <$> fromAnnot lts <*> fromAnnot x + + N.XCase _ x alts + -> G.XCase <$> fromAnnot x <*> fromAnnots alts + + N.XCast _ c x + -> G.XCast <$> fromAnnot c <*> fromAnnot x + + N.XType{} + -> Left $ ErrorFromAnnotFoundNakedType + + N.XWitness{} + -> Left $ ErrorFromAnnotFoundNakedWitness + + +instance FromAnnot (N.Lets a A.Name) Lets where + fromAnnot lts + = case lts of + N.LLet u x + -> G.LLet <$> fromAnnot u <*> fromAnnot x + + N.LRec bxs + -> G.LRec <$> (sequence $ fmap fromAnnot2 bxs) + + N.LPrivate rs mt wt + -> G.LPrivate <$> fromAnnots rs <*> fromAnnotM mt <*> fromAnnots wt + + +instance FromAnnot (N.Alt a A.Name) Alt where + fromAnnot aa + = case aa of + N.AAlt w x -> G.AAlt <$> fromAnnot w <*> fromAnnot x + + +instance FromAnnot (N.Pat A.Name) Pat where + fromAnnot pp + = case pp of + N.PDefault -> pure G.PDefault + N.PData dc bs -> G.PData <$> pure dc <*> fromAnnots bs + + +instance FromAnnot (N.Cast a A.Name) Cast where + fromAnnot cc + = case cc of + N.CastWeakenEffect t -> G.CastWeakenEffect <$> pure t + N.CastPurify w -> G.CastPurify <$> fromAnnot w + N.CastBox -> pure G.CastBox + N.CastRun -> pure G.CastRun + + +instance FromAnnot (N.Witness a A.Name) Witness where + fromAnnot ww + = case ww of + N.WVar _ u -> G.WVar <$> pure u + N.WCon _ wc -> G.WCon <$> fromAnnot wc + N.WApp _ w1 w2 -> G.WApp <$> fromAnnot w1 <*> fromAnnot w2 + N.WType _ t -> G.WType <$> pure t + + +instance FromAnnot (N.DaCon A.Name) (N.DaCon A.Name) where + fromAnnot dc = pure dc + + +instance FromAnnot (N.WiCon A.Name) WiCon where + fromAnnot ww + = case ww of + N.WiConBound u t -> G.WiConBound <$> pure u <*> pure t + + +instance FromAnnot (C.Type A.Name) (C.Type A.Name) where + fromAnnot tt = pure tt + + +instance FromAnnot (N.Bind A.Name) (C.Bind A.Name) where + fromAnnot bb = pure bb + + +instance FromAnnot (N.Bound A.Name) (C.Bound A.Name) where + fromAnnot uu = pure uu + + +fromAnnot2 (x, y) + = (,) <$> fromAnnot x <*> fromAnnot y + +fromAnnots xs + = sequence $ fmap fromAnnot xs + +fromAnnotM Nothing = pure Nothing +fromAnnotM (Just x) = Just <$> fromAnnot x + diff --git a/DDC/Core/Salt/Name.hs b/DDC/Core/Salt/Name.hs --- a/DDC/Core/Salt/Name.hs +++ b/DDC/Core/Salt/Name.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} -- | Names used in the Disciple Core Salt language profile. module DDC.Core.Salt.Name @@ -5,17 +6,26 @@ -- * Primitive Type Constructors , PrimTyCon (..) - , readPrimTyCon + , pprPrimTyConStem + , readPrimTyCon, readPrimTyConStem , primTyConIsIntegral , primTyConIsFloating , primTyConIsUnsigned , primTyConIsSigned , primTyConWidth + -- * Primitive Values + , PrimVal (..) + , readPrimVal + + , pattern NamePrimOp + , pattern NamePrimLit + -- * Primitive Operators , PrimOp (..) + , readPrimOp - -- * Primative Arithmetic + -- * Primitive Arithmetic , PrimArith (..) , readPrimArith @@ -43,16 +53,31 @@ , multiOfPrimVec , liftPrimArithToVec , lowerPrimVecToArith - + -- * Primitive Literals + , PrimLit (..) + , readPrimLit , readLitInteger - , readLitPrimNat - , readLitPrimInt - , readLitPrimWordOfBits - , readLitPrimFloatOfBits + , readLitNat + , readLitInt + , readLitSize + , readLitWordOfBits + , readLitFloatOfBits + , pattern NameLitVoid + , pattern NameLitBool + , pattern NameLitNat + , pattern NameLitInt + , pattern NameLitSize + , pattern NameLitWord + , pattern NameLitFloat + , pattern NameLitTextLit + , pattern NameLitTag + -- * Name Parsing - , readName) + , readName + + , takeNameVar ) where import DDC.Core.Salt.Name.PrimArith import DDC.Core.Salt.Name.PrimCall @@ -62,63 +87,48 @@ import DDC.Core.Salt.Name.PrimTyCon import DDC.Core.Salt.Name.PrimVec import DDC.Core.Salt.Name.Lit +import DDC.Core.Lexer.Names (isVarStart) +import DDC.Data.ListUtils import DDC.Base.Pretty +import DDC.Base.Name import Data.Typeable import Data.Char import Data.List import Control.DeepSeq +import Data.Text (Text) +import qualified Data.Text as T + -- | Names of things used in Disciple Core Salt. data Name -- | A type or value variable. - = NameVar String + = NameVar !String -- | Constructor names. - | NameCon String + | NameCon !String + -- | An extended name. + | NameExt !Name !String + -- | The abstract heap object type constructor. | NameObjTyCon -- | A primitive type constructor. - | NamePrimTyCon PrimTyCon - - -- | A primitive operator. - | NamePrimOp PrimOp - - -- | The void literal. - | NameLitVoid - - -- | A boolean literal. - | NameLitBool Bool - - -- | A natural number literal. - | NameLitNat Integer - - -- | An integer number literal. - | NameLitInt Integer - - -- | A constructor tag literal. - | NameLitTag Integer + | NamePrimTyCon !PrimTyCon - -- | A @WordN#@ literal, of the given width. - | NameLitWord Integer Int + -- | A primitive value. + | NamePrimVal !PrimVal deriving (Eq, Ord, Show, Typeable) - instance NFData Name where rnf name = case name of NameVar s -> rnf s + NameExt n s -> rnf n `seq` rnf s NameCon s -> rnf s NameObjTyCon -> () NamePrimTyCon con -> rnf con - NamePrimOp op -> rnf op - NameLitVoid -> () - NameLitBool b -> rnf b - NameLitNat i -> rnf i - NameLitInt i -> rnf i - NameLitTag i -> rnf i - NameLitWord i bits -> rnf i `seq` rnf bits + NamePrimVal val -> rnf val instance Pretty Name where @@ -126,18 +136,22 @@ = case nn of NameVar n -> text n NameCon n -> text n + NameExt n ext -> ppr n <> text "$" <> text ext NameObjTyCon -> text "Obj" NamePrimTyCon tc -> ppr tc - NamePrimOp p -> ppr p - NameLitVoid -> text "V#" - NameLitBool True -> text "True#" - NameLitBool False -> text "False#" - NameLitNat i -> integer i <> text "#" - NameLitInt i -> integer i <> text "i#" - NameLitTag i -> text "TAG" <> integer i <> text "#" - NameLitWord i bits -> integer i <> text "w" <> int bits <> text "#" + NamePrimVal val -> ppr val +instance CompoundName Name where + extendName n str + = NameExt n str + + splitName nn + = case nn of + NameExt n str -> Just (n, str) + _ -> Nothing + + -- | Read the name of a variable, constructor or literal. readName :: String -> Maybe Name readName str @@ -149,83 +163,93 @@ | Just p <- readPrimTyCon str = Just $ NamePrimTyCon p - -- PrimArith - | Just p <- readPrimArith str - = Just $ NamePrimOp $ PrimArith p + -- PrimVal + | Just p <- readPrimVal str + = Just $ NamePrimVal p - -- PrimCast - | Just p <- readPrimCast str - = Just $ NamePrimOp $ PrimCast p + -- Constructors. + | c : _ <- str + , isUpper c + = Just $ NameVar str - -- PrimCall - | Just p <- readPrimCall str - = Just $ NamePrimOp $ PrimCall p + -- Variables. + | c : _ <- str + , isVarStart c || c == '_' + = Just $ NameVar str - -- PrimControl - | Just p <- readPrimControl str - = Just $ NamePrimOp $ PrimControl p + | otherwise + = Nothing - -- PrimStore - | Just p <- readPrimStore str - = Just $ NamePrimOp $ PrimStore p - -- Literal void - | str == "V#" - = Just $ NameLitVoid +-- | Take the string of a non-primitive name. Supports extended names. +takeNameVar :: Name -> Maybe String - -- Literal Nats - | Just val <- readLitPrimNat str - = Just $ NameLitNat val +takeNameVar (NameVar n) + = Just n - -- Literal Ints - | Just val <- readLitPrimInt str - = Just $ NameLitInt val +takeNameVar (NameExt n str) + | Just n' <- takeNameVar n + = Just (n' ++ "$" ++ str) - -- Literal Tags - | Just rest <- stripPrefix "TAG" str - , (ds, "#") <- span isDigit rest - = Just $ NameLitTag (read ds) +takeNameVar _ + = Nothing - -- Literal Bools - | str == "True#" = Just $ NameLitBool True - | str == "False#" = Just $ NameLitBool False - -- Literal Words - | Just (val, bits) <- readLitPrimWordOfBits str - , elem bits [8, 16, 32, 64] - = Just $ NameLitWord val bits +-- PrimVal -------------------------------------------------------------------- +-- | Primitive values, meaning both operators and literals. +data PrimVal + = PrimValOp !PrimOp + | PrimValLit !PrimLit + deriving (Eq, Ord, Show) - -- Constructors. - | c : _ <- str - , isUpper c - = Just $ NameVar str +pattern NamePrimOp op = NamePrimVal (PrimValOp op) +pattern NamePrimLit lit = NamePrimVal (PrimValLit lit) - -- Variables. - | c : _ <- str - , isLower c - = Just $ NameVar str +instance NFData PrimVal where + rnf p + = case p of + PrimValOp op -> rnf op + PrimValLit lit -> rnf lit + + +instance Pretty PrimVal where + ppr p + = case p of + PrimValOp op -> ppr op + PrimValLit lit -> ppr lit + + +-- | Read a primitive value. +readPrimVal :: String -> Maybe PrimVal +readPrimVal str + | Just op <- readPrimOp str + = Just $ PrimValOp op + + | Just lit <- readPrimLit str + = Just $ PrimValLit lit + | otherwise = Nothing -- PrimOp --------------------------------------------------------------------- -- | Primitive operators implemented directly by the machine or runtime system. -data PrimOp +data PrimOp -- | Arithmetic, logic, comparison and bit-wise operators. - = PrimArith PrimArith + = PrimArith !PrimArith -- | Casting between numeric types. - | PrimCast PrimCast + | PrimCast !PrimCast -- | Raw store access. - | PrimStore PrimStore + | PrimStore !PrimStore -- | Special function calling conventions. - | PrimCall PrimCall + | PrimCall !PrimCall -- | Non-functional control flow. - | PrimControl PrimControl + | PrimControl !PrimControl deriving (Eq, Ord, Show) @@ -247,4 +271,151 @@ PrimStore p -> ppr p PrimCall c -> ppr c PrimControl c -> ppr c + + +-- | Read a primitive operator. +readPrimOp :: String -> Maybe PrimOp +readPrimOp str + -- PrimArith + | Just p <- readPrimArith str + = Just $ PrimArith p + + -- PrimCast + | Just p <- readPrimCast str + = Just $ PrimCast p + + -- PrimCall + | Just p <- readPrimCall str + = Just $ PrimCall p + + -- PrimControl + | Just p <- readPrimControl str + = Just $ PrimControl p + + -- PrimStore + | Just p <- readPrimStore str + = Just $ PrimStore p + + | otherwise + = Nothing + + +-- PrimLit -------------------------------------------------------------------- +-- | Primitive literals. +data PrimLit + -- | The void literal. + = PrimLitVoid + + -- | A boolean literal. + | PrimLitBool !Bool + + -- | A natural number literal. + | PrimLitNat !Integer + + -- | An integer number literal. + | PrimLitInt !Integer + + -- | A size literal. + | PrimLitSize !Integer + + -- | A word literal, of the given width. + | PrimLitWord !Integer !Int + + -- | A floating point literal, of the given width. + | PrimLitFloat !Double !Int + + -- | A text literal. + | PrimLitTextLit !Text + + -- | A constructor tag literal. + | PrimLitTag !Integer + deriving (Eq, Ord, Show) + + +pattern NameLitVoid = NamePrimVal (PrimValLit PrimLitVoid) +pattern NameLitBool x = NamePrimVal (PrimValLit (PrimLitBool x)) +pattern NameLitNat x = NamePrimVal (PrimValLit (PrimLitNat x)) +pattern NameLitInt x = NamePrimVal (PrimValLit (PrimLitInt x)) +pattern NameLitSize x = NamePrimVal (PrimValLit (PrimLitSize x)) +pattern NameLitWord x s = NamePrimVal (PrimValLit (PrimLitWord x s)) +pattern NameLitFloat x s = NamePrimVal (PrimValLit (PrimLitFloat x s)) +pattern NameLitTextLit x = NamePrimVal (PrimValLit (PrimLitTextLit x)) +pattern NameLitTag x = NamePrimVal (PrimValLit (PrimLitTag x)) + + + +instance NFData PrimLit where + rnf p + = case p of + PrimLitVoid -> () + PrimLitBool b -> rnf b + PrimLitNat i -> rnf i + PrimLitInt i -> rnf i + PrimLitSize i -> rnf i + PrimLitWord i bits -> rnf i `seq` rnf bits + PrimLitFloat f bits -> rnf f `seq` rnf bits + PrimLitTextLit bs -> rnf bs + PrimLitTag i -> rnf i + + +instance Pretty PrimLit where + ppr p + = case p of + PrimLitVoid -> text "V#" + PrimLitBool True -> text "True#" + PrimLitBool False -> text "False#" + PrimLitNat i -> integer i <> text "#" + PrimLitInt i -> integer i <> text "i#" + PrimLitSize i -> integer i <> text "s#" + PrimLitWord i bits -> integer i <> text "w" <> int bits <> text "#" + PrimLitFloat f bits -> double f <> text "f" <> int bits <> text "#" + PrimLitTextLit tx -> (text $ show $ T.unpack tx) <> text "#" + PrimLitTag i -> text "TAG" <> integer i <> text "#" + + +-- | Read a primitive literal. +readPrimLit :: String -> Maybe PrimLit +readPrimLit str + -- Literal void + | str == "V#" + = Just $ PrimLitVoid + + -- Literal Bools + | str == "True#" = Just $ PrimLitBool True + | str == "False#" = Just $ PrimLitBool False + + -- Literal Nats + | Just str' <- stripSuffix "#" str + , Just val <- readLitNat str' + = Just $ PrimLitNat val + + -- Literal Ints + | Just str' <- stripSuffix "#" str + , Just val <- readLitInt str' + = Just $ PrimLitInt val + + -- Literal Sizes + | Just str' <- stripSuffix "s#" str + , Just val <- readLitSize str' + = Just $ PrimLitSize val + + -- Literal Words + | Just str' <- stripSuffix "#" str + , Just (val, bits) <- readLitWordOfBits str' + , elem bits [8, 16, 32, 64] + = Just $ PrimLitWord val bits + + -- Literal Floats + | Just str' <- stripSuffix "#" str + , Just (val, bits) <- readLitFloatOfBits str' + , elem bits [32, 64] + = Just $ PrimLitFloat val bits + + -- Literal Tags + | Just rest <- stripPrefix "TAG" str + , (ds, "#") <- span isDigit rest + = Just $ PrimLitTag (read ds) + + | otherwise + = Nothing diff --git a/DDC/Core/Salt/Name/Lit.hs b/DDC/Core/Salt/Name/Lit.hs --- a/DDC/Core/Salt/Name/Lit.hs +++ b/DDC/Core/Salt/Name/Lit.hs @@ -2,10 +2,11 @@ -- | Reading literal values. module DDC.Core.Salt.Name.Lit ( readLitInteger - , readLitPrimNat - , readLitPrimInt - , readLitPrimWordOfBits - , readLitPrimFloatOfBits) + , readLitNat + , readLitInt + , readLitSize + , readLitWordOfBits + , readLitFloatOfBits) where import Data.List @@ -16,39 +17,54 @@ readLitInteger :: String -> Maybe Integer readLitInteger [] = Nothing readLitInteger str@(c:cs) - | '-' <- c + | '-' <- c , all isDigit cs = Just $ read str - | all isDigit str + | all isDigit cs = Just $ read str | otherwise = Nothing --- | Read an integer with an explicit format specifier like @1234i#@. -readLitPrimNat :: String -> Maybe Integer -readLitPrimNat str1 - | (ds, str2) <- span isDigit str1 - , not $ null ds - , Just "" <- stripPrefix "#" str2 +-- | Read an integer with an explicit format specifier like @1234i@. +readLitNat :: String -> Maybe Integer +readLitNat str1 + | (ds, "") <- span isDigit str1 + , not $ null ds = Just $ read ds | otherwise = Nothing --- | Read an integer literal with an explicit format specifier like @1234i#@. -readLitPrimInt :: String -> Maybe Integer -readLitPrimInt str1 +-- | Read an integer literal with an explicit format specifier like @1234i@. +readLitInt :: String -> Maybe Integer +readLitInt str1 | '-' : str2 <- str1 - , (ds, "i#") <- span isDigit str2 - , not $ null ds + , (ds, "i") <- span isDigit str2 + , not $ null ds + = Just $ negate $ read ds + + | (ds, "i") <- span isDigit str1 + , not $ null ds = Just $ read ds - | (ds, "i#") <- span isDigit str1 - , not $ null ds + | otherwise + = Nothing + + +-- | Read an size literal with an explicit format specifier like @1234s@. +readLitSize :: String -> Maybe Integer +readLitSize str1 + | '-' : str2 <- str1 + , (ds, "s") <- span isDigit str2 + , not $ null ds + = Just $ negate $ read ds + + | (ds, "s") <- span isDigit str1 + , not $ null ds = Just $ read ds | otherwise @@ -56,24 +72,37 @@ -- | Read a word with an explicit format speficier. -readLitPrimWordOfBits :: String -> Maybe (Integer, Int) -readLitPrimWordOfBits str1 - -- binary like 0b01001w32# +readLitWordOfBits :: String -> Maybe (Integer, Int) +readLitWordOfBits str1 + -- binary like 0b01001w32 | Just str2 <- stripPrefix "0b" str1 , (ds, str3) <- span (\c -> c == '0' || c == '1') str2 , not $ null ds , Just str4 <- stripPrefix "w" str3 - , (bs, "#") <- span isDigit str4 + , (bs, "") <- span isDigit str4 , not $ null bs , bits <- read bs , length ds <= bits = Just (readBinary ds, bits) - -- decimal like 1234w32# + -- hex like 0x0ffw32 + | Just str2 <- stripPrefix "0x" str1 + , (ds, str3) <- span (\c -> elem c ['0' .. '9'] + || elem c ['A' .. 'F'] + || elem c ['a' .. 'f']) str2 + , not $ null ds + , Just str4 <- stripPrefix "w" str3 + , (bs, "") <- span isDigit str4 + , not $ null bs + , bits <- read bs + , length ds <= bits + = Just (readHex ds, bits) + + -- decimal like 1234w32 | (ds, str2) <- span isDigit str1 , not $ null ds , Just str3 <- stripPrefix "w" str2 - , (bs, "#") <- span isDigit str3 + , (bs, "") <- span isDigit str3 , not $ null bs = Just (read ds, read bs) @@ -82,10 +111,10 @@ -- | Read a float literal with an explicit format specifier like @123.00f32#@. -readLitPrimFloatOfBits :: String -> Maybe (Double, Int) -readLitPrimFloatOfBits str1 +readLitFloatOfBits :: String -> Maybe (Double, Int) +readLitFloatOfBits str1 | '-' : str2 <- str1 - , Just (d, bs) <- readLitPrimFloatOfBits str2 + , Just (d, bs) <- readLitFloatOfBits str2 = Just (negate d, bs) | (ds1, str2) <- span isDigit str1 @@ -94,7 +123,7 @@ , (ds2, str4) <- span isDigit str3 , not $ null ds2 , Just str5 <- stripPrefix "f" str4 - , (bs, "#") <- span isDigit str5 + , (bs, "") <- span isDigit str5 , not $ null bs = Just (read (ds1 ++ "." ++ ds2), read bs) @@ -103,8 +132,21 @@ -- | Read a binary string as a number. -readBinary :: (Num a, Read a) => String -> a +readBinary :: Num a => String -> a readBinary digits - = foldl' (\ acc b -> if b then 2 * acc + 1 else 2 * acc) 0 + = foldl' (\acc b -> if b then 2 * acc + 1 else 2 * acc) 0 $ map (/= '0') digits + + +-- | Read a hex string as a number. +readHex :: (Enum a, Num a) => String -> a +readHex digits + = foldl' (\acc d -> let Just v = lookup d table + in 16 * acc + v) 0 + $ digits + + where table + = zip ['0' .. '9'] [0 .. 9] + ++ zip ['a' .. 'f'] [10 .. 15] + ++ zip ['A' .. 'F'] [10 .. 15] diff --git a/DDC/Core/Salt/Name/PrimArith.hs b/DDC/Core/Salt/Name/PrimArith.hs --- a/DDC/Core/Salt/Name/PrimArith.hs +++ b/DDC/Core/Salt/Name/PrimArith.hs @@ -44,7 +44,10 @@ | PrimArithBXOr -- ^ Bit-wise eXclusive Or deriving (Eq, Ord, Show) -instance NFData PrimArith + +instance NFData PrimArith where + rnf !_ = () + instance Pretty PrimArith where ppr op diff --git a/DDC/Core/Salt/Name/PrimCall.hs b/DDC/Core/Salt/Name/PrimCall.hs --- a/DDC/Core/Salt/Name/PrimCall.hs +++ b/DDC/Core/Salt/Name/PrimCall.hs @@ -12,24 +12,41 @@ -- | Primitive ways of invoking a function, -- where control flow returns back to the caller. data PrimCall - -- | Tailcall a function - = PrimCallTail Int + -- | Perform a standard function call where the address is not + -- statically known. All the arguments are boxed heap objects. + = PrimCallStd Int + + -- | Tailcall a statically known functions, + -- where the arguments can be boxed or unboxed. + | PrimCallTail Int deriving (Eq, Ord, Show) instance NFData PrimCall where + rnf (PrimCallStd i) = rnf i rnf (PrimCallTail i) = rnf i instance Pretty PrimCall where ppr pc = case pc of - PrimCallTail arity + PrimCallStd arity + -> text "call" <> int arity <> text "#" + + PrimCallTail arity -> text "tailcall" <> int arity <> text "#" readPrimCall :: String -> Maybe PrimCall readPrimCall str + + -- callN# + | Just rest <- stripPrefix "call" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 0 + = Just $ PrimCallStd n -- tailcallN# | Just rest <- stripPrefix "tailcall" str diff --git a/DDC/Core/Salt/Name/PrimCast.hs b/DDC/Core/Salt/Name/PrimCast.hs --- a/DDC/Core/Salt/Name/PrimCast.hs +++ b/DDC/Core/Salt/Name/PrimCast.hs @@ -31,7 +31,9 @@ deriving (Eq, Ord, Show) -instance NFData PrimCast +instance NFData PrimCast where + rnf !_ = () + instance Pretty PrimCast where ppr c @@ -94,3 +96,4 @@ | otherwise = False + diff --git a/DDC/Core/Salt/Name/PrimControl.hs b/DDC/Core/Salt/Name/PrimControl.hs --- a/DDC/Core/Salt/Name/PrimControl.hs +++ b/DDC/Core/Salt/Name/PrimControl.hs @@ -20,7 +20,8 @@ deriving (Eq, Ord, Show) -instance NFData PrimControl +instance NFData PrimControl where + rnf !_ = () instance Pretty PrimControl where @@ -36,5 +37,4 @@ "fail#" -> Just $ PrimControlFail "return#" -> Just $ PrimControlReturn _ -> Nothing - diff --git a/DDC/Core/Salt/Name/PrimStore.hs b/DDC/Core/Salt/Name/PrimStore.hs --- a/DDC/Core/Salt/Name/PrimStore.hs +++ b/DDC/Core/Salt/Name/PrimStore.hs @@ -47,12 +47,18 @@ | PrimStoreMinusAddr -- Ptr operations ------------- - -- | Read a value from a pointer plus the given offset. + -- | Read a value from a pointer plus offset. | PrimStorePeek - -- | Write a value to a pointer plus the given offset. + -- | Read a value from a pointer plus offset, with an integrated bounds check. + | PrimStorePeekBounded + + -- | Write a value to a pointer plus given offset. | PrimStorePoke + -- | Write a value to a pointer plus offset, with an integrated bounds check. + | PrimStorePokeBounded + -- | Add an offset in bytes to a pointer. | PrimStorePlusPtr @@ -70,7 +76,8 @@ deriving (Eq, Ord, Show) -instance NFData PrimStore +instance NFData PrimStore where + rnf !_ = () instance Pretty PrimStore where @@ -90,6 +97,8 @@ PrimStorePeek -> text "peek#" PrimStorePoke -> text "poke#" + PrimStorePeekBounded -> text "peekBounded#" + PrimStorePokeBounded -> text "pokeBounded#" PrimStorePlusPtr -> text "plusPtr#" PrimStoreMinusPtr -> text "minusPtr#" PrimStoreMakePtr -> text "makePtr#" @@ -115,6 +124,8 @@ "peek#" -> Just PrimStorePeek "poke#" -> Just PrimStorePoke + "peekBounded#" -> Just PrimStorePeekBounded + "pokeBounded#" -> Just PrimStorePokeBounded "plusPtr#" -> Just PrimStorePlusPtr "minusPtr#" -> Just PrimStoreMinusPtr "makePtr#" -> Just PrimStoreMakePtr diff --git a/DDC/Core/Salt/Name/PrimTyCon.hs b/DDC/Core/Salt/Name/PrimTyCon.hs --- a/DDC/Core/Salt/Name/PrimTyCon.hs +++ b/DDC/Core/Salt/Name/PrimTyCon.hs @@ -1,21 +1,23 @@ module DDC.Core.Salt.Name.PrimTyCon ( PrimTyCon (..) + , pprPrimTyConStem , readPrimTyCon + , readPrimTyConStem , primTyConIsIntegral , primTyConIsFloating , primTyConIsUnsigned , primTyConIsSigned , primTyConWidth) where -import DDC.Base.Pretty import DDC.Core.Salt.Platform +import DDC.Data.ListUtils +import DDC.Base.Pretty +import Control.DeepSeq import Data.Char import Data.List -import Control.DeepSeq --- PrimTyCon ----------------------------------------------------------------- -- | Primitive type constructors. data PrimTyCon -- | @Void#@ the Void type has no values. @@ -26,16 +28,20 @@ -- | @Nat#@ natural numbers. -- Enough precision to count every object in the heap, - -- but NOT enough precision to count every byte of memory. + -- but NOT necessearily enough precision to count every byte of memory. | PrimTyConNat -- | @Int#@ signed integers. -- Enough precision to count every object in the heap, - -- but NOT enough precision to count every byte of memory. + -- but NOT necessearily enough precision to count every byte of memory. -- If N is the total number of objects that can exist in the heap, -- then the range of @Int#@ is at least (-N .. +N) inclusive. | PrimTyConInt + -- | @Size#@ unsigned sizes. + -- Enough precision to count every addressable bytes of memory. + | PrimTyConSize + -- | @WordN#@ machine words of the given width. | PrimTyConWord Int @@ -53,19 +59,19 @@ -- memory owned by the current process. | PrimTyConAddr - -- | @Ptr#@ should point to a well-formed object owned by the - -- current process. + -- | @Ptr#@ like @Addr#@, but with a region and element type annotation. + -- In particular, a value of a type like (Ptr# r Word32#) must be at least + -- 4-byte aligned and point to memory owned by the current process. | PrimTyConPtr + -- | @TextLit#@ type of a text literal, which is represented as a pointer + -- to the literal data in static memory. + | PrimTyConTextLit + -- | @Tag#@ data constructor tags. -- Enough precision to count every possible alternative of an -- enumerated type. | PrimTyConTag - - -- | @String#@ of UTF8 characters. - -- - -- These are primitive until we can define our own unboxed types. - | PrimTyConString deriving (Eq, Ord, Show) @@ -78,21 +84,28 @@ instance Pretty PrimTyCon where - ppr tc - = case tc of - PrimTyConVoid -> text "Void#" - PrimTyConBool -> text "Bool#" - PrimTyConNat -> text "Nat#" - PrimTyConInt -> text "Int#" - PrimTyConWord bits -> text "Word" <> int bits <> text "#" - PrimTyConFloat bits -> text "Float" <> int bits <> text "#" - PrimTyConVec arity -> text "Vec" <> int arity <> text "#" - PrimTyConTag -> text "Tag#" - PrimTyConAddr -> text "Addr#" - PrimTyConPtr -> text "Ptr#" - PrimTyConString -> text "String#" + ppr tc = pprPrimTyConStem tc <> text "#" +-- | Pretty print a primitive type constructor, +-- without the '#' suffix. +pprPrimTyConStem :: PrimTyCon -> Doc +pprPrimTyConStem tc + = case tc of + PrimTyConVoid -> text "Void" + PrimTyConBool -> text "Bool" + PrimTyConNat -> text "Nat" + PrimTyConInt -> text "Int" + PrimTyConSize -> text "Size" + PrimTyConWord bits -> text "Word" <> int bits + PrimTyConFloat bits -> text "Float" <> int bits + PrimTyConVec arity -> text "Vec" <> int arity + PrimTyConTag -> text "Tag" + PrimTyConAddr -> text "Addr" + PrimTyConPtr -> text "Ptr" + PrimTyConTextLit -> text "TextLit" + + -- | Read a primitive type constructor. -- -- Words are limited to 8, 16, 32, or 64 bits. @@ -100,18 +113,29 @@ -- Floats are limited to 32 or 64 bits. readPrimTyCon :: String -> Maybe PrimTyCon readPrimTyCon str - | str == "Void#" = Just $ PrimTyConVoid - | str == "Bool#" = Just $ PrimTyConBool - | str == "Nat#" = Just $ PrimTyConNat - | str == "Int#" = Just $ PrimTyConInt - | str == "Tag#" = Just $ PrimTyConTag - | str == "Addr#" = Just $ PrimTyConAddr - | str == "Ptr#" = Just $ PrimTyConPtr - | str == "String#" = Just $ PrimTyConString + | Just stem <- stripSuffix "#" str + = readPrimTyConStem stem + | otherwise + = Nothing + + +-- | Read a primitive type constructor, without the '#' suffix. +readPrimTyConStem :: String -> Maybe PrimTyCon +readPrimTyConStem str + | str == "Void" = Just $ PrimTyConVoid + | str == "Bool" = Just $ PrimTyConBool + | str == "Nat" = Just $ PrimTyConNat + | str == "Int" = Just $ PrimTyConInt + | str == "Size" = Just $ PrimTyConSize + | str == "Tag" = Just $ PrimTyConTag + | str == "Addr" = Just $ PrimTyConAddr + | str == "Ptr" = Just $ PrimTyConPtr + | str == "TextLit" = Just $ PrimTyConTextLit + -- WordN# | Just rest <- stripPrefix "Word" str - , (ds, "#") <- span isDigit rest + , (ds, "") <- span isDigit rest , not $ null ds , n <- read ds , elem n [8, 16, 32, 64] @@ -119,7 +143,7 @@ -- FloatN# | Just rest <- stripPrefix "Float" str - , (ds, "#") <- span isDigit rest + , (ds, "") <- span isDigit rest , not $ null ds , n <- read ds , elem n [32, 64] @@ -127,7 +151,7 @@ -- VecN# | Just rest <- stripPrefix "Vec" str - , (ds, "#") <- span isDigit rest + , (ds, "") <- span isDigit rest , not $ null ds , n <- read ds , elem n [2, 4, 8, 16] @@ -140,7 +164,7 @@ -- | Integral constructors are the ones that we can reasonably -- convert from integers of the same size. -- --- These are @Bool#@ @Nat#@ @Int#@ @WordN#@ and @Tag#@. +-- These are @Bool#@, @Nat#@, @Int#@, @Size@, @WordN#@ and @Tag#@. -- primTyConIsIntegral :: PrimTyCon -> Bool primTyConIsIntegral tc @@ -148,14 +172,15 @@ PrimTyConBool -> True PrimTyConNat -> True PrimTyConInt -> True + PrimTyConSize -> True PrimTyConWord{} -> True PrimTyConTag -> True _ -> False --- | Floating point constructors. +-- | Floating point types. -- --- These are @FloatN@. +-- These are @FloatN#@. primTyConIsFloating :: PrimTyCon -> Bool primTyConIsFloating tc = case tc of @@ -163,14 +188,15 @@ _ -> False --- | Unsigned integral constructors. +-- | Unsigned types. -- --- These are @Bool@ @Nat@ @WordN@ @Tag@. +-- These are @Bool#@ @Nat#@ @Size#@ @WordN@ @Tag@. primTyConIsUnsigned :: PrimTyCon -> Bool primTyConIsUnsigned tc = case tc of PrimTyConBool -> True PrimTyConNat -> True + PrimTyConSize -> True PrimTyConWord{} -> True PrimTyConTag -> True _ -> False @@ -198,14 +224,21 @@ primTyConWidth pp tc = case tc of PrimTyConVoid -> Nothing - PrimTyConBool -> Just $ 8 * platformNatBytes pp + PrimTyConBool -> Just $ 8 * platformNatBytes pp PrimTyConNat -> Just $ 8 * platformNatBytes pp PrimTyConInt -> Just $ 8 * platformNatBytes pp + PrimTyConSize -> Just $ 8 * platformNatBytes pp PrimTyConWord bits -> Just $ fromIntegral bits PrimTyConFloat bits -> Just $ fromIntegral bits PrimTyConTag -> Just $ 8 * platformTagBytes pp PrimTyConAddr -> Just $ 8 * platformAddrBytes pp PrimTyConPtr -> Just $ 8 * platformAddrBytes pp + + -- The string literal itself does not have a width associated with it. + -- In the object code string literals are represented by pointers to + -- static data. The static data is an array of Word8s, but the pointer + -- itself is the width of an address on our machine. + PrimTyConTextLit -> Nothing + PrimTyConVec _ -> Nothing - PrimTyConString -> Nothing diff --git a/DDC/Core/Salt/Name/PrimVec.hs b/DDC/Core/Salt/Name/PrimVec.hs --- a/DDC/Core/Salt/Name/PrimVec.hs +++ b/DDC/Core/Salt/Name/PrimVec.hs @@ -13,7 +13,7 @@ import Data.Char --- | Primitive vector operators. +-- | Primitive fixed-length SIMD vector operators. data PrimVec -- Arithmetic --------------------------- -- | Negate elements of a vector. @@ -62,7 +62,8 @@ deriving (Eq, Ord, Show) -instance NFData PrimVec +instance NFData PrimVec where + rnf !_ = () instance Pretty PrimVec where @@ -158,5 +159,4 @@ PrimVecMul{} -> Just PrimArithMul PrimVecDiv{} -> Just PrimArithDiv _ -> Nothing - diff --git a/DDC/Core/Salt/Profile.hs b/DDC/Core/Salt/Profile.hs --- a/DDC/Core/Salt/Profile.hs +++ b/DDC/Core/Salt/Profile.hs @@ -22,7 +22,8 @@ , profilePrimKinds = primKindEnv , profilePrimTypes = primTypeEnv , profileTypeIsUnboxed = typeIsUnboxed - , profileNameIsHole = Nothing } + , profileNameIsHole = Nothing + , profileMakeStringName = Just (\_sp t -> NameLitTextLit t) } -- | The Salt fragment doesn't support many features. @@ -33,9 +34,17 @@ , featuresFunctionalClosures = True , featuresDebruijnBinders = True , featuresUnusedBindings = True - , featuresEffectCapabilities = True } + , featuresEffectCapabilities = True + -- ISSUE #340: Check for partial application of supers in Salt + -- fragment check. This is enabled to support the reify# primitive, + -- which takes the address of a top-level super. However, the Salt + -- language itself doesn't support general partial application. + -- The fragment compliance checker should distinguish between these + -- two cases. + , featuresPartialApplication = True } + -- | Lex a string to tokens, using primitive names. lexModuleString :: String -- ^ Source file name. @@ -47,7 +56,7 @@ where rn (Token strTok sp) = case renameTok readName strTok of Just t' -> Token t' sp - Nothing -> Token (KJunk "lexical error") sp + Nothing -> Token (KErrorJunk "lexical error") sp -- | Lex a string to tokens, using primitive names. @@ -61,4 +70,4 @@ where rn (Token strTok sp) = case renameTok readName strTok of Just t' -> Token t' sp - Nothing -> Token (KJunk "lexical error") sp + Nothing -> Token (KErrorJunk "lexical error") sp diff --git a/DDC/Core/Salt/Runtime.hs b/DDC/Core/Salt/Runtime.hs --- a/DDC/Core/Salt/Runtime.hs +++ b/DDC/Core/Salt/Runtime.hs @@ -1,4 +1,3 @@ - -- | Bindings to functions exported by the runtime system, -- and wrappers for related primops. module DDC.Core.Salt.Runtime @@ -7,38 +6,48 @@ , runtimeImportKinds , runtimeImportTypes - -- * Types defined in the runtime system. + -- * Runtime Types. , rTop - -- * Functions defined in the runtime system. + -- * Runtime Functions + -- ** Generic , xGetTag + + -- ** Boxed Objects , xAllocBoxed , xGetFieldOfBoxed , xSetFieldOfBoxed - , xAllocRawSmall - , xPayloadOfRawSmall - -- * Calls to primops. - , xCreate - , xRead - , xWrite - , xPeekBuffer - , xPokeBuffer - , xFail - , xReturn) + -- ** Raw Objects + , xAllocRaw + , xPayloadOfRaw + + -- ** Raw Small Objects + , xAllocSmall + , xPayloadOfSmall + + -- ** Thunk Objects + , xAllocThunk + , xArgsOfThunk + , xSetFieldOfThunk + , xExtendThunk + , xCopyArgsOfThunk + , xApplyThunk + , xRunThunk + + -- ** Error handling + , xErrorDefault) where import DDC.Core.Salt.Compounds import DDC.Core.Salt.Name -import DDC.Core.Salt.Env -import DDC.Core.Compounds +import DDC.Core.Exp.Annot import DDC.Core.Module -import DDC.Core.Exp import DDC.Base.Pretty import qualified Data.Map as Map import Data.Map (Map) --- Runtime -------------------------------------------------------------------- +-- Runtime ----------------------------------------------------------------------------------------- -- | Runtime system configuration data Config = Config @@ -48,29 +57,49 @@ -- | Kind signatures for runtime types that we use when converting to Salt. -runtimeImportKinds :: Map Name (ImportSource Name) +runtimeImportKinds :: Map Name (ImportType Name) runtimeImportKinds = Map.fromList [ rn ukTop ] - where rn (UName n, t) = (n, ImportSourceModule (ModuleName ["Runtime"]) n t) + where rn (UName n, t) = (n, ImportTypeAbstract t) rn _ = error "ddc-core-salt: all runtime bindings must be named." -- | Type signatures for runtime funtions that we use when converting to Salt. -runtimeImportTypes :: Map Name (ImportSource Name) +runtimeImportTypes :: Map Name (ImportValue Name) runtimeImportTypes = Map.fromList [ rn utGetTag , rn utAllocBoxed , rn utGetFieldOfBoxed , rn utSetFieldOfBoxed - , rn utAllocRawSmall - , rn utPayloadOfRawSmall ] - where rn (UName n, t) = (n, ImportSourceSea (renderPlain $ ppr n) t) + + , rn utAllocSmall + , rn utPayloadOfSmall + + , rn utAllocRaw + , rn utPayloadOfRaw + + , rn utAllocThunk + , rn utArgsOfThunk + , rn utSetFieldOfThunk + , rn utExtendThunk + , rn utCopyArgsOfThunk + , rn utRunThunk + + , rn (utApplyThunk 0) + , rn (utApplyThunk 1) + , rn (utApplyThunk 2) + , rn (utApplyThunk 3) + , rn (utApplyThunk 4) + + , rn utErrorDefault] + + where rn (UName n, t) = (n, ImportValueSea (renderPlain $ ppr n) t) rn _ = error "ddc-core-salt: all runtime bindings must be named." --- Regions ---------------------------- +-- Regions -------------------------------------------------------------------- -- | The top-level region. -- This region lives for the whole program, and is used to store objects whose -- types don't have region annotations (like function closures and Unit values). @@ -83,7 +112,7 @@ , kRegion) --- Tags ------------------------------- +-- Tags ------------------------------------------------------------------------------------------- -- | Get the constructor tag of an object. xGetTag :: a -> Type Name -> Exp a Name -> Exp a Name xGetTag a tR x2 @@ -93,47 +122,196 @@ utGetTag :: (Bound Name, Type Name) utGetTag = ( UName (NameVar "getTag") - , tForall kRegion $ \r -> tPtr r tObj `tFunPE` tTag) + , tForall kRegion $ \r -> tPtr r tObj `tFun` tTag) --- Boxed ------------------------------ +-- Thunk ------------------------------------------------------------------------------------------ +-- | Allocate a Thunk object. +xAllocThunk + :: a + -> Type Name + -> Exp a Name -- ^ Function + -> Exp a Name -- ^ Value paramters. + -> Exp a Name -- ^ Times boxed. + -> Exp a Name -- ^ Value args. + -> Exp a Name -- ^ Times run. + -> Exp a Name + +xAllocThunk a tR xFun xParam xBoxes xArgs xRun + = xApps a (XVar a $ fst utAllocThunk) + [ XType a tR, xFun, xParam, xBoxes, xArgs, xRun] + +utAllocThunk :: (Bound Name, Type Name) +utAllocThunk + = ( UName (NameVar "allocThunk") + , tForall kRegion + $ \tR -> (tAddr `tFun` tNat `tFun` tNat `tFun` tNat + `tFun` tNat `tFun` tPtr tR tObj)) + + +-- | Copy the available arguments from one thunk to another. +xCopyArgsOfThunk + :: a -> Type Name -> Type Name + -> Exp a Name -> Exp a Name -> Exp a Name -> Exp a Name -> Exp a Name + +xCopyArgsOfThunk a tRSrc tRDst xSrc xDst xIndex xLen + = xApps a (XVar a $ fst utCopyArgsOfThunk) + [ XType a tRSrc, XType a tRDst, xSrc, xDst, xIndex, xLen ] + + +utCopyArgsOfThunk :: (Bound Name, Type Name) +utCopyArgsOfThunk + = ( UName (NameVar "copyThunk") + , tForalls [kRegion, kRegion] + $ \[tR1, tR2] -> (tPtr tR1 tObj + `tFun` tPtr tR2 tObj + `tFun` tNat `tFun` tNat + `tFun` tPtr tR2 tObj)) + + +-- | Copy a thunk while extending the number of available argument slots. +xExtendThunk + :: a -> Type Name -> Type Name + -> Exp a Name -> Exp a Name -> Exp a Name + +xExtendThunk a tRSrc tRDst xSrc xMore + = xApps a (XVar a $ fst utExtendThunk) + [ XType a tRSrc, XType a tRDst, xSrc, xMore ] + +utExtendThunk :: (Bound Name, Type Name) +utExtendThunk + = ( UName (NameVar "extendThunk") + , tForalls [kRegion, kRegion] + $ \[tR1, tR2] -> (tPtr tR1 tObj `tFun` tNat `tFun` tPtr tR2 tObj)) + + +-- | Get the available arguments in a thunk. +xArgsOfThunk + :: a -> Type Name + -> Exp a Name -> Exp a Name + +xArgsOfThunk a tR xThunk + = xApps a (XVar a $ fst utArgsOfThunk) + [ XType a tR, xThunk ] + +utArgsOfThunk :: (Bound Name, Type Name) +utArgsOfThunk + = ( UName (NameVar "argsThunk") + , tForall kRegion + $ \tR -> (tPtr tR tObj `tFun` tNat)) + + +-- | Set one of the argument pointers in a thunk. +xSetFieldOfThunk + :: a + -> Type Name -- ^ Region containing thunk. + -> Type Name -- ^ Region containigng new child. + -> Exp a Name -- ^ Thunk to set field of. + -> Exp a Name -- ^ Base offset. + -> Exp a Name -- ^ Index of field from base. + -> Exp a Name -- ^ New child value. + -> Exp a Name + +xSetFieldOfThunk a tR tC xObj xBase xIndex xVal + = xApps a (XVar a $ fst utSetFieldOfThunk) + [ XType a tR, XType a tC, xObj, xBase, xIndex, xVal] + +utSetFieldOfThunk :: (Bound Name, Type Name) +utSetFieldOfThunk + = ( UName (NameVar "setThunk") + , tForalls [kRegion, kRegion] + $ \[tR1, tR2] + -> (tPtr tR1 tObj + `tFun` tNat `tFun` tNat + `tFun` tPtr tR2 tObj `tFun` tVoid)) + + +-- | Apply a thunk to some more arguments. +xApplyThunk + :: a -> Int + -> [Exp a Name] -> Exp a Name + +xApplyThunk a arity xsArgs + = xApps a (XVar a $ fst (utApplyThunk arity)) xsArgs + +utApplyThunk :: Int -> (Bound Name, Type Name) +utApplyThunk arity + = let krThunk = kRegion + krsArg = replicate arity kRegion + krResult = kRegion + ks = [krThunk] ++ krsArg ++ [krResult] + + t = tForalls ks $ \rs + -> let (rThunk : rsMore) = rs + rsArg = take arity rsMore + [rResult] = drop arity rsMore + Just t' = tFunOfList + $ [tPtr rThunk tObj] + ++ [tPtr r tObj | r <- rsArg] + ++ [tPtr rResult tObj] + in t' + + in ( UName (NameVar $ "apply" ++ show arity) + , t ) + + +-- | Run a thunk. +xRunThunk + :: a -- ^ Annotation. + -> Type Name -- ^ Region containing thunk to run. + -> Type Name -- ^ Region containing result object. + -> Exp a Name -- ^ Expression of thunk to run. + -> Exp a Name + +xRunThunk a trThunk trResult xArg + = xApps a (XVar a $ fst utRunThunk) + [XType a trThunk, XType a trResult, xArg] + +utRunThunk :: (Bound Name, Type Name) +utRunThunk + = ( UName (NameVar $ "runThunk") + , tForalls [kRegion, kRegion] + $ \[tR1, tR2] -> tPtr tR1 tObj `tFun` tPtr tR2 tObj) + + +-- Boxed ------------------------------------------------------------------------------------------ -- | Allocate a Boxed object. xAllocBoxed :: a -> Type Name -> Integer -> Exp a Name -> Exp a Name xAllocBoxed a tR tag x2 = xApps a (XVar a $ fst utAllocBoxed) [ XType a tR - , XCon a (DaConPrim (NameLitTag tag) tTag) + , XCon a (DaConPrim (NamePrimLit (PrimLitTag tag)) tTag) , x2] utAllocBoxed :: (Bound Name, Type Name) utAllocBoxed = ( UName (NameVar "allocBoxed") - , tForall kRegion $ \r -> (tTag `tFunPE` tNat `tFunPE` tPtr r tObj)) + , tForall kRegion $ \r -> (tTag `tFun` tNat `tFun` tPtr r tObj)) -- | Get a field of a Boxed object. xGetFieldOfBoxed :: a -> Type Name -- ^ Prime region var of object. - -> Type Name -- ^ Type of field object + -> Type Name -- ^ Regino of result object. -> Exp a Name -- ^ Object to update. -> Integer -- ^ Field index. -> Exp a Name -xGetFieldOfBoxed a trPrime tField x2 offset +xGetFieldOfBoxed a trPrime trField x2 offset = xApps a (XVar a $ fst utGetFieldOfBoxed) - [ XType a trPrime, XType a tField + [ XType a trPrime, XType a trField , x2 , xNat a offset ] utGetFieldOfBoxed :: (Bound Name, Type Name) utGetFieldOfBoxed - = ( UName (NameVar "getFieldOfBoxed") - , tForalls [kRegion, kData] - $ \[r1, t2] + = ( UName (NameVar "getBoxed") + , tForalls [kRegion, kRegion] + $ \[r1, r2] -> tPtr r1 tObj - `tFunPE` tNat - `tFunPE` t2) + `tFun` tNat + `tFun` tPtr r2 tObj) -- | Set a field in a Boxed Object. @@ -146,149 +324,78 @@ -> Exp a Name -- ^ New field value. -> Exp a Name -xSetFieldOfBoxed a trPrime tField x2 offset val +xSetFieldOfBoxed a trPrime trField x2 offset val = xApps a (XVar a $ fst utSetFieldOfBoxed) - [ XType a trPrime, XType a tField + [ XType a trPrime, XType a trField , x2 , xNat a offset , val] utSetFieldOfBoxed :: (Bound Name, Type Name) utSetFieldOfBoxed - = ( UName (NameVar "setFieldOfBoxed") - , tForalls [kRegion, kData] - $ \[r1, t2] - -> tPtr r1 tObj - `tFunPE` tNat - `tFunPE` t2 - `tFunPE` tVoid) - + = ( UName (NameVar "setBoxed") + , tForalls [kRegion, kRegion] + $ \[r1, t2] -> tPtr r1 tObj `tFun` tNat `tFun` tPtr t2 tObj `tFun` tVoid) --- RawSmall --------------------------- --- | Allocate a RawSmall object. -xAllocRawSmall :: a -> Type Name -> Integer -> Exp a Name -> Exp a Name -xAllocRawSmall a tR tag x2 - = xApps a (XVar a $ fst utAllocRawSmall) - [ XType a tR - , xTag a tag - , x2] +-- Raw -------------------------------------------------------------------------------------------- +-- | Allocate a Raw object. +xAllocRaw :: a -> Type Name -> Integer -> Exp a Name -> Exp a Name +xAllocRaw a tR tag x2 + = xApps a (XVar a $ fst utAllocRaw) + [ XType a tR, xTag a tag, x2] -utAllocRawSmall :: (Bound Name, Type Name) -utAllocRawSmall - = ( UName (NameVar "allocRawSmall") - , tForall kRegion $ \r -> (tTag `tFunPE` tNat `tFunPE` tPtr r tObj)) +utAllocRaw :: (Bound Name, Type Name) +utAllocRaw + = ( UName (NameVar "allocRaw") + , tForall kRegion $ \r -> (tTag `tFun` tNat `tFun` tPtr r tObj)) --- | Get the payload of a RawSmall object. -xPayloadOfRawSmall :: a -> Type Name -> Exp a Name -> Exp a Name -xPayloadOfRawSmall a tR x2 - = xApps a (XVar a $ fst utPayloadOfRawSmall) +-- | Get the payload of a Raw object. +xPayloadOfRaw :: a -> Type Name -> Exp a Name -> Exp a Name +xPayloadOfRaw a tR x2 + = xApps a (XVar a $ fst utPayloadOfRaw) [XType a tR, x2] -utPayloadOfRawSmall :: (Bound Name, Type Name) -utPayloadOfRawSmall - = ( UName (NameVar "payloadOfRawSmall") - , tForall kRegion $ \r -> (tFunPE (tPtr r tObj) (tPtr r (tWord 8)))) - - --- Primops -------------------------------------------------------------------- --- | Create the heap. -xCreate :: a -> Integer -> Exp a Name -xCreate a bytes - = XApp a (XVar a uCreate) - (xNat a bytes) - -uCreate :: Bound Name -uCreate = UPrim (NamePrimOp $ PrimStore $ PrimStoreCreate) - (tNat `tFunPE` tVoid) - - --- | Read a value from an address plus offset. -xRead :: a -> Type Name -> Exp a Name -> Integer -> Exp a Name -xRead a tField xAddr offset - = XApp a (XApp a (XApp a (XVar a uRead) - (XType a tField)) - xAddr) - (xNat a offset) - -uRead :: Bound Name -uRead = UPrim (NamePrimOp $ PrimStore $ PrimStoreRead) - (tForall kData $ \t -> tAddr `tFunPE` tNat `tFunPE` t) - - --- | Write a value to an address plus offset. -xWrite :: a -> Type Name -> Exp a Name -> Integer -> Exp a Name -> Exp a Name -xWrite a tField xAddr offset xVal - = XApp a (XApp a (XApp a (XApp a (XVar a uWrite) - (XType a tField)) - xAddr) - (xNat a offset)) - xVal - -uWrite :: Bound Name -uWrite = UPrim (NamePrimOp $ PrimStore $ PrimStoreWrite) - (tForall kData $ \t -> tAddr `tFunPE` tNat `tFunPE` t `tFunPE` tVoid) +utPayloadOfRaw :: (Bound Name, Type Name) +utPayloadOfRaw + = ( UName (NameVar "payloadRaw") + , tForall kRegion $ \r -> (tFun (tPtr r tObj) (tPtr r (tWord 8)))) --- | Peek a value from a buffer pointer plus offset -xPeekBuffer :: a -> Type Name -> Type Name -> Exp a Name -> Integer -> Exp a Name -xPeekBuffer a r t xPtr offset - = let castedPtr = xCast a r t (tWord 8) xPtr - in XApp a (XApp a (XApp a (XApp a (XVar a uPeek) - (XType a r)) - (XType a t)) - castedPtr) - (xNat a offset) - -uPeek :: Bound Name -uPeek = UPrim (NamePrimOp $ PrimStore $ PrimStorePeek) - (typeOfPrimStore PrimStorePeek) - - --- | Poke a value from a buffer pointer plus offset -xPokeBuffer :: a -> Type Name -> Type Name -> Exp a Name -> Integer -> Exp a Name -> Exp a Name -xPokeBuffer a r t xPtr offset xVal - = let castedPtr = xCast a r t (tWord 8) xPtr - in XApp a (XApp a (XApp a (XApp a (XApp a (XVar a uPoke) - (XType a r)) - (XType a t)) - castedPtr) - (xNat a offset)) - xVal +-- Small ------------------------------------------------------------------------------------------ +-- | Allocate a Small object. +xAllocSmall :: a -> Type Name -> Integer -> Exp a Name -> Exp a Name +xAllocSmall a tR tag x2 + = xApps a (XVar a $ fst utAllocSmall) + [ XType a tR, xTag a tag, x2] -uPoke :: Bound Name -uPoke = UPrim (NamePrimOp $ PrimStore $ PrimStorePoke) - (typeOfPrimStore PrimStorePoke) +utAllocSmall :: (Bound Name, Type Name) +utAllocSmall + = ( UName (NameVar "allocSmall") + , tForall kRegion $ \r -> (tTag `tFun` tNat `tFun` tPtr r tObj)) --- | Cast a pointer -xCast :: a -> Type Name -> Type Name -> Type Name -> Exp a Name -> Exp a Name -xCast a r toType fromType xPtr - = XApp a (XApp a (XApp a (XApp a (XVar a uCast) - (XType a r)) - (XType a toType)) - (XType a fromType)) - xPtr - -uCast :: Bound Name -uCast = UPrim (NamePrimOp $ PrimStore $ PrimStoreCastPtr) - (typeOfPrimStore PrimStoreCastPtr) - - --- | Fail with an internal error. -xFail :: a -> Type Name -> Exp a Name -xFail a t - = XApp a (XVar a uFail) (XType a t) - where uFail = UPrim (NamePrimOp (PrimControl PrimControlFail)) tFail - tFail = TForall (BAnon kData) (TVar $ UIx 0) +-- | Get the payload of a Small object. +xPayloadOfSmall :: a -> Type Name -> Exp a Name -> Exp a Name +xPayloadOfSmall a tR x2 + = xApps a (XVar a $ fst utPayloadOfSmall) + [XType a tR, x2] + +utPayloadOfSmall :: (Bound Name, Type Name) +utPayloadOfSmall + = ( UName (NameVar "payloadSmall") + , tForall kRegion $ \r -> (tFun (tPtr r tObj) (tPtr r (tWord 8)))) --- | Return a value. --- like (return# [Int32#] x) -xReturn :: a -> Type Name -> Exp a Name -> Exp a Name -xReturn a t x - = XApp a (XApp a (XVar a (UPrim (NamePrimOp (PrimControl PrimControlReturn)) - (tForall kData $ \t1 -> t1 `tFunPE` t1))) - (XType a t)) - x +-- Error ------------------------------------------------------------------------------------------ +-- | Get the payload of a Small object. +xErrorDefault :: a -> Exp a Name -> Exp a Name -> Exp a Name +xErrorDefault a xStr xLine + = xApps a (XVar a $ fst utErrorDefault) + [xStr, xLine] + +utErrorDefault :: (Bound Name, Type Name) +utErrorDefault + = ( UName (NameVar "primErrorDefault") + , tTextLit `tFun` tNat `tFun` tPtr rTop tObj) diff --git a/DDC/Core/Salt/Transfer.hs b/DDC/Core/Salt/Transfer.hs --- a/DDC/Core/Salt/Transfer.hs +++ b/DDC/Core/Salt/Transfer.hs @@ -3,13 +3,11 @@ (transferModule) where import DDC.Core.Salt.Convert.Base -import DDC.Core.Salt.Runtime +import DDC.Core.Salt.Compounds import DDC.Core.Salt.Name import DDC.Core.Salt.Env -import DDC.Core.Predicates -import DDC.Core.Compounds import DDC.Core.Module -import DDC.Core.Exp +import DDC.Core.Exp.Annot import DDC.Core.Check (AnTEC(..)) import Data.Map (Map) import qualified Data.Map as Map @@ -144,7 +142,6 @@ LLet b x -> LLet b (transX tails x) LRec bxs -> LRec [(b, transX tails x) | (b, x) <- bxs] LPrivate{} -> lts - LWithRegion{} -> lts -- Alt ------------------------------------------------------------------------ diff --git a/ddc-core-salt.cabal b/ddc-core-salt.cabal --- a/ddc-core-salt.cabal +++ b/ddc-core-salt.cabal @@ -1,5 +1,5 @@ Name: ddc-core-salt -Version: 0.4.1.3 +Version: 0.4.2.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -14,19 +14,21 @@ Library Build-Depends: - base >= 4.6 && < 4.8, + base >= 4.6 && < 4.9, array >= 0.4 && < 0.6, - deepseq == 1.3.*, + deepseq >= 1.3 && < 1.5, containers == 0.5.*, + text >= 1.0 && < 1.3, transformers == 0.4.*, - mtl == 2.2.*, - ddc-base == 0.4.1.*, - ddc-core == 0.4.1.* + mtl == 2.2.1.*, + ddc-base == 0.4.2.*, + ddc-core == 0.4.2.* Exposed-modules: DDC.Core.Salt.Compounds DDC.Core.Salt.Convert DDC.Core.Salt.Env + DDC.Core.Salt.Exp DDC.Core.Salt.Name DDC.Core.Salt.Platform DDC.Core.Salt.Profile @@ -34,12 +36,15 @@ DDC.Core.Salt.Transfer DDC.Core.Salt - DDC.Core.Lite.Compounds - DDC.Core.Lite.Layout - DDC.Core.Lite.Env - DDC.Core.Lite - Other-modules: + DDC.Core.Salt.Compounds.Lit + DDC.Core.Salt.Compounds.PrimArith + DDC.Core.Salt.Compounds.PrimCast + DDC.Core.Salt.Compounds.PrimControl + DDC.Core.Salt.Compounds.PrimStore + DDC.Core.Salt.Compounds.PrimTyCon + + DDC.Core.Salt.Convert.Base DDC.Core.Salt.Convert.Exp DDC.Core.Salt.Convert.Init DDC.Core.Salt.Convert.Name @@ -56,16 +61,8 @@ DDC.Core.Salt.Name.PrimTyCon DDC.Core.Salt.Name.PrimVec - DDC.Core.Lite.Convert.Base - DDC.Core.Lite.Convert.Data - DDC.Core.Lite.Convert.Type - DDC.Core.Lite.Convert - DDC.Core.Lite.Name - DDC.Core.Lite.Profile - DDC.Core.Salt.Convert.Base - GHC-options: -Wall @@ -75,11 +72,15 @@ -fno-warn-unused-do-bind Extensions: - KindSignatures NoMonomorphismRestriction + FunctionalDependencies + MultiParamTypeClasses ScopedTypeVariables StandaloneDeriving - PatternGuards - DeriveDataTypeable + FlexibleInstances + FlexibleContexts ParallelListComp - + PatternSynonyms + KindSignatures + PatternGuards + BangPatterns