diff --git a/DDC/Core/Lite.hs b/DDC/Core/Lite.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lite.hs @@ -0,0 +1,39 @@ + +-- | 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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Lite/Compounds.hs @@ -0,0 +1,91 @@ + +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.Exp +import DDC.Core.DaCon +import DDC.Type.Compounds + + +-- 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 = mkDaConAlg (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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Lite/Convert.hs @@ -0,0 +1,620 @@ + +-- | 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, result) +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 #-} + result $ 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' + <- liftM Map.fromList + $ mapM convertExportM + $ Map.toList + $ moduleExportTypes mm + + -- Convert signatures of imported functions. + tsImports' + <- liftM Map.fromList + $ mapM convertImportM + $ Map.toList + $ moduleImportTypes mm + + -- Convert the body of the module to Salt. + let ntsImports = [(BName n t) | (n, (_, t)) <- Map.toList $ 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 Just a = takeAnnotOfExp 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. + , moduleExportKinds = Map.empty + , moduleExportTypes = tsExports' + + , moduleImportKinds = S.runtimeImportKinds + , moduleImportTypes = Map.union S.runtimeImportTypes tsImports' + + , moduleBody = x2 } + + -- If this is the 'Main' module then add code to initialise the + -- runtime system. This will fail if given a Main module with no + -- 'main' function. + mm_init <- case initRuntime runConfig mm_salt of + Nothing -> throw ErrorMainHasNoMain + Just mm' -> return mm' + + return $ mm_init + + +-- | Convert an export spec. +convertExportM + :: (L.Name, Type L.Name) + -> ConvertM a (S.Name, Type S.Name) + +convertExportM (n, t) + = do n' <- convertBindNameM n + t' <- convertT Env.empty t + return (n', t') + + +-- | Convert an import spec. +convertImportM + :: (L.Name, (QualName L.Name, Type L.Name)) + -> ConvertM a (S.Name, (QualName S.Name, Type S.Name)) + +convertImportM (n, (qn, t)) + = do n' <- convertBindNameM n + qn' <- convertQualNameM qn + t' <- convertT Env.empty t + return (n', (qn', t')) + + +-- | Convert a qualified name. +convertQualNameM + :: QualName L.Name + -> ConvertM a (QualName S.Name) + +convertQualNameM (QualName mn n) + = do n' <- convertBindNameM n + return $ QualName mn n' + + +-- 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 t + | ExpArg <- ctx -> liftM XType (convertT kenv t) + | otherwise -> throw $ ErrorNotNormalized ("Unexpected type expresison.") + + + -- Witnesses can only appear as the arguments to function applications. + XWitness w + | ExpArg <- ctx -> liftM XWitness (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 LetStrict b x1 + -> do let tenv' = Env.extend b tenv + b' <- convertB kenv b + x1' <- convertExpX ExpBind pp defs kenv tenv' x1 + return $ LLet LetStrict b' x1' + + LLet LetLazy{} _ _ + -> throw $ ErrorMalformed "XLet lazy not handled yet" + + LLetRegions b bs + -> do b' <- mapM (convertB kenv) b + let kenv' = Env.extends b kenv + bs' <- mapM (convertB kenv') bs + return $ LLetRegions b' 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 L.Name -- ^ Witness to convert. + -> ConvertM a (Witness S.Name) + +convertWitnessX kenv ww + = let down = convertWitnessX kenv + in case ww of + WVar n -> liftM WVar (convertU n) + WCon wc -> liftM WCon (convertWiConX kenv wc) + WApp w1 w2 -> liftM2 WApp (down w1) (down w2) + WJoin w1 w2 -> liftM2 WApp (down w1) (down w2) + WType t -> liftM WType (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 <- daConName 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 + = case takeAnnotOfExp x of + Nothing -> return Nothing + Just a' -> 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 <- daConName dc + -> do xBody <- convertExpX ctx pp defs kenv tenv x + let dcTag = mkDaConAlg (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 = mkDaConAlg (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 <- daConName 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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Lite/Convert/Base.hs @@ -0,0 +1,79 @@ + +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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Lite/Convert/Data.hs @@ -0,0 +1,179 @@ + +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 $ dataTypeParamKinds dataDef) xsArgs + + -- Get the regions each of the objects are in. + let Just tsFields = sequence + $ drop (length $ dataTypeParamKinds 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 LetStrict (BNone O.tVoid) + (O.xSetFieldOfBoxed a + rPrime trField xObject' ix (liftX 1 xField)) + | ix <- [0..] + | xField <- xsFields + | trField <- tsFields ] + + return $ XLet a (LLet LetStrict 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 $ dataTypeParamKinds 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 LetStrict (BNone O.tVoid) + (O.xPokeBuffer a rPrime tField xPayload' + offset (liftX 2 xField)) + | tField <- tsFields + | offset <- offsets + | xField <- xsFields] + + return $ XLet a (LLet LetStrict bObject xAlloc) + $ XLet a (LLet LetStrict 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 LetStrict 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 LetStrict bField + (O.xPeekBuffer a trPrime tField + (XVar a uPayload) offset) + | bField <- bsFields + | tField <- map typeOfBind bsFields + | offset <- offsets ] + + return $ foldr (XLet a) xBody + $ LLet LetStrict bPayload xPayload + : lsFields + + + | otherwise + = throw ErrorInvalidAlt + diff --git a/DDC/Core/Lite/Convert/Type.hs b/DDC/Core/Lite/Convert/Type.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lite/Convert/Type.hs @@ -0,0 +1,213 @@ + +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 $ "convertT': unexpected var kind " ++ show tt + + Nothing + -> error $ "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) <- takeTFun 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 TcConFun -> return $ TCon $ TyConSpec TcConFun + 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 "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 $ "convertTyConPrim: unknown prim name " ++ show n + + +-- Names ---------------------------------------------------------------------- +convertDC + :: KindEnv L.Name + -> DaCon L.Name + -> ConvertM a (DaCon O.Name) + +convertDC kenv dc + = case daConName dc of + DaConUnit + -> error "convertDC: not converting unit DaConName" + + DaConNamed n + -> do n' <- convertBoundNameM n + t' <- convertT kenv (daConType dc) + return $ DaCon + { daConName = DaConNamed n' + , daConType = t' + , daConIsAlgebraic = daConIsAlgebraic dc } + + +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 $ "convertBoundNameM: cannot convert name" + diff --git a/DDC/Core/Lite/Env.hs b/DDC/Core/Lite/Env.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Lite/Env.hs @@ -0,0 +1,292 @@ + +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# + [ DataDef (NamePrimTyCon PrimTyConBool) + [] + (Just [ (NameLitBool True, []) + , (NameLitBool False, []) ]) + + -- Nat# + , DataDef (NamePrimTyCon PrimTyConNat) [] Nothing + + -- Int# + , DataDef (NamePrimTyCon PrimTyConInt) [] Nothing + + -- WordN# + , DataDef (NamePrimTyCon (PrimTyConWord 64)) [] Nothing + , DataDef (NamePrimTyCon (PrimTyConWord 32)) [] Nothing + , DataDef (NamePrimTyCon (PrimTyConWord 16)) [] Nothing + , DataDef (NamePrimTyCon (PrimTyConWord 8)) [] Nothing + + + -- Boxed ---------------------------------------------------- + -- Unit + , DataDef + (NameDataTyCon DataTyConUnit) + [] + (Just [ ( NamePrimDaCon PrimDaConUnit + , []) ]) + + -- Bool + , DataDef + (NameDataTyCon DataTyConBool) + [kRegion] + (Just [ ( NamePrimDaCon PrimDaConBoolU + , [tBoolU]) ]) + + -- Nat + , DataDef + (NameDataTyCon DataTyConNat) + [kRegion] + (Just [ ( NamePrimDaCon PrimDaConNatU + , [tNatU]) ]) + + -- Int + , DataDef + (NameDataTyCon DataTyConInt) + [kRegion] + (Just [ ( NamePrimDaCon PrimDaConIntU + , [tIntU]) ]) + + -- Pair + , DataDef + (NameDataTyCon DataTyConPair) + [kRegion, kData, kData] + (Just [ ( NamePrimDaCon PrimDaConPr + , [tIx kData 1, tIx kData 0]) ]) + + -- List + , DataDef + (NameDataTyCon DataTyConList) + [kRegion, 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 + + +-- | 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 + -> tFun tBoolU (tAlloc tR) + (tBot kClosure) + $ tBool tR + + -- N# + NamePrimDaCon PrimDaConNatU + -> Just $ tForall kRegion $ \tR + -> tFun tNatU (tAlloc tR) + (tBot kClosure) + $ tNat tR + + -- I# + NamePrimDaCon PrimDaConIntU + -> Just $ tForall kRegion $ \tR + -> tFun tIntU (tAlloc tR) + (tBot kClosure) + $ tInt tR + + -- Unit + NamePrimDaCon PrimDaConUnit + -> Just $ tUnit + + -- Pair + NamePrimDaCon PrimDaConPr + -> Just $ tForalls [kRegion, kData, kData] $ \[tR, tA, tB] + -> tFun tA (tBot kEffect) + (tBot kClosure) + $ tFun tB (tSum kEffect [tAlloc tR]) + (tSum kClosure [tDeepUse tA]) + $ tPair tR tA tB + + -- List + NamePrimDaCon PrimDaConNil + -> Just $ tForalls [kRegion, kData] $ \[tR, tA] + -> tFun tUnit (tAlloc tR) + (tBot kClosure) + $ tList tR tA + + NamePrimDaCon PrimDaConCons + -> Just $ tForalls [kRegion, kData] $ \[tR, tA] + -> tFun tA (tBot kEffect) + (tBot kClosure) + $ tFun (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 + 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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Lite/Layout.hs @@ -0,0 +1,145 @@ + +-- | 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 `mod` 8 == 0 -> Just $ fromIntegral $ bits `div` 8 + | otherwise -> Nothing + + PrimTyConFloat bits + | bits `mod` 8 == 0 -> Just $ fromIntegral $ bits `div` 8 + | otherwise -> 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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Lite/Name.hs @@ -0,0 +1,263 @@ + +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.PrimOp +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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Lite/Profile.hs @@ -0,0 +1,76 @@ + +-- | 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 + + -- As we allow unboxed instantiation, + -- this isn't needed by the compliance check. + , profileTypeIsUnboxed = const False } + + +features :: Features +features + = Features + { featuresUntrackedEffects = False + , featuresUntrackedClosures = False + , featuresPartialPrims = False + , featuresPartialApplication = True + , featuresGeneralApplication = True + , featuresNestedFunctions = True + , featuresLazyBindings = 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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt.hs @@ -0,0 +1,50 @@ + +-- | Disciple Core Salt. +-- +-- This is what happens to 'C' when you leave it out in the sun for too long. +-- +-- Salt is a fragment of System-F2 that contains just those features that +-- can be easily mapped onto C or LLVM code. It has functions, case +-- expressions and primops, but no partial application, data types, or nested +-- functions. All operations on algebraic data need to have been expanded to +-- primitive store operations. +-- +-- Salt exposes raw store and control primops, so its possible for functions +-- written directly in Salt to corrupt the heap (if they are wrong). +-- +module DDC.Core.Salt + ( -- * Language profile + profile + + -- * Conversion + , seaOfSaltModule + , Error(..) + + -- * Names + , Name (..) + , PrimTyCon (..) + , PrimOp (..) + + , PrimCast (..) + , primCastPromoteIsValid + , primCastTruncateIsValid + + , PrimCall (..) + + , PrimControl (..) + + , PrimStore (..) + + , PrimArith (..) + + -- * Name parsing + , readName + + -- * Program lexing + , lexModuleString + , lexExpString) + +where +import DDC.Core.Salt.Name +import DDC.Core.Salt.Profile +import DDC.Core.Salt.Convert diff --git a/DDC/Core/Salt/Compounds.hs b/DDC/Core/Salt/Compounds.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Compounds.hs @@ -0,0 +1,72 @@ + +module DDC.Core.Salt.Compounds + ( tVoid + , tBool, xBool + , tNat, xNat + , tInt, xInt + , tWord, xWord + , tTag, xTag + , tObj + , tAddr + , tPtr, takeTPtr + , tString) +where +import DDC.Core.Salt.Name +import DDC.Core.Exp +import DDC.Core.DaCon +import DDC.Type.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 (mkDaConAlg (NameLitBool b) tBool) + + +xNat :: a -> Integer -> Exp a Name +xNat a i = XCon a (mkDaConAlg (NameLitNat i) tNat) + + +xInt :: a -> Integer -> Exp a Name +xInt a i = XCon a (mkDaConAlg (NameLitInt i) tInt) + + +xWord :: a -> Integer -> Int -> Exp a Name +xWord a i bits = XCon a (mkDaConAlg (NameLitWord i bits) (tWord bits)) + + +xTag :: a -> Integer -> Exp a Name +xTag a i = XCon a (mkDaConAlg (NameLitTag i) tTag) + diff --git a/DDC/Core/Salt/Convert.hs b/DDC/Core/Salt/Convert.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Convert.hs @@ -0,0 +1,651 @@ +-- | Convert the Disciple Core Salt into to real C code. +-- +-- The input module needs to be: +-- well typed, +-- fully named with no deBruijn indices, +-- have all functions defined at top-level, +-- a-normalised, +-- have a control-transfer primop at the end of every function body +-- (these are added by DDC.Core.Salt.Convert.Transfer) +-- +module DDC.Core.Salt.Convert + ( Error (..) + , seaOfSaltModule) +where +import DDC.Core.Salt.Convert.Prim +import DDC.Core.Salt.Convert.Base +import DDC.Core.Salt.Convert.Type +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 as C +import DDC.Core.Exp +import DDC.Type.Env (KindEnv, TypeEnv) +import DDC.Base.Pretty +import DDC.Control.Monad.Check (throw, result) +import qualified DDC.Type.Env as Env +import qualified Data.Map as Map +import Control.Monad +import Data.Maybe + + +-- | Convert a Disciple Core Salt module to C-source text. +seaOfSaltModule + :: Show a + => Bool -- ^ Whether to include top-level include macros. + -> Platform -- ^ Target platform specification + -> Module a Name -- ^ Module to convert. + -> Either (Error a) Doc + +seaOfSaltModule withPrelude pp mm + = {-# SCC seaOfSaltModule #-} + result $ convModuleM withPrelude pp mm + + +-- Module --------------------------------------------------------------------- +-- | Convert a Salt module to C source text. +convModuleM :: Show a => Bool -> Platform -> Module a Name -> ConvertM a Doc +convModuleM withPrelude pp mm@(ModuleCore{}) + | ([LRec bxs], _) <- splitXLets $ moduleBody mm + = do + -- Top-level includes --------- + let cIncludes + | not withPrelude + = [] + + | otherwise + = [ text "#include \"Runtime.h\"" + , text "#include \"Primitive.h\"" + , empty ] + + -- Import external symbols ---- + let nts = Map.elems $ C.moduleImportTypes mm + docs <- mapM (uncurry $ convFunctionTypeM Env.empty) nts + let cExterns + | not withPrelude + = [] + + | otherwise + = [ text "extern " <> doc <> semi | doc <- docs ] + + -- RTS def -------------------- + -- If this is the main module then we need to declare + -- the global RTS state. + let cGlobals + | not withPrelude + = [] + + | isMainModule mm + = [ text "addr_t _DDC_Runtime_heapTop = 0;" + , text "addr_t _DDC_Runtime_heapMax = 0;" + , empty ] + + | otherwise + = [ text "extern addr_t _DDC_Runtime_heapTop;" + , text "extern addr_t _DDC_Runtime_heapMax;" + , empty ] + + -- Super-combinator definitions. + let kenv = Env.fromTypeMap $ Map.map snd $ moduleImportKinds mm + let tenv = Env.fromTypeMap $ Map.map snd $ moduleImportTypes mm + cSupers <- mapM (uncurry (convSuperM pp kenv tenv)) bxs + + -- Paste everything together + return $ vcat + $ cIncludes + ++ cExterns + ++ cGlobals + ++ cSupers + + | otherwise + = throw $ ErrorNoTopLevelLetrec mm + + +-- Super definition ----------------------------------------------------------- +-- | Convert a super to C source text. +convSuperM + :: Show a + => Platform + -> KindEnv Name + -> TypeEnv Name + -> Bind Name + -> Exp a Name + -> ConvertM a Doc + +convSuperM pp kenv0 tenv0 bTop xx + = convSuperM' pp kenv0 tenv0 bTop [] xx + +convSuperM' pp kenv tenv bTop bsParam xx + -- Enter into type abstractions, + -- adding the bound name to the environment. + | XLAM _ b x <- xx + = convSuperM' pp (Env.extend b kenv) tenv bTop bsParam x + + -- Enter into value abstractions, + -- remembering that we're now in a function that has this parameter. + | XLam _ b x <- xx + = convSuperM' pp kenv (Env.extend b tenv) bTop (bsParam ++ [b]) x + + -- Convert the function body. + | BName (NameVar nTop) tTop <- bTop + = do + + -- Convert the function name. + let nTop' = text $ sanitizeGlobal nTop + let (_, tResult) = takeTFunArgResult $ eraseTForalls tTop + + -- Convert function parameters. + bsParam' <- mapM (convBind kenv tenv) $ filter keepBind bsParam + + -- Convert result type. + tResult' <- convTypeM kenv $ eraseWitArg tResult + + -- Emit variable definitions for all the value binders in the code. + let (_, bsVal) = collectBinds xx + dsVal <- liftM catMaybes $ mapM (makeVarDecl kenv) + $ filter keepBind bsVal + + -- Convert the body of the function. + -- We pass in ContextTop to say we're at the top-level + -- of the function, so the block must explicitly pass + -- control in the final statement. + xBody' <- convBlockM ContextTop pp kenv tenv xx + + return $ vcat + [ tResult' -- Function header. + <+> nTop' + <+> parenss bsParam' + , lbrace + , indent 8 $ vcat dsVal -- Variable declarations. + , empty + , indent 8 xBody' -- Function body. + , rbrace + , empty] + + | otherwise + = throw $ ErrorFunctionInvalid xx + + +-- | Make a variable declaration for this binder. +makeVarDecl :: KindEnv Name -> Bind Name -> ConvertM a (Maybe Doc) +makeVarDecl kenv bb + = case bb of + BNone{} + -> return Nothing + + BName (NameVar n) t + -> do t' <- convTypeM kenv t + let n' = text $ sanitizeLocal n + return $ Just (t' <+> n' <+> equals <+> text "0" <> semi) + + _ -> throw $ ErrorParameterInvalid bb + + +-- | Remove witness arguments from the return type +eraseWitArg :: Type Name -> Type Name +eraseWitArg tt + = case tt of + -- Distinguish between application of witnesses and ptr + TApp _ t2 + | Just (NamePrimTyCon PrimTyConPtr, _) <- takePrimTyConApps tt -> tt + | otherwise -> eraseWitArg t2 + + -- Pass through all other types + _ -> tt + + +-- | Ditch witness bindings +keepBind :: Bind Name -> Bool +keepBind bb + = case bb of + BName _ t + | tc : _ <- takeTApps t + , isWitnessType tc + -> False + + BNone{} -> False + _ -> True + + +-- | Convert a function parameter binding to C source text. +convBind :: KindEnv Name -> TypeEnv Name -> Bind Name -> ConvertM a Doc +convBind kenv _tenv b + = case b of + + -- Named variables binders. + BName (NameVar str) t + -> do t' <- convTypeM kenv t + return $ t' <+> (text $ sanitizeLocal str) + + _ -> throw $ ErrorParameterInvalid b + + +-- Blocks --------------------------------------------------------------------- +-- | What context we're doing this conversion in. +data Context + -- | Conversion at the top-level of a function. + -- The expresison being converted must eventually pass control. + = ContextTop + + -- | In a nested context, like in the right of a let-binding. + -- The expression should produce a value that we assign to this + -- variable. + | ContextNest (Bind Name) + deriving Show + + +-- | Check whether a context is nested. +isContextNest :: Context -> Bool +isContextNest cc + = case cc of + ContextNest{} -> True + _ -> False + + +-- | Convert an expression to a block of statements. +-- +-- If this expression defines a top-level function then the block +-- must end with a control transfer primop like return# or tailcall#. +-- +-- The `Context` tells us what do do when we get to the end of the block. +-- +convBlockM + :: Show a + => Context + -> Platform + -> KindEnv Name + -> TypeEnv Name + -> Exp a Name + -> ConvertM a Doc + +convBlockM context pp kenv tenv xx + = case xx of + + XApp{} + -- If we're at the top-level of a function body then the + -- last statement must explicitly pass control. + | ContextTop <- context + -> case takeXPrimApps xx of + Just (NamePrimOp p, xs) + | isControlPrim p || isCallPrim p + -> do x1 <- convPrimCallM pp kenv tenv p xs + return $ x1 <> semi + + _ -> throw $ ErrorBodyMustPassControl xx + + -- If we're in a nested context but the primop we're + -- calling doesn't return, and doesn't return a value, + -- then we can't assign it to the result var. + | ContextNest{} <- context + , Just (NamePrimOp p, xs) <- takeXPrimApps xx + , isControlPrim p || isCallPrim p + -> do x1 <- convPrimCallM pp kenv tenv p xs + return $ x1 <> semi + + _ + -- In a nested context with a BName binder, + -- assign the result value to the provided variable. + | isRValue xx + , ContextNest (BName n _) <- context + -> do xx' <- convRValueM pp kenv tenv xx + let n' = text $ sanitizeLocal (renderPlain $ ppr n) + return $ vcat + [ fill 12 n' <+> equals <+> xx' <> semi ] + + -- In a nested context with a BNone binder, + -- just drop the result on the floor. + | isRValue xx + , ContextNest (BNone _) <- context + -> do xx' <- convRValueM pp kenv tenv xx + return $ vcat + [ xx' <> semi ] + + -- Binding from a case-expression. + XLet _ (LLet LetStrict b x1@XCase{}) x2 + -> do + -- Convert the right hand side in a nested context. + -- The ContextNext holds the var to assign the result to. + x1' <- convBlockM (ContextNest b) pp kenv tenv x1 + + -- Convert the rest of the function. + let tenv' = Env.extend b tenv + x2' <- convBlockM context pp kenv tenv' x2 + + return $ vcat + [ x1' + , x2' ] + + -- Binding from an r-value. + XLet _ (LLet LetStrict b x1) x2 + -> do x1' <- convRValueM pp kenv tenv x1 + x2' <- convBlockM context pp kenv tenv x2 + + let dst = case b of + BName (NameVar n) _ + -> fill 12 (text $ sanitizeLocal n) <+> equals <> space + _ -> empty + + return $ vcat + [ dst <> x1' <> semi + , x2' ] + + -- Ditch letregions. + XLet _ (LLetRegions bs ws) x + -> let kenv' = Env.extends bs kenv + tenv' = Env.extends ws tenv + in convBlockM context pp kenv' tenv' x + + -- Case-expression. + -- Prettier printing for case-expression that just checks for failure. + XCase _ x [ AAlt (PData dc []) x1 + , AAlt PDefault xFail] + | isFailX xFail + , Just n <- takeNameOfDaCon dc + , Just n' <- convDaConName n + -> do + x' <- convRValueM pp kenv tenv x + x1' <- convBlockM context pp kenv tenv x1 + xFail' <- convBlockM context pp kenv tenv xFail + + return $ vcat + [ text "if" + <+> parens (x' <+> text "!=" <+> n') + <+> xFail' + , x1' ] + + -- Case-expression. + -- 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 + -> do x' <- convRValueM pp kenv tenv x + x1' <- convBlockM context pp kenv tenv x1 + x2' <- convBlockM context pp kenv tenv x2 + + return $ vcat + [ text "if" <> parens x' + , lbrace <> indent 7 x1' <> line <> rbrace + , text "else" + , lbrace <> indent 7 x2' <> line <> rbrace ] + + -- Case-expression. + -- In the general case we use the C-switch statement. + XCase _ x alts + -> do x' <- convRValueM pp kenv tenv x + alts' <- mapM (convAltM context pp kenv tenv) alts + + return $ vcat + [ text "switch" <+> parens x' + , lbrace <> indent 1 (vcat alts') + , rbrace ] + + -- Ditch casts. + XCast _ _ x + -> convBlockM context pp kenv tenv x + + _ -> throw $ ErrorBodyInvalid xx + + +-- | Check whether this primop passes control (and does not return). +isControlPrim :: PrimOp -> Bool +isControlPrim pp + = case pp of + PrimControl{} -> True + _ -> False + + +-- | Check whether this primop passes control (and returns). +isCallPrim :: PrimOp -> Bool +isCallPrim pp + = case pp of + PrimCall{} -> True + _ -> False + + +-- | Check whether this an application of the fail# primop. +isFailX :: Exp a Name -> Bool +isFailX (XApp _ (XVar _ (UPrim (NamePrimOp (PrimControl PrimControlFail)) _)) _) + = True +isFailX _ = False + + +-- Alt ------------------------------------------------------------------------ +-- | Convert a case alternative to C source text. +convAltM + :: Show a + => Context + -> Platform + -> KindEnv Name + -> TypeEnv Name + -> Alt a Name + -> ConvertM a Doc + +convAltM context pp kenv tenv aa + = let end + | isContextNest context = line <> text "break;" + | otherwise = empty + in case aa of + AAlt PDefault x1 + -> do x1' <- convBlockM context pp kenv tenv x1 + return $ vcat + [ text "default:" + , lbrace <> indent 5 (x1' <> end) + <> line + <> rbrace] + + AAlt (PData dc []) x1 + | Just n <- takeNameOfDaCon dc + , Just n' <- convDaConName n + -> do x1' <- convBlockM context pp kenv tenv x1 + return $ vcat + [ text "case" <+> n' <> colon + , lbrace <> indent 5 (x1' <> end) + <> line + <> rbrace] + + AAlt{} -> throw $ ErrorAltInvalid aa + + +-- | Convert a data constructor name to a pattern to use in a switch. +-- +-- Only integral-ish types can be used as patterns, for others +-- such as Floats we rely on the Lite transform to have expanded +-- 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 + + NameLitNat i -> Just $ integer i + + NameLitInt i -> Just $ integer i + + NameLitWord i bits + | elem bits [8, 16, 32, 64] + -> Just $ integer i + + NameLitTag i -> Just $ integer i + + _ -> Nothing + + +-- RValue --------------------------------------------------------------------- +-- | Convert an r-value to C source text. +convRValueM + :: Show a + => Platform + -> KindEnv Name + -> TypeEnv Name + -> Exp a Name + -> ConvertM a Doc + +convRValueM pp kenv tenv xx + = case xx of + + -- Plain variable. + XVar _ (UName n) + | NameVar str <- n + -> return $ text $ sanitizeLocal str + + -- Literals + XCon _ dc + | DaConNamed n <- daConName dc + -> case n of + NameLitBool 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" + _ -> throw $ ErrorRValueInvalid xx + + -- Primop application. + XApp{} + | Just (NamePrimOp p, args) <- takeXPrimApps xx + -> convPrimCallM pp kenv tenv p args + + -- Super application. + XApp{} + | Just (XVar _ (UName n), args) <- takeXApps xx + , NameVar nTop <- n + -> do let nTop' = sanitizeGlobal nTop + + -- Ditch type and witness arguments + args' <- mapM (convRValueM pp kenv tenv) + $ filter keepFunArgX args + + return $ text nTop' <> parenss args' + + -- Type argument. + XType t + -> do t' <- convTypeM kenv t + return $ t' + + -- Ditch casts. + XCast _ _ x + -> convRValueM pp kenv tenv x + + _ -> throw $ ErrorRValueInvalid xx + + +-- | Check if some expression is an r-value, +-- meaning a variable, constructor, application or cast of one. +isRValue :: Exp a Name -> Bool +isRValue xx + = case xx of + XVar{} -> True + XCon{} -> True + XApp{} -> True + XCast _ _ x -> isRValue x + _ -> False + + +-- | We don't need to pass types and witnesses to top-level supers. +keepFunArgX :: Exp a n -> Bool +keepFunArgX xx + = case xx of + XType{} -> False + XWitness{} -> False + _ -> True + + +-- PrimCalls ------------------------------------------------------------------ +-- | Convert a call to a primitive operator to C source text. +convPrimCallM + :: Show a + => Platform + -> KindEnv Name + -> TypeEnv Name + -> PrimOp + -> [Exp a Name] -> ConvertM a Doc + +convPrimCallM pp kenv tenv p xs + = case p of + + -- Binary arithmetic primops. + PrimArith op + | [XType _t, x1, x2] <- xs + , Just op' <- convPrimArith2 op + -> do x1' <- convRValueM pp kenv tenv x1 + x2' <- convRValueM pp kenv tenv x2 + return $ parens (x1' <+> op' <+> x2') + + + -- Cast primops. + PrimCast PrimCastPromote + | [XType tDst, XType tSrc, x1] <- xs + , Just (NamePrimTyCon tcSrc, _) <- takePrimTyConApps tSrc + , Just (NamePrimTyCon tcDst, _) <- takePrimTyConApps tDst + , primCastPromoteIsValid pp tcSrc tcDst + -> do tDst' <- convTypeM kenv tDst + x1' <- convRValueM pp kenv tenv x1 + return $ parens tDst' <> parens x1' + + PrimCast PrimCastTruncate + | [XType tDst, XType tSrc, x1] <- xs + , Just (NamePrimTyCon tcSrc, _) <- takePrimTyConApps tSrc + , Just (NamePrimTyCon tcDst, _) <- takePrimTyConApps tDst + , primCastTruncateIsValid pp tcSrc tcDst + -> do tDst' <- convTypeM kenv tDst + x1' <- convRValueM pp kenv tenv x1 + return $ parens tDst' <> parens x1' + + + -- Control primops. + PrimControl PrimControlReturn + | [XType _t, x1] <- xs + -> do x1' <- convRValueM pp kenv tenv x1 + return $ text "return" <+> x1' + + PrimControl PrimControlFail + | [XType _t] <- xs + -> do return $ text "_FAIL()" + + + -- Call primops. + -- ISSUE #261: Implement tailcalls in the C backend. + -- This doesn't actually do a tailcall. + -- For straight tail-recursion we need to overwrite the parameters + -- with the new arguments and jump back to the start of the function. + PrimCall (PrimCallTail arity) + | xFunTys : xsArgs <- drop (arity + 1) xs + , Just (xFun, _) <- takeXApps xFunTys + , XVar _ (UName n) <- xFun + , NameVar nTop <- n + -> do let nFun' = text $ sanitizeGlobal nTop + xsArgs' <- mapM (convRValueM pp kenv tenv) xsArgs + return $ text "return" <+> nFun' <> parenss xsArgs' + + + -- Store primops. + PrimStore op + -> do let op' = convPrimStore op + xs' <- mapM (convRValueM pp kenv tenv) + $ filter (keepPrimArgX kenv) xs + return $ op' <> parenss xs' + + _ -> throw $ ErrorPrimCallInvalid p xs + + +-- | Ditch away region arguments. +keepPrimArgX :: KindEnv Name -> Exp a Name -> Bool +keepPrimArgX kenv xx + = case xx of + XType (TVar u) + | Just k <- Env.lookup u kenv + -> isDataKind k + + XWitness{} -> False + _ -> True + + +parenss :: [Doc] -> Doc +parenss xs = encloseSep lparen rparen (comma <> space) xs + diff --git a/DDC/Core/Salt/Convert/Base.hs b/DDC/Core/Salt/Convert/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Convert/Base.hs @@ -0,0 +1,140 @@ + +-- | Things that can go wrong when converting Disciple Core Salt to C-code. +-- +-- If we get any of these then the program doesn't map onto the features +-- of the C-language. +module DDC.Core.Salt.Convert.Base + ( ConvertM + , Error(..)) +where +import DDC.Core.Salt.Name +import DDC.Core.Pretty +import DDC.Core.Module +import DDC.Core.Exp +import qualified DDC.Control.Monad.Check as G + + +-- | Conversion Monad +type ConvertM a x = G.CheckM (Error a) x + + +-- | Things that can go wrong when converting Disciple Core Salt to +-- to C source text. +data Error a + -- | Variable is not in scope. + = ErrorUndefined + { errorVar :: Bound Name } + + -- | Binder has BNone form, binds no variable. + | ErrorBindNone + + -- | Modules must contain a top-level letrec. + | ErrorNoTopLevelLetrec + { errorModule :: Module a Name } + + -- | A local variable has an invalid type. + | ErrorTypeInvalid + { errorType :: Type Name } + + -- | An invalid function definition. + | ErrorFunctionInvalid + { errorExp :: Exp a Name } + + -- | An invalid function parameter. + | ErrorParameterInvalid + { errorBind :: Bind Name } + + -- | An invalid function body. + | ErrorBodyInvalid + { errorExp :: Exp a Name } + + -- | A function body that does not explicitly pass control. + | ErrorBodyMustPassControl + { errorExp :: Exp a Name } + + -- | An invalid statement. + | ErrorStmtInvalid + { errorExp :: Exp a Name } + + -- | An invalid alternative. + | ErrorAltInvalid + { errorAlt :: Alt a Name } + + -- | An invalid RValue. + | ErrorRValueInvalid + { errorExp :: Exp a Name } + + -- | An invalid function argument. + | ErrorArgInvalid + { errorExp :: Exp a Name } + + -- | An invalid primitive call + | ErrorPrimCallInvalid + { errorPrimOp :: PrimOp + , errorArgs :: [Exp a Name]} + deriving Show + + +instance (Show a, Pretty a) => Pretty (Error a) where + ppr err + = case err of + ErrorUndefined var + -> vcat [ text "Undefined variable" <+> ppr var ] + + ErrorBindNone + -> vcat [ text "Found a _ binder"] + + ErrorNoTopLevelLetrec _mm + -> vcat [ text "Module does not have a top-level letrec." ] + + ErrorTypeInvalid tt + -> vcat [ text "Invalid type for local variable." + , empty + , text "with:" <+> align (ppr tt) ] + + ErrorFunctionInvalid xx + -> vcat [ text "Invalid function definition." + , empty + , text "with:" <+> align (ppr xx) ] + + ErrorParameterInvalid b + -> vcat [ text "Invalid function parameter." + , empty + , text "with:" <+> align (ppr b) ] + + ErrorBodyInvalid xx + -> vcat [ text "Invalid function body." + , empty + , text "with:" <+> align (ppr xx) ] + + ErrorBodyMustPassControl xx + -> vcat [ text "The final statement in a function must pass control" + , text " You need an explicit return# or fail#." + , empty + , text "this isn't one: " <+> align (ppr xx) ] + + ErrorStmtInvalid xx + -> vcat [ text "Invalid statement." + , empty + , text "with:" <+> align (ppr xx) ] + + ErrorAltInvalid xx + -> vcat [ text "Invalid case-alternative." + , empty + , text "with:" <+> align (ppr xx) ] + + ErrorRValueInvalid xx + -> vcat [ text "Invalid R-value." + , empty + , text "with:" <+> align (ppr xx) ] + + ErrorArgInvalid xx + -> vcat [ text "Invalid argument." + , empty + , text "with:" <+> align (ppr xx) ] + + ErrorPrimCallInvalid p xs + -> vcat [ text "Invalid primCall." + , text " primitive: " <+> align (ppr p) + , text " args: " <+> align (ppr xs) ] + diff --git a/DDC/Core/Salt/Convert/Init.hs b/DDC/Core/Salt/Convert/Init.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Convert/Init.hs @@ -0,0 +1,73 @@ + +-- | Adding code to initialise the runtime system. +module DDC.Core.Salt.Convert.Init + (initRuntime) +where +import DDC.Core.Salt.Compounds +import DDC.Core.Salt.Runtime +import DDC.Core.Salt.Name +import DDC.Core.Module +import DDC.Core.Exp +import Data.List + + +-- | If this it the Main module, +-- then add code to the 'main' function to initialise the runtime system. +-- +-- Returns Nothing if this is the Main module, +-- but there is no main function. +initRuntime + :: Config + -> Module a Name + -> Maybe (Module a Name) + +initRuntime config mm@ModuleCore{} + | isMainModule mm + = case initRuntimeTopX config (moduleBody mm) of + Nothing -> Nothing + Just x' -> Just $ mm { moduleBody = x'} + + | otherwise + = Just mm + + +-- | Takes the top-level let-bindings of amodule +-- and add code to initialise the runtime system. +initRuntimeTopX :: Config -> Exp a Name -> Maybe (Exp a Name) +initRuntimeTopX config xx + | XLet a (LRec bxs) x2 <- xx + , Just (bMain, xMain) <- find (isMainBind . fst) bxs + , bxs_cut <- filter (not . isMainBind . fst) bxs + = let + -- Initial size of the heap. + bytes = configHeapSize config + + xMain' = hackBodyX (XLet a (LLet LetStrict (BNone tVoid) + (xCreate a bytes))) + xMain + + in Just $ XLet a (LRec $ bxs_cut ++ [(bMain, xMain')]) x2 + + -- This was supposed to be the main Module, + -- but there was no 'main' function for the program entry point. + | otherwise + = Nothing + + +-- | Apply a worker to the body of some function. +-- Enters into enclosing lambdas. +hackBodyX :: (Exp a n -> Exp a n) -> Exp a n -> Exp a n +hackBodyX f xx + = case xx of + XLAM a b x -> XLAM a b $ hackBodyX f x + XLam a b x -> XLam a b $ hackBodyX f x + _ -> f xx + + +-- | Check whether this is the bind for the 'main' function. +isMainBind :: Bind Name -> Bool +isMainBind bb + = case bb of + (BName (NameVar "main") _) -> True + _ -> False + diff --git a/DDC/Core/Salt/Convert/Prim.hs b/DDC/Core/Salt/Convert/Prim.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Convert/Prim.hs @@ -0,0 +1,82 @@ + +-- | Pretty printers for primitive type and operator names. +module DDC.Core.Salt.Convert.Prim + ( convPrimTyCon + , convPrimArith2 + , convPrimStore) +where +import DDC.Core.Salt.Name +import DDC.Base.Pretty + + +-- | Convert a primitive type constructor to C source text. +convPrimTyCon :: PrimTyCon -> Maybe Doc +convPrimTyCon tc + = case tc of + PrimTyConVoid -> Just $ text "void" + PrimTyConBool -> Just $ text "bool_t" + PrimTyConNat -> Just $ text "nat_t" + PrimTyConInt -> Just $ text "int_t" + PrimTyConWord bits -> Just $ text "uint" <> int bits <> text "_t" + 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 + + +-- | Convert an binary arithmetic primop name to C source text. +convPrimArith2 :: PrimArith -> Maybe Doc +convPrimArith2 pp + = case pp of + -- arithmetic + PrimArithNeg -> Just $ text "-" + PrimArithAdd -> Just $ text "+" + PrimArithSub -> Just $ text "-" + PrimArithMul -> Just $ text "*" + PrimArithDiv -> Just $ text "/" + PrimArithRem -> Just $ text "%" + + -- comparison + PrimArithEq -> Just $ text "==" + PrimArithNeq -> Just $ text "!=" + PrimArithGt -> Just $ text ">" + PrimArithGe -> Just $ text ">=" + PrimArithLt -> Just $ text "<" + PrimArithLe -> Just $ text "<=" + + -- boolean + PrimArithAnd -> Just $ text "&&" + PrimArithOr -> Just $ text "||" + + -- bitwise + PrimArithShl -> Just $ text "<<" + PrimArithShr -> Just $ text ">>" + PrimArithBAnd -> Just $ text "&" + PrimArithBOr -> Just $ text "|" + PrimArithBXOr -> Just $ text "^" + + +-- | Convert a store primop name to C source text. +convPrimStore :: PrimStore -> Doc +convPrimStore pp + = case pp of + PrimStoreSize -> text "_SIZE" + PrimStoreSize2 -> text "_SIZE2" + PrimStoreCreate -> text "_CREATE" + PrimStoreCheck -> text "_CHECK" + PrimStoreRecover -> text "_RECOVER" + PrimStoreAlloc -> text "_ALLOC" + PrimStoreRead -> text "_READ" + PrimStoreWrite -> text "_WRITE" + PrimStorePlusAddr -> text "_PLUSADDR" + PrimStoreMinusAddr -> text "_MINUSADDr" + PrimStorePeek -> text "_PEEK" + PrimStorePoke -> text "_POKE" + PrimStorePlusPtr -> text "_PLUSPTR" + PrimStoreMinusPtr -> text "_MINUSPTR" + PrimStoreMakePtr -> text "_MAKEPTR" + PrimStoreTakePtr -> text "_TAKEPTR" + PrimStoreCastPtr -> text "_CASTPTR" + + diff --git a/DDC/Core/Salt/Convert/Type.hs b/DDC/Core/Salt/Convert/Type.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Convert/Type.hs @@ -0,0 +1,82 @@ + +module DDC.Core.Salt.Convert.Type + ( convTypeM + , convFunctionTypeM) +where +import DDC.Core.Salt.Convert.Prim +import DDC.Core.Salt.Convert.Base +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.Type.Env (KindEnv) +import DDC.Base.Pretty +import DDC.Control.Monad.Check (throw) +import qualified DDC.Type.Env as Env + + +-- Type ----------------------------------------------------------------------- +-- | Convert a Salt type to C source text. +-- This is used to convert the types of function parameters and locally +-- defined variables. It only handles non-function types, as we don't +-- directly support higher-order functions or partial application in Salt. +convTypeM :: KindEnv Name -> Type Name -> ConvertM a Doc +convTypeM kenv tt + = case tt of + TVar u + -> case Env.lookup u kenv of + Nothing + -> throw $ ErrorUndefined u + + Just k + | isDataKind k -> return $ text "Obj*" + | otherwise + -> throw $ ErrorTypeInvalid tt + + TCon{} + | TCon (TyConBound (UPrim (NamePrimTyCon tc) _) _) <- tt + , Just doc <- convPrimTyCon tc + -> return doc + + | TCon (TyConBound (UPrim NameObjTyCon _) _) <- tt + -> return $ text "Obj" + + + TApp{} + | Just (NamePrimTyCon PrimTyConPtr, [_, t2]) <- takePrimTyConApps tt + -> do t2' <- convTypeM kenv t2 + return $ t2' <> text "*" + + TForall b t + -> convTypeM (Env.extend b kenv) t + + _ -> throw $ ErrorTypeInvalid tt + + +-- | Convert a Salt function type to a C source prototype. +convFunctionTypeM + :: KindEnv Name + -> QualName Name -- ^ Function name. + -> Type Name -- ^ Function type. + -> ConvertM a Doc + +convFunctionTypeM kenv nFunc tFunc + | TForall b t' <- tFunc + = convFunctionTypeM (Env.extend b kenv) nFunc t' + + | otherwise + = do -- Qualifiers aren't supported yet. + let QualName _ n = nFunc + let nFun' = text $ sanitizeGlobal (renderPlain $ ppr n) + + let (tsArgs, tResult) = takeTFunArgResult tFunc + + tsArgs' <- mapM (convTypeM kenv) tsArgs + tResult' <- convTypeM kenv tResult + + return $ tResult' <+> nFun' <+> parenss tsArgs' + + +parenss :: [Doc] -> Doc +parenss xs = encloseSep lparen rparen (comma <> space) xs diff --git a/DDC/Core/Salt/Env.hs b/DDC/Core/Salt/Env.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Env.hs @@ -0,0 +1,287 @@ + +-- | Types of Disciple Core Salt primops. +module DDC.Core.Salt.Env + ( primDataDefs + , primKindEnv + , primTypeEnv + , typeOfPrimCall + , typeOfPrimStore + , typeIsUnboxed) +where +import DDC.Core.Salt.Compounds +import DDC.Core.Salt.Name +import DDC.Type.DataDef +import DDC.Type.Compounds +import DDC.Type.Predicates +import DDC.Type.Exp +import DDC.Type.Env (Env) +import qualified DDC.Type.Env as Env + + +-- DataDefs ------------------------------------------------------------------- +-- | Data type definitions for: +-- +-- > 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#) +-- +primDataDefs :: DataDefs Name +primDataDefs + = fromListDataDefs + -- Bool + [ DataDef + (NamePrimTyCon PrimTyConBool) + [] + (Just [ (NameLitBool True, []) + , (NameLitBool False, []) ]) + -- Nat + , DataDef (NamePrimTyCon PrimTyConNat) [] Nothing + + -- Int + , DataDef (NamePrimTyCon PrimTyConInt) [] Nothing + + -- Tag + , DataDef (NamePrimTyCon PrimTyConTag) [] Nothing + + -- Word 8, 16, 32, 64 + , DataDef (NamePrimTyCon (PrimTyConWord 8)) [] Nothing + , DataDef (NamePrimTyCon (PrimTyConWord 16)) [] Nothing + , DataDef (NamePrimTyCon (PrimTyConWord 32)) [] Nothing + , DataDef (NamePrimTyCon (PrimTyConWord 64)) [] Nothing + + -- Float 32, 64 + , DataDef (NamePrimTyCon (PrimTyConFloat 32)) [] Nothing + , DataDef (NamePrimTyCon (PrimTyConFloat 64)) [] Nothing + ] + + +-- Kinds ---------------------------------------------------------------------- +-- | Kind environment containing kinds of primitive data types. +primKindEnv :: Env Name +primKindEnv = Env.setPrimFun kindOfName Env.empty + + +-- | Take the kind of a name, +-- or `Nothing` if this is not a type name. +kindOfName :: Name -> Maybe (Kind Name) +kindOfName nn + = case nn of + NameObjTyCon -> Just $ kData + NamePrimTyCon tc -> Just $ kindOfPrimTyCon tc + _ -> Nothing + + +-- | Take the kind of a primitive name. +-- +-- Returns `Nothing` if the name isn't primitive. +-- +kindOfPrimTyCon :: PrimTyCon -> Kind Name +kindOfPrimTyCon tc + = case tc of + PrimTyConVoid -> kData + PrimTyConBool -> kData + PrimTyConNat -> kData + PrimTyConInt -> kData + PrimTyConWord _ -> kData + PrimTyConFloat _ -> kData + PrimTyConAddr -> kData + PrimTyConPtr -> (kRegion `kFun` kData `kFun` kData) + PrimTyConTag -> kData + PrimTyConString -> kData + + +-- Types ---------------------------------------------------------------------- +-- | Type environment containing types of primitive operators. +primTypeEnv :: Env Name +primTypeEnv = Env.setPrimFun typeOfName Env.empty + + +-- | Take the type of a name, +-- or `Nothing` if this is not a value name. +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 + + +-- | Take the type of a primitive. +typeOfPrim :: PrimOp -> Type Name +typeOfPrim pp + = case pp of + PrimArith op -> typeOfPrimArith op + PrimCast cc -> typeOfPrimCast cc + PrimCall pc -> typeOfPrimCall pc + PrimControl pc -> typeOfPrimControl pc + 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 + 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 + PrimCastPromote + -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFunPE` t1 + + PrimCastTruncate + -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFunPE` t1 + + +-- PrimCall ------------------------------------------------------------------- +-- | Take the type of a primitive call operator. +typeOfPrimCall :: PrimCall -> Type Name +typeOfPrimCall cc + = case cc of + PrimCallTail arity -> makePrimCallType arity + + +-- | Make the type of the @callN#@ and @tailcallN@ primitives. +makePrimCallType :: Int -> Type Name +makePrimCallType arity + = let tSuper = foldr tFunPE + (TVar (UIx 0)) + (reverse [TVar (UIx i) | i <- [1..arity]]) + + tCall = foldr TForall (tSuper `tFunPE` 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 + + +------------------------------------------------------------------------------- +-- | Check if a type is an unboxed data type. +typeIsUnboxed :: Type Name -> Bool +typeIsUnboxed tt + = case tt of + TVar{} -> False + + -- All plain constructors are unboxed. + TCon (TyConBound _ k) + | isDataKind k -> True + + TCon _ -> False + + TForall _ t -> typeIsUnboxed t + + -- Pointers to objects are boxed. + TApp{} + | Just (_tR, tTarget) <- takeTPtr tt + , tTarget == tObj + -> False + + TApp t1 t2 + -> typeIsUnboxed t1 || typeIsUnboxed t2 + + TSum{} -> False + + diff --git a/DDC/Core/Salt/Name.hs b/DDC/Core/Salt/Name.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Name.hs @@ -0,0 +1,186 @@ + +-- | Names used in the Disciple Core Salt language profile. +module DDC.Core.Salt.Name + ( Name (..) + + -- * Primitive Type Constructors + , PrimTyCon (..) + , primTyConIsIntegral + , primTyConIsFloating + , primTyConIsUnsigned + , primTyConIsSigned + , primTyConWidth + + -- * Primitive Operators + , PrimOp (..) + + , PrimArith (..) + + , PrimCast (..) + , primCastPromoteIsValid + , primCastTruncateIsValid + + , PrimStore (..) + + , PrimCall (..) + + , PrimControl (..) + + -- * Name Parsing + , readName + + -- * Name Sanitisation + , sanitizeName + , sanitizeGlobal + , sanitizeLocal) +where +import DDC.Core.Salt.Name.Sanitize +import DDC.Core.Salt.Name.PrimTyCon +import DDC.Core.Salt.Name.PrimOp +import DDC.Core.Salt.Name.Lit +import DDC.Base.Pretty +import Data.Typeable +import Data.Char +import Data.List +import Control.DeepSeq + +-- | Names of things used in Disciple Core Salt. +data Name + -- | A type or value variable. + = NameVar String + + -- | Constructor names. + | NameCon 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 + + -- | A @WordN#@ literal, of the given width. + | NameLitWord Integer Int + deriving (Eq, Ord, Show, Typeable) + + +instance NFData Name where + rnf name + = case name of + NameVar s -> 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 + + +instance Pretty Name where + ppr nn + = case nn of + NameVar n -> text n + NameCon n -> text n + 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 "#" + + +-- | Read the name of a variable, constructor or literal. +readName :: String -> Maybe Name +readName str + -- Obj + | str == "Obj" + = Just $ NameObjTyCon + + -- PrimTyCon + | Just p <- readPrimTyCon str + = Just $ NamePrimTyCon p + + -- PrimArith + | Just p <- readPrimArith str + = Just $ NamePrimOp $ PrimArith p + + -- PrimCast + | Just p <- readPrimCast str + = Just $ NamePrimOp $ PrimCast p + + -- PrimCall + | Just p <- readPrimCall str + = Just $ NamePrimOp $ PrimCall p + + -- PrimControl + | Just p <- readPrimControl str + = Just $ NamePrimOp $ PrimControl p + + -- PrimStore + | Just p <- readPrimStore str + = Just $ NamePrimOp $ PrimStore p + + -- Literal void + | str == "V#" + = Just $ NameLitVoid + + -- Literal Nats + | Just val <- readLitPrimNat str + = Just $ NameLitNat val + + -- Literal Ints + | Just val <- readLitPrimInt str + = Just $ NameLitInt val + + -- Literal Tags + | Just rest <- stripPrefix "TAG" str + , (ds, "#") <- span isDigit rest + = Just $ NameLitTag (read ds) + + -- 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 + + -- Constructors. + | c : _ <- str + , isUpper c + = Just $ NameVar str + + -- Variables. + | c : _ <- str + , isLower c + = Just $ NameVar str + + | otherwise + = Nothing + diff --git a/DDC/Core/Salt/Name/Lit.hs b/DDC/Core/Salt/Name/Lit.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Name/Lit.hs @@ -0,0 +1,86 @@ + +-- | Reading literal values. +module DDC.Core.Salt.Name.Lit + ( readLitInteger + , readLitPrimNat + , readLitPrimInt + , readLitPrimWordOfBits) +where +import Data.List +import Data.Char + + +-- | Read a signed integer. +readLitInteger :: String -> Maybe Integer +readLitInteger [] = Nothing +readLitInteger str@(c:cs) + | '-' <- c + , all isDigit cs + = Just $ read str + + | all isDigit str + = 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 + = Just $ read ds + + | otherwise + = Nothing + + +-- | Read an integer with an explicit format specifier like @1234i#@. +readLitPrimInt :: String -> Maybe Integer +readLitPrimInt str1 + | '-' : str2 <- str1 + , (ds, "i#") <- span isDigit str2 + , not $ null ds + = Just $ read ds + + | (ds, "i#") <- span isDigit str1 + , not $ null ds + = Just $ read ds + + | otherwise + = Nothing + + +-- | Read a word with an explicit format speficier. +readLitPrimWordOfBits :: String -> Maybe (Integer, Int) +readLitPrimWordOfBits 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 + , not $ null bs + , bits <- read bs + , length ds <= bits + = Just (readBinary ds, bits) + + -- decimal like 1234w32# + | (ds, str2) <- span isDigit str1 + , not $ null ds + , Just str3 <- stripPrefix "w" str2 + , (bs, "#") <- span isDigit str3 + , not $ null bs + = Just (read ds, read bs) + + | otherwise + = Nothing + + +-- | Read a binary string as a number. +readBinary :: (Num a, Read a) => String -> a +readBinary digits + = foldl' (\ acc b -> if b then 2 * acc + 1 else 2 * acc) 0 + $ map (/= '0') digits diff --git a/DDC/Core/Salt/Name/PrimOp.hs b/DDC/Core/Salt/Name/PrimOp.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Name/PrimOp.hs @@ -0,0 +1,399 @@ + +-- | Primitive operator names. +-- +-- The arithmetic operators are also used by the Lite language. +module DDC.Core.Salt.Name.PrimOp + ( PrimOp (..) + , PrimArith (..), readPrimArith + , PrimCast (..), readPrimCast + , primCastPromoteIsValid + , primCastTruncateIsValid + , PrimStore (..), readPrimStore + , PrimCall (..), readPrimCall + , PrimControl (..), readPrimControl) +where +import DDC.Core.Salt.Name.PrimTyCon +import DDC.Core.Salt.Platform +import DDC.Base.Pretty +import Control.DeepSeq +import Data.Char +import Data.List + + +-- PrimOp --------------------------------------------------------------------- +-- | Primitive operators implemented directly by the machine or runtime system. +data PrimOp + -- | Arithmetic, logic, comparison and bit-wise operators. + = PrimArith PrimArith + + -- | Casting between numeric types. + | PrimCast PrimCast + + -- | Raw store access. + | PrimStore PrimStore + + -- | Special function calling conventions. + | PrimCall PrimCall + + -- | Non-functional control flow. + | PrimControl PrimControl + deriving (Eq, Ord, Show) + + +instance NFData PrimOp where + rnf op + = case op of + PrimArith pa -> rnf pa + PrimCast pc -> rnf pc + PrimStore ps -> rnf ps + PrimCall pc -> rnf pc + PrimControl pc -> rnf pc + + +instance Pretty PrimOp where + ppr pp + = case pp of + PrimArith op -> ppr op + PrimCast c -> ppr c + PrimStore p -> ppr p + PrimCall c -> ppr c + PrimControl c -> ppr c + + +-- PrimArith ------------------------------------------------------------------ +-- | Primitive arithmetic, logic, and comparison opretors. +-- We expect the backend/machine to be able to implement these directly. +-- +-- For the Shift Right operator, the type that it is used at determines +-- whether it is an arithmetic (with sign-extension) or logical +-- (no sign-extension) shift. +data PrimArith + -- numeric + = PrimArithNeg -- ^ Negation + | PrimArithAdd -- ^ Addition + | PrimArithSub -- ^ Subtraction + | PrimArithMul -- ^ Multiplication + | PrimArithDiv -- ^ Division + | PrimArithRem -- ^ Remainder + + -- comparison + | PrimArithEq -- ^ Equality + | PrimArithNeq -- ^ Negated Equality + | PrimArithGt -- ^ Greater Than + | PrimArithGe -- ^ Greater Than or Equal + | PrimArithLt -- ^ Less Than + | PrimArithLe -- ^ Less Than or Equal + + -- boolean + | PrimArithAnd -- ^ Boolean And + | PrimArithOr -- ^ Boolean Or + + -- bitwise + | PrimArithShl -- ^ Shift Left + | PrimArithShr -- ^ Shift Right + | PrimArithBAnd -- ^ Bit-wise And + | PrimArithBOr -- ^ Bit-wise Or + | PrimArithBXOr -- ^ Bit-wise eXclusive Or + deriving (Eq, Ord, Show) + +instance NFData PrimArith + +instance Pretty PrimArith where + ppr op + = let Just (_, n) = find (\(p, _) -> op == p) primArithNames + in (text n) + + +-- | Read a primitive operator. +readPrimArith :: String -> Maybe PrimArith +readPrimArith str + = case find (\(_, n) -> str == n) primArithNames of + Just (p, _) -> Just p + _ -> Nothing + + +-- | Names of primitve operators. +primArithNames :: [(PrimArith, String)] +primArithNames + = [ (PrimArithNeg, "neg#") + , (PrimArithAdd, "add#") + , (PrimArithSub, "sub#") + , (PrimArithMul, "mul#") + , (PrimArithDiv, "div#") + , (PrimArithRem, "rem#") + , (PrimArithEq , "eq#" ) + , (PrimArithNeq, "neq#") + , (PrimArithGt , "gt#" ) + , (PrimArithGe , "ge#" ) + , (PrimArithLt , "lt#" ) + , (PrimArithLe , "le#" ) + , (PrimArithAnd, "and#") + , (PrimArithOr , "or#" ) + , (PrimArithShl, "shl#") + , (PrimArithShr, "shr#") + , (PrimArithBAnd, "band#") + , (PrimArithBOr, "bor#") + , (PrimArithBXOr, "bxor#") ] + + + +-- PrimCast ------------------------------------------------------------------- +-- | Primitive cast between two types. +-- +-- The exact set of available casts is determined by the target platform. +-- For example, you can only promote a @Nat\#@ to a @Word32\#@ on a 32-bit +-- system. On a 64-bit system the @Nat\#@ type is 64-bits wide, so casting it +-- to a @Word32\#@ would be a truncation. +data PrimCast + -- | Promote a value to one of similar or larger width, + -- without loss of precision. + = PrimCastPromote + + -- | Truncate a value to a new width, + -- possibly losing precision. + | PrimCastTruncate + deriving (Eq, Ord, Show) + +instance NFData PrimCast + +instance Pretty PrimCast where + ppr c + = case c of + PrimCastPromote -> text "promote#" + PrimCastTruncate -> text "truncate#" + + +readPrimCast :: String -> Maybe PrimCast +readPrimCast str + = case str of + "promote#" -> Just PrimCastPromote + "truncate#" -> Just PrimCastTruncate + _ -> Nothing + + +-- | Check for a valid promotion primop. +primCastPromoteIsValid + :: Platform -- ^ Target platform. + -> PrimTyCon -- ^ Source type. + -> PrimTyCon -- ^ Destination type. + -> Bool + +primCastPromoteIsValid pp src dst + -- Promote unsigned to a larger or similar width. + | primTyConIsIntegral src, primTyConIsIntegral dst + , primTyConIsUnsigned src, primTyConIsUnsigned dst + , primTyConWidth pp dst >= primTyConWidth pp src + = True + + -- Promote signed to a larger or similar width. + | primTyConIsIntegral src, primTyConIsIntegral dst + , primTyConIsSigned src, primTyConIsSigned dst + , primTyConWidth pp dst >= primTyConWidth pp src + = True + + -- Promote unsigned to a strictly larger unsigned width. + | primTyConIsIntegral src, primTyConIsIntegral dst + , primTyConIsUnsigned src, primTyConIsSigned dst + , primTyConWidth pp dst > primTyConWidth pp src + = True + + | otherwise + = False + + +-- | Check for valid truncation primop. +primCastTruncateIsValid + :: Platform -- ^ Target platform. + -> PrimTyCon -- ^ Source type. + -> PrimTyCon -- ^ Destination type. + -> Bool + +primCastTruncateIsValid _pp src dst + | primTyConIsIntegral src + , primTyConIsIntegral dst + = True + + | otherwise + = False + + +-- PrimStore -------------------------------------------------------------------- +-- | Raw access to the store. +data PrimStore + -- Constants ------------------ + -- | Number of bytes needed to store a value of a primitive type. + = PrimStoreSize + + -- | Log2 of number of bytes need to store a value of a primitive type. + | PrimStoreSize2 + + -- Allocation ----------------- + -- | Create a heap of the given size. + -- This must be called before @alloc#@ below, and has global side effect. + -- Calling it twice in the same program is undefined. + | PrimStoreCreate + + -- | Check whether there are at least this many bytes still available + -- on the heap. + | PrimStoreCheck + + -- | Force a garbage collection to recover at least this many bytes. + | PrimStoreRecover + + -- | Allocate some space on the heap. + -- There must be enough space available, else undefined. + | PrimStoreAlloc + + -- Addr operations ------------ + -- | Read a value from the store at the given address and offset. + | PrimStoreRead + + -- | Write a value to the store at the given address and offset. + | PrimStoreWrite + + -- | Add an offset in bytes to an address. + | PrimStorePlusAddr + + -- | Subtract an offset in bytes from an address. + | PrimStoreMinusAddr + + -- Ptr operations ------------- + -- | Read a value from a pointer plus the given offset. + | PrimStorePeek + + -- | Write a value to a pointer plus the given offset. + | PrimStorePoke + + -- | Add an offset in bytes to a pointer. + | PrimStorePlusPtr + + -- | Subtract an offset in bytes from a pointer. + | PrimStoreMinusPtr + + -- | Convert an raw address to a pointer. + | PrimStoreMakePtr + + -- | Convert a pointer to a raw address. + | PrimStoreTakePtr + + -- | Cast between pointer types. + | PrimStoreCastPtr + deriving (Eq, Ord, Show) + +instance NFData PrimStore + +instance Pretty PrimStore where + ppr p + = case p of + PrimStoreSize -> text "size#" + PrimStoreSize2 -> text "size2#" + PrimStoreCreate -> text "create#" + PrimStoreCheck -> text "check#" + PrimStoreRecover -> text "recover#" + PrimStoreAlloc -> text "alloc#" + + PrimStoreRead -> text "read#" + PrimStoreWrite -> text "write#" + PrimStorePlusAddr -> text "plusAddr#" + PrimStoreMinusAddr -> text "minusAddr#" + + PrimStorePeek -> text "peek#" + PrimStorePoke -> text "poke#" + PrimStorePlusPtr -> text "plusPtr#" + PrimStoreMinusPtr -> text "minusPtr#" + PrimStoreMakePtr -> text "makePtr#" + PrimStoreTakePtr -> text "takePtr#" + PrimStoreCastPtr -> text "castPtr#" + + +readPrimStore :: String -> Maybe PrimStore +readPrimStore str + = case str of + "size#" -> Just PrimStoreSize + "size2#" -> Just PrimStoreSize2 + + "create#" -> Just PrimStoreCreate + "check#" -> Just PrimStoreCheck + "recover#" -> Just PrimStoreRecover + "alloc#" -> Just PrimStoreAlloc + + "read#" -> Just PrimStoreRead + "write#" -> Just PrimStoreWrite + "plusAddr#" -> Just PrimStorePlusAddr + "minusAddr#" -> Just PrimStoreMinusAddr + + "peek#" -> Just PrimStorePeek + "poke#" -> Just PrimStorePoke + "plusPtr#" -> Just PrimStorePlusPtr + "minusPtr#" -> Just PrimStoreMinusPtr + "makePtr#" -> Just PrimStoreMakePtr + "takePtr#" -> Just PrimStoreTakePtr + "castPtr#" -> Just PrimStoreCastPtr + + _ -> Nothing + + +-- PrimCall ------------------------------------------------------------------- +-- | Primitive ways of invoking a function, +-- where control flow returns back to the caller. +data PrimCall + -- | Tailcall a function + = PrimCallTail Int + deriving (Eq, Ord, Show) + + +instance NFData PrimCall where + rnf (PrimCallTail i) = rnf i + + +instance Pretty PrimCall where + ppr pc + = case pc of + PrimCallTail arity + -> text "tailcall" <> int arity <> text "#" + + +readPrimCall :: String -> Maybe PrimCall +readPrimCall str + + -- tailcallN# + | Just rest <- stripPrefix "tailcall" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n > 0 + = Just $ PrimCallTail n + + | otherwise + = Nothing + + +-- PrimControl ---------------------------------------------------------------- +-- | Primitive non-returning control flow. +data PrimControl + -- | Ungraceful failure -- just abort the program. + -- This is called on internal errors in the runtime system. + -- There is no further debugging info provided, so you'll need to + -- look at the stack trace to debug it. + = PrimControlFail + + -- | Return from the enclosing function with the given value. + | PrimControlReturn + deriving (Eq, Ord, Show) + +instance NFData PrimControl + +instance Pretty PrimControl where + ppr pc + = case pc of + PrimControlFail -> text "fail#" + PrimControlReturn -> text "return#" + + +readPrimControl :: String -> Maybe PrimControl +readPrimControl str + = case str of + "fail#" -> Just $ PrimControlFail + "return#" -> Just $ PrimControlReturn + _ -> Nothing + diff --git a/DDC/Core/Salt/Name/PrimTyCon.hs b/DDC/Core/Salt/Name/PrimTyCon.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Name/PrimTyCon.hs @@ -0,0 +1,188 @@ + +module DDC.Core.Salt.Name.PrimTyCon + ( PrimTyCon (..) + , readPrimTyCon + , primTyConIsIntegral + , primTyConIsFloating + , primTyConIsUnsigned + , primTyConIsSigned + , primTyConWidth) +where +import DDC.Base.Pretty +import DDC.Core.Salt.Platform +import Data.Char +import Data.List +import Control.DeepSeq + + +-- PrimTyCon ----------------------------------------------------------------- +-- | Primitive type constructors. +data PrimTyCon + -- | @Void#@ the Void type has no values. + = PrimTyConVoid + + -- | @Bool#@ unboxed booleans. + | PrimTyConBool + + -- | @Nat#@ natural numbers. + -- Big enough to count every addressable byte in the store. + | PrimTyConNat + + -- | @Int#@ signed integers. + | PrimTyConInt + + -- | @WordN#@ machine words of the given width. + | PrimTyConWord Int + + -- | @FloatN#@ floating point numbers of the given width. + | PrimTyConFloat Int + + -- | @Tag#@ data constructor tags. + | PrimTyConTag + + -- | @Addr#@ raw machine addresses. Unlike pointers below, + -- a raw @Addr#@ need not to refer to memory owned + -- by the current process. + | PrimTyConAddr + + -- | @Ptr#@ should point to a well-formed object owned by the + -- current process. + | PrimTyConPtr + + -- | @String#@ of UTF8 characters. + -- + -- These are primitive until we can define our own unboxed types. + | PrimTyConString + deriving (Eq, Ord, Show) + + +instance NFData PrimTyCon where + rnf tc + = case tc of + PrimTyConWord i -> rnf i + PrimTyConFloat i -> rnf i + _ -> () + + +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 "#" + PrimTyConTag -> text "Tag#" + PrimTyConAddr -> text "Addr#" + PrimTyConPtr -> text "Ptr#" + PrimTyConString -> text "String#" + + +-- | Read a primitive type constructor. +-- +-- Words are limited to 8, 16, 32, or 64 bits. +-- +-- 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 + + -- WordN# + | Just rest <- stripPrefix "Word" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , elem n [8, 16, 32, 64] + = Just $ PrimTyConWord n + + -- FloatN# + | Just rest <- stripPrefix "Float" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , elem n [32, 64] + = Just $ PrimTyConFloat n + + | otherwise + = Nothing + + +-- | Integral constructors are the ones that we can reasonably +-- convert from integers of the same size. +-- +-- These are @Bool#@ @Nat#@ @Int#@ @WordN#@ and @Tag#@. +-- +primTyConIsIntegral :: PrimTyCon -> Bool +primTyConIsIntegral tc + = case tc of + PrimTyConBool -> True + PrimTyConNat -> True + PrimTyConInt -> True + PrimTyConWord{} -> True + PrimTyConTag -> True + _ -> False + + +-- | Floating point constructors. +-- +-- These are @FloatN@. +primTyConIsFloating :: PrimTyCon -> Bool +primTyConIsFloating tc + = case tc of + PrimTyConFloat{} -> True + _ -> False + + +-- | Unsigned integral constructors. +-- +-- These are @Bool@ @Nat@ @WordN@ @Tag@. +primTyConIsUnsigned :: PrimTyCon -> Bool +primTyConIsUnsigned tc + = case tc of + PrimTyConBool -> True + PrimTyConNat -> True + PrimTyConWord{} -> True + PrimTyConTag -> True + _ -> False + +-- | Signed integral constructors. +-- +-- This is just @Int@. +primTyConIsSigned :: PrimTyCon -> Bool +primTyConIsSigned tc + = case tc of + PrimTyConInt -> True + PrimTyConFloat{} -> True + _ -> False + + +-- | Get the representation width of a primitive type constructor, +-- in bits. This is how much space it takes up in an object payload. +-- +-- Bools are representable with a single bit, but we unpack +-- them into a whole word. +-- +-- The abstract constructors `Void` and `String` have no width. +primTyConWidth :: Platform -> PrimTyCon -> Maybe Integer +primTyConWidth pp tc + = case tc of + PrimTyConBool -> Just $ 8 * platformNatBytes pp + PrimTyConNat -> Just $ 8 * platformNatBytes pp + PrimTyConInt -> 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 + + PrimTyConVoid -> Nothing + PrimTyConString -> Nothing + diff --git a/DDC/Core/Salt/Name/Sanitize.hs b/DDC/Core/Salt/Name/Sanitize.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Name/Sanitize.hs @@ -0,0 +1,73 @@ + +module DDC.Core.Salt.Name.Sanitize + ( sanitizeName + , sanitizeGlobal + , sanitizeLocal) +where +import Data.Maybe + + +-- | Rewrite the symbols in a name to make it safe to export as an external +-- symbol. For example, a names containing a '&' is prefixed with '_sym_' +-- and the '&' replzced by 'ZAn'. Literal 'Z's in a symbolic name are doubled +-- to 'ZZ'. +sanitizeName :: String -> String +sanitizeName str + = let hasSymbols = any isJust $ map convertSymbol str + in if hasSymbols + then "_sym_" ++ concatMap rewriteChar str + else str + + +-- | Like 'sanitizeGlobal' but indicate that the name is going to be visible +-- globally. +sanitizeGlobal :: String -> String +sanitizeGlobal = sanitizeName + + +-- | Like 'sanitizeName' but at add an extra '_' prefix. +-- This is used for function-local names so that they do not conflict +-- with globally-visible ones. +sanitizeLocal :: String -> String +sanitizeLocal str + = "_" ++ sanitizeGlobal str + + +-- | Get the encoded version of a character. +rewriteChar :: Char -> String +rewriteChar c + | Just str <- convertSymbol c = "Z" ++ str + | 'Z' <- c = "ZZ" + | otherwise = [c] + + +-- | Convert symbols to their sanitized form. +convertSymbol :: Char -> Maybe String +convertSymbol c + = case c of + '!' -> Just "Bg" + '@' -> Just "At" + '#' -> Just "Hs" + '$' -> Just "Dl" + '%' -> Just "Pc" + '^' -> Just "Ht" + '&' -> Just "An" + '*' -> Just "St" + '~' -> Just "Tl" + '-' -> Just "Ms" + '+' -> Just "Ps" + '=' -> Just "Eq" + '|' -> Just "Pp" + '\\' -> Just "Bs" + '/' -> Just "Fs" + ':' -> Just "Cl" + '.' -> Just "Dt" + '?' -> Just "Qm" + '<' -> Just "Lt" + '>' -> Just "Gt" + '[' -> Just "Br" + ']' -> Just "Kt" + '\'' -> Just "Pm" + '`' -> Just "Bt" + _ -> Nothing + diff --git a/DDC/Core/Salt/Platform.hs b/DDC/Core/Salt/Platform.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Platform.hs @@ -0,0 +1,72 @@ + +module DDC.Core.Salt.Platform + ( Platform (..) + , platform32 + , platform64) +where +import DDC.Base.Pretty + +-- | Enough information about the platform to generate code for it. +-- We need to know the pointer size and alignment constraints +-- so that we can lay out heap objects. +data Platform + = Platform + { -- | Width of an address in bytes. + platformAddrBytes :: Integer + + -- | Width of a constructor tag in bytes. + , platformTagBytes :: Integer + + -- | Width of a Nat in bytes (used for object sizes like size_t). + , platformNatBytes :: Integer + + -- | Align functions on this boundary in bytes. + , platformAlignBytes :: Integer + + -- | Minimum size of a heap object in bytes. + , platformObjBytes :: Integer } + deriving Show + +instance Pretty Platform where + ppr pp + = vcat + [ text "Address Width (bytes) : " + <> text (show $ platformAddrBytes pp) + + , text "Tag Word Width (bytes) : " + <> text (show $ platformTagBytes pp) + + , text "Nat Word Width (bytes) : " + <> text (show $ platformNatBytes pp) + + , text "Function Alignment (bytes) : " + <> text (show $ platformAlignBytes pp) + + , text "Minimum Object Size (bytes) : " + <> text (show $ platformObjBytes pp) ] + + +-- | 32-bit platform specification. +-- +-- Heap objects are aligned to 64-bit so that double-precision floats +-- in the object payloads maintain their alignments. +platform32 :: Platform +platform32 + = Platform + { platformAddrBytes = 4 + , platformTagBytes = 4 + , platformNatBytes = 4 + , platformAlignBytes = 4 + , platformObjBytes = 8 } + + +-- | 64-bit platform specification. +platform64 :: Platform +platform64 + = Platform + { platformAddrBytes = 8 + , platformTagBytes = 4 + , platformNatBytes = 8 + , platformAlignBytes = 8 + , platformObjBytes = 8 } + diff --git a/DDC/Core/Salt/Profile.hs b/DDC/Core/Salt/Profile.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Profile.hs @@ -0,0 +1,62 @@ + +-- | Language profile for Disciple Core Salt. +module DDC.Core.Salt.Profile + ( profile + , lexModuleString + , lexExpString) +where +import DDC.Core.Salt.Env +import DDC.Core.Salt.Name +import DDC.Core.Fragment +import DDC.Core.Lexer +import DDC.Data.Token + + +-- | Language profile for Disciple Core Salt. +profile :: Profile Name +profile + = Profile + { profileName = "Salt" + , profileFeatures = features + , profilePrimDataDefs = primDataDefs + , profilePrimKinds = primKindEnv + , profilePrimTypes = primTypeEnv + , profileTypeIsUnboxed = typeIsUnboxed } + + +-- | The Salt fragment doesn't support many features. +-- No nested functions, no partial application and so on. +features :: Features +features = zeroFeatures + { featuresUntrackedEffects = True + , featuresUntrackedClosures = True + , featuresDebruijnBinders = True + , featuresUnusedBindings = True } + + +-- | Lex a string to tokens, using primitive names. +lexModuleString + :: String -- ^ Source file name. + -> Int -- ^ Starting line number. + -> String -- ^ String to parse. + -> [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. +lexExpString + :: String -- ^ Source file name. + -> Int -- ^ Starting line number. + -> String -- ^ String to parse. + -> [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/Runtime.hs b/DDC/Core/Salt/Runtime.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Runtime.hs @@ -0,0 +1,293 @@ + +-- | Bindings to functions exported by the runtime system, +-- and wrappers for related primops. +module DDC.Core.Salt.Runtime + ( -- * Runtime Config + Config (..) + , runtimeImportKinds + , runtimeImportTypes + + -- * Types defined in the runtime system. + , rTop + + -- * Functions defined in the runtime system. + , xGetTag + , xAllocBoxed + , xGetFieldOfBoxed + , xSetFieldOfBoxed + , xAllocRawSmall + , xPayloadOfRawSmall + + -- * Calls to primops. + , xCreate + , xRead + , xWrite + , xPeekBuffer + , xPokeBuffer + , xFail + , xReturn) +where +import DDC.Core.Salt.Compounds +import DDC.Core.Salt.Name +import DDC.Core.Salt.Env +import DDC.Core.Compounds +import DDC.Core.Module +import DDC.Core.Exp +import qualified Data.Map as Map +import Data.Map (Map) + + +-- Runtime -------------------------------------------------------------------- +-- | Runtime system configuration +data Config + = Config + { -- | Used a fixed-size heap of this many bytes. + configHeapSize :: Integer + } + + +-- | Kind signatures for runtime types that we use when converting to Salt. +runtimeImportKinds :: Map Name (QualName Name, Kind Name) +runtimeImportKinds + = Map.fromList + [ rn ukTop ] + where rn (UName n, t) = (n, (QualName (ModuleName ["Runtime"]) n, t)) + rn _ = error "runtimeImportKinds: all runtime bindings must be named." + + +-- | Type signatures for runtime funtions that we use when converting to Salt. +runtimeImportTypes :: Map Name (QualName Name, Type Name) +runtimeImportTypes + = Map.fromList + [ rn utGetTag + , rn utAllocBoxed + , rn utGetFieldOfBoxed + , rn utSetFieldOfBoxed + , rn utAllocRawSmall + , rn utPayloadOfRawSmall ] + where rn (UName n, t) = (n, (QualName (ModuleName ["Runtime"]) n, t)) + rn _ = error "runtimeImportTypes: all runtime bindings must be named." + + +-- 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). +rTop :: Type Name +rTop = TVar (fst ukTop) + +ukTop :: (Bound Name, Kind Name) +ukTop + = ( UName (NameVar "rT") + , kRegion) + + +-- Tags ------------------------------- +-- | Get the constructor tag of an object. +xGetTag :: a -> Type Name -> Exp a Name -> Exp a Name +xGetTag a tR x2 + = xApps a (XVar a $ fst utGetTag) + [ XType tR, x2 ] + +utGetTag :: (Bound Name, Type Name) +utGetTag + = ( UName (NameVar "getTag") + , tForall kRegion $ \r -> tPtr r tObj `tFunPE` tTag) + + +-- 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 tR + , XCon a (mkDaConAlg (NameLitTag tag) tTag) + , x2] + +utAllocBoxed :: (Bound Name, Type Name) +utAllocBoxed + = ( UName (NameVar "allocBoxed") + , tForall kRegion $ \r -> (tTag `tFunPE` tNat `tFunPE` 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 + -> Exp a Name -- ^ Object to update. + -> Integer -- ^ Field index. + -> Exp a Name + +xGetFieldOfBoxed a trPrime tField x2 offset + = xApps a (XVar a $ fst utGetFieldOfBoxed) + [ XType trPrime, XType tField + , x2 + , xNat a offset ] + +utGetFieldOfBoxed :: (Bound Name, Type Name) +utGetFieldOfBoxed + = ( UName (NameVar "getFieldOfBoxed") + , tForalls [kRegion, kData] + $ \[r1, t2] + -> tPtr r1 tObj + `tFunPE` tNat + `tFunPE` t2) + + +-- | Set a field in a Boxed Object. +xSetFieldOfBoxed + :: a + -> Type Name -- ^ Prime region var of object. + -> Type Name -- ^ Region of field object. + -> Exp a Name -- ^ Object to update. + -> Integer -- ^ Field index. + -> Exp a Name -- ^ New field value. + -> Exp a Name + +xSetFieldOfBoxed a trPrime tField x2 offset val + = xApps a (XVar a $ fst utSetFieldOfBoxed) + [ XType trPrime, XType tField + , 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) + + +-- 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 tR + , xTag a tag + , x2] + +utAllocRawSmall :: (Bound Name, Type Name) +utAllocRawSmall + = ( UName (NameVar "allocRawSmall") + , tForall kRegion $ \r -> (tTag `tFunPE` tNat `tFunPE` 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) + [XType 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 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 tField)) + xAddr) + (xNat a offset)) + xVal + +uWrite :: Bound Name +uWrite = UPrim (NamePrimOp $ PrimStore $ PrimStoreWrite) + (tForall kData $ \t -> tAddr `tFunPE` tNat `tFunPE` t `tFunPE` tVoid) + + +-- | 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 r)) + (XType 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 r)) + (XType t)) + castedPtr) + (xNat a offset)) + xVal + +uPoke :: Bound Name +uPoke = UPrim (NamePrimOp $ PrimStore $ PrimStorePoke) + (typeOfPrimStore PrimStorePoke) + + +-- | 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 r)) + (XType toType)) + (XType 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 t) + where uFail = UPrim (NamePrimOp (PrimControl PrimControlFail)) tFail + tFail = TForall (BAnon kData) (TVar $ UIx 0) + + +-- | 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 t)) + x + diff --git a/DDC/Core/Salt/Transfer.hs b/DDC/Core/Salt/Transfer.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Transfer.hs @@ -0,0 +1,178 @@ + +module DDC.Core.Salt.Transfer + (transferModule) +where +import DDC.Core.Salt.Convert.Base +import DDC.Core.Salt.Runtime +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.Check (AnTEC(..)) +import Data.Map (Map) +import qualified Data.Map as Map + + +-- | Add control transfer primops to function bodies. +-- For example: +-- +-- @ +-- fun \[x : Int32\#\] : Int32\# +-- = case ... of +-- ... -> add\# \[Int32\] ... +-- ... -> fun x +-- +-- => fun \[x : Int32\#\] : Int32\# +-- = case ... of +-- ... -> return\# \[Int32\#] (add\# \[Int32\] ...) +-- ... -> tailcall1\# \[Int32\#] \[Int32\#\] fun x +-- @ +-- +-- The control primops return# and tailcall1# tell us how to transfer control +-- after we've finished with the current function. +-- +transferModule + :: Module (AnTEC a Name) Name + -> Either (Error (AnTEC a Name)) + (Module (AnTEC a Name) Name) + +transferModule mm@ModuleCore{} + | XLet a (LRec bxs) x1 <- moduleBody mm + = let bxs' = map transLet bxs + in Right $ mm { moduleBody = XLet a (LRec bxs') x1 } + + | otherwise + = Left (ErrorNoTopLevelLetrec mm) + + +-- Let ------------------------------------------------------------------------ +transLet :: (Bind Name, Exp (AnTEC a Name) Name) + -> (Bind Name, Exp (AnTEC a Name) Name) + +transLet (BName n t, x) + = let tails = Map.singleton n t + x' = transSuper tails x + in (BName n t, x') + +transLet tup + = tup + + +-- Super ---------------------------------------------------------------------- +transSuper + :: Map Name (Type Name) -- ^ Tail-callable supers, with types. + -> Exp (AnTEC a Name) Name + -> Exp (AnTEC a Name) Name + +transSuper tails xx + = let down = transSuper tails + in case xx of + -- Return the value bound to a var. + XVar a _ -> xReturn a (annotType a) xx + + -- Return a constructor value. + XCon a _ -> xReturn a (annotType a) xx + + XLAM a b x -> XLAM a b $ down x + XLam a b x -> XLam a b $ down x + + -- Tail-call a supercombinator. + -- The super must have its arguments in standard order, + -- being type arguments, then witness arguments, then value arguments. + -- We need this so we can split off just the value arguments and + -- pass them to the appropriate tailcallN# primitive. + XApp{} + | Just (xv@(XVar a (UName n)), args) <- takeXApps xx + , Just tF <- Map.lookup n tails + + -- Split off args and check they are in standard order. + , (xsArgsType, xsArgsMore) <- span isXType args + , (xsArgsWit, xsArgsVal) <- span isXWitness xsArgsMore + , not $ any isXType xsArgsVal + , not $ any isXWitness xsArgsVal + + -- Get the types of the value parameters. + , (_, tsValArgs, tResult) <- takeTFunWitArgResult $ eraseTForalls tF + + -> let arity = length xsArgsVal + p = PrimCallTail arity + u = UPrim (NamePrimOp (PrimCall p)) (typeOfPrimCall p) + in xApps a (XVar a u) + $ (map XType (tsValArgs ++ [tResult])) + ++ [xApps a xv (xsArgsType ++ xsArgsWit)] + ++ xsArgsVal + + -- Return the result of this application. + XApp a x1 x2 + -> let x1' = transX tails x1 + x2' = transX tails x2 + in addReturnX a (annotType a) (XApp a x1' x2') + + XLet a lts x -> XLet a (transL tails lts) (down x) + XCase a x alts -> XCase a (transX tails x) (map (transA tails) alts) + XCast a c x -> XCast a c (transSuper tails x) + XType{} -> xx + XWitness{} -> xx + + +-- | Add a statment to return this value, +-- but don't wrap existing control transfer operations. +addReturnX :: a -> Type Name + -> Exp a Name -> Exp a Name +addReturnX a t xx + + -- If there is already a control transfer primitive here then + -- don't add another one. + | Just (NamePrimOp p, _) <- takeXPrimApps xx + , PrimControl{} <- p + = xx + + -- Wrap the final expression in a return primitive. + | otherwise + = xReturn a t xx + + +-- Let ------------------------------------------------------------------------ +transL :: Map Name (Type Name) -- ^ Tail-callable supers, with types. + -> Lets (AnTEC a Name) Name + -> Lets (AnTEC a Name) Name + +transL tails lts + = case lts of + LLet mode b x -> LLet mode b (transX tails x) + LRec bxs -> LRec [(b, transX tails x) | (b, x) <- bxs] + LLetRegions{} -> lts + LWithRegion{} -> lts + + +-- Alt ------------------------------------------------------------------------ +transA :: Map Name (Type Name) -- ^ Tail-callable supers, with types. + -> Alt (AnTEC a Name) Name + -> Alt (AnTEC a Name) Name + +transA tails aa + = case aa of + AAlt p x -> AAlt p (transSuper tails x) + + +-- Exp ------------------------------------------------------------------------ +transX :: Map Name (Type Name) -- ^ Tail-callable supers, with types. + -> Exp (AnTEC a Name) Name + -> Exp (AnTEC a Name) Name + +transX tails xx + = let down = transX tails + in case xx of + XVar{} -> xx + XCon{} -> xx + XLAM{} -> xx + XLam{} -> xx + XApp a x1 x2 -> XApp a (down x1) (down x2) + XLet{} -> xx + XCase{} -> xx + XCast{} -> xx + XType{} -> xx + XWitness{} -> xx + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +-------------------------------------------------------------------------------- +The Disciplined Disciple Compiler License (MIT style) + +Copyrite (K) 2007-2012 The Disciplined Disciple Compiler Strike Force +All rights reversed. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +------------------------------------------------------------------------------- +Under Australian law copyright is free and automatic. +By contributing to DDC authors grant all rights they have regarding their +contributions to the other members of the Disciplined Disciple Compiler Strike +Force, past, present and future, as well as placing their contributions under +the above license. + +Use "darcs show authors" to get a list of Strike Force members. + +-------------------------------------------------------------------------------- +Redistributions of libraries in ./external are governed by their own licenses: + + - TinyPTC GNU Lesser General Public License + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ddc-core-salt.cabal b/ddc-core-salt.cabal new file mode 100644 --- /dev/null +++ b/ddc-core-salt.cabal @@ -0,0 +1,75 @@ +Name: ddc-core-salt +Version: 0.3.1.1 +License: MIT +License-file: LICENSE +Author: The Disciplined Disciple Compiler Strike Force +Maintainer: Ben Lippmeier +Build-Type: Simple +Cabal-Version: >=1.6 +Stability: experimental +Category: Compilers/Interpreters +Homepage: http://disciple.ouroborus.net +Bug-reports: disciple@ouroborus.net +Synopsis: Disciplined Disciple Compiler C code generator. +Description: Disciplined Disciple Compiler C code generator. + +Library + Build-Depends: + base == 4.6.*, + deepseq == 1.3.*, + containers == 0.5.*, + array == 0.4.*, + transformers == 0.3.*, + mtl == 2.1.*, + ddc-base == 0.3.1.*, + ddc-core == 0.3.1.* + + Exposed-modules: + DDC.Core.Salt.Transfer + DDC.Core.Salt.Platform + DDC.Core.Salt.Compounds + DDC.Core.Salt.Runtime + DDC.Core.Salt.Name + DDC.Core.Salt.Env + DDC.Core.Salt + + DDC.Core.Lite.Compounds + DDC.Core.Lite.Layout + DDC.Core.Lite.Env + DDC.Core.Lite + + Other-modules: + 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 + DDC.Core.Salt.Convert.Type + DDC.Core.Salt.Convert.Init + DDC.Core.Salt.Convert.Prim + DDC.Core.Salt.Name.Lit + DDC.Core.Salt.Name.PrimOp + DDC.Core.Salt.Name.PrimTyCon + DDC.Core.Salt.Name.Sanitize + DDC.Core.Salt.Convert + DDC.Core.Salt.Profile + + + GHC-options: + -Wall + -fno-warn-orphans + -fno-warn-missing-signatures + -fno-warn-unused-do-bind + + Extensions: + KindSignatures + NoMonomorphismRestriction + ScopedTypeVariables + StandaloneDeriving + PatternGuards + DeriveDataTypeable + ParallelListComp +