ddc-core-salt (empty) → 0.3.1.1
raw patch · 30 files changed
+5078/−0 lines, 30 filesdep +arraydep +basedep +containerssetup-changed
Dependencies added: array, base, containers, ddc-base, ddc-core, deepseq, mtl, transformers
Files
- DDC/Core/Lite.hs +39/−0
- DDC/Core/Lite/Compounds.hs +91/−0
- DDC/Core/Lite/Convert.hs +620/−0
- DDC/Core/Lite/Convert/Base.hs +79/−0
- DDC/Core/Lite/Convert/Data.hs +179/−0
- DDC/Core/Lite/Convert/Type.hs +213/−0
- DDC/Core/Lite/Env.hs +292/−0
- DDC/Core/Lite/Layout.hs +145/−0
- DDC/Core/Lite/Name.hs +263/−0
- DDC/Core/Lite/Profile.hs +76/−0
- DDC/Core/Salt.hs +50/−0
- DDC/Core/Salt/Compounds.hs +72/−0
- DDC/Core/Salt/Convert.hs +651/−0
- DDC/Core/Salt/Convert/Base.hs +140/−0
- DDC/Core/Salt/Convert/Init.hs +73/−0
- DDC/Core/Salt/Convert/Prim.hs +82/−0
- DDC/Core/Salt/Convert/Type.hs +82/−0
- DDC/Core/Salt/Env.hs +287/−0
- DDC/Core/Salt/Name.hs +186/−0
- DDC/Core/Salt/Name/Lit.hs +86/−0
- DDC/Core/Salt/Name/PrimOp.hs +399/−0
- DDC/Core/Salt/Name/PrimTyCon.hs +188/−0
- DDC/Core/Salt/Name/Sanitize.hs +73/−0
- DDC/Core/Salt/Platform.hs +72/−0
- DDC/Core/Salt/Profile.hs +62/−0
- DDC/Core/Salt/Runtime.hs +293/−0
- DDC/Core/Salt/Transfer.hs +178/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- ddc-core-salt.cabal +75/−0
+ DDC/Core/Lite.hs view
@@ -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
+ DDC/Core/Lite/Compounds.hs view
@@ -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+
+ DDC/Core/Lite/Convert.hs view
@@ -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."+
+ DDC/Core/Lite/Convert/Base.hs view
@@ -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" ]+
+ DDC/Core/Lite/Convert/Data.hs view
@@ -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+
+ DDC/Core/Lite/Convert/Type.hs view
@@ -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"+
+ DDC/Core/Lite/Env.hs view
@@ -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+
+ DDC/Core/Lite/Layout.hs view
@@ -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+
+ DDC/Core/Lite/Name.hs view
@@ -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+
+ DDC/Core/Lite/Profile.hs view
@@ -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++
+ DDC/Core/Salt.hs view
@@ -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
+ DDC/Core/Salt/Compounds.hs view
@@ -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)+
+ DDC/Core/Salt/Convert.hs view
@@ -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+
+ DDC/Core/Salt/Convert/Base.hs view
@@ -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) ]+
+ DDC/Core/Salt/Convert/Init.hs view
@@ -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+
+ DDC/Core/Salt/Convert/Prim.hs view
@@ -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"++
+ DDC/Core/Salt/Convert/Type.hs view
@@ -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
+ DDC/Core/Salt/Env.hs view
@@ -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++
+ DDC/Core/Salt/Name.hs view
@@ -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+
+ DDC/Core/Salt/Name/Lit.hs view
@@ -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
+ DDC/Core/Salt/Name/PrimOp.hs view
@@ -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+
+ DDC/Core/Salt/Name/PrimTyCon.hs view
@@ -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+
+ DDC/Core/Salt/Name/Sanitize.hs view
@@ -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+
+ DDC/Core/Salt/Platform.hs view
@@ -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 }+
+ DDC/Core/Salt/Profile.hs view
@@ -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
+ DDC/Core/Salt/Runtime.hs view
@@ -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+
+ DDC/Core/Salt/Transfer.hs view
@@ -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+
+ LICENSE view
@@ -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+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ddc-core-salt.cabal view
@@ -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 <benl@ouroborus.net>+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+