ddc-core-salt 0.3.2.1 → 0.4.1.1
raw patch · 34 files changed
+1877/−1338 lines, 34 filesdep ~arraydep ~basedep ~ddc-base
Dependency ranges changed: array, base, ddc-base, ddc-core
Files
- DDC/Core/Lite/Compounds.hs +1/−1
- DDC/Core/Lite/Convert.hs +88/−60
- DDC/Core/Lite/Convert/Base.hs +1/−1
- DDC/Core/Lite/Convert/Data.hs +3/−3
- DDC/Core/Lite/Convert/Type.hs +20/−15
- DDC/Core/Lite/Env.hs +19/−19
- DDC/Core/Lite/Layout.hs +13/−10
- DDC/Core/Lite/Name.hs +2/−1
- DDC/Core/Lite/Profile.hs +3/−6
- DDC/Core/Salt/Compounds.hs +5/−5
- DDC/Core/Salt/Convert.hs +101/−590
- DDC/Core/Salt/Convert/Base.hs +12/−5
- DDC/Core/Salt/Convert/Exp.hs +472/−0
- DDC/Core/Salt/Convert/Init.hs +62/−27
- DDC/Core/Salt/Convert/Name.hs +123/−0
- DDC/Core/Salt/Convert/Super.hs +164/−0
- DDC/Core/Salt/Convert/Type.hs +34/−20
- DDC/Core/Salt/Env.hs +15/−11
- DDC/Core/Salt/Name.hs +66/−14
- DDC/Core/Salt/Name/Lit.hs +26/−2
- DDC/Core/Salt/Name/PrimArith.hs +86/−0
- DDC/Core/Salt/Name/PrimCall.hs +43/−0
- DDC/Core/Salt/Name/PrimCast.hs +96/−0
- DDC/Core/Salt/Name/PrimControl.hs +40/−0
- DDC/Core/Salt/Name/PrimOp.hs +0/−401
- DDC/Core/Salt/Name/PrimStore.hs +125/−0
- DDC/Core/Salt/Name/PrimTyCon.hs +34/−11
- DDC/Core/Salt/Name/PrimVec.hs +162/−0
- DDC/Core/Salt/Name/Sanitize.hs +0/−73
- DDC/Core/Salt/Profile.hs +4/−4
- DDC/Core/Salt/Runtime.hs +25/−24
- DDC/Core/Salt/Transfer.hs +2/−2
- LICENSE +1/−15
- ddc-core-salt.cabal +29/−18
DDC/Core/Lite/Compounds.hs view
@@ -34,7 +34,7 @@ -- | A Literal Nat# data constructor. dcNatU :: Integer -> DaCon Name-dcNatU i = mkDaConAlg (NameLitNat i) tNatU+dcNatU i = DaConPrim (NameLitNat i) tNatU -- | A literal Nat#
DDC/Core/Lite/Convert.hs view
@@ -16,7 +16,7 @@ import DDC.Core.Exp import DDC.Type.Universe import DDC.Type.DataDef-import DDC.Control.Monad.Check (throw, result)+import DDC.Control.Monad.Check (throw, evalCheck) import DDC.Core.Check (AnTEC(..)) import DDC.Type.Env (KindEnv, TypeEnv) import qualified DDC.Core.Lite.Name as L@@ -60,10 +60,10 @@ saltOfLiteModule platform runConfig defs kenv tenv mm = {-# SCC saltOfLiteModule #-}- result $ convertM platform runConfig defs kenv tenv mm+ evalCheck () $ convertM platform runConfig defs kenv tenv mm --- Module ---------------------------------------------------------------------+-- Module ----------------------------------------------------------------------------------------- convertM :: Show a => Platform@@ -77,28 +77,21 @@ convertM pp runConfig defs kenv tenv mm = do -- Convert signatures of exported functions.- tsExports'- <- liftM Map.fromList- $ mapM convertExportM - $ Map.toList - $ moduleExportTypes mm+ tsExports' <- mapM convertExportM $ moduleExportValues mm -- Convert signatures of imported functions.- tsImports'- <- liftM Map.fromList- $ mapM convertImportM - $ Map.toList- $ moduleImportTypes mm-+ tsImports' <- mapM convertImportM $ moduleImportValues mm+ -- Convert the body of the module to Salt.- let ntsImports = [(BName n t) | (n, (_, t)) <- Map.toList $ moduleImportTypes mm]+ let ntsImports = [BName n (typeOfImportSource isrc) + | (n, isrc) <- moduleImportTypes mm] let tenv' = Env.extends ntsImports tenv x1 <- convertExpX ExpTop pp defs kenv tenv' $ moduleBody mm -- Converting the body will also expand out code to construct, -- the place-holder '()' inside the top-level lets. -- We don't want that, so just replace that code with a fresh unit.- let Just a = takeAnnotOfExp x1+ let a = annotOfExp x1 let (lts', _) = splitXLets x1 let x2 = xLets a lts' (xUnit a) @@ -109,12 +102,16 @@ -- None of the types imported by Lite modules are relevant -- to the Salt language.- , moduleExportKinds = Map.empty- , moduleExportTypes = tsExports'+ , moduleExportTypes = []+ , moduleExportValues = tsExports' - , moduleImportKinds = S.runtimeImportKinds- , moduleImportTypes = Map.union S.runtimeImportTypes tsImports'+ , moduleImportTypes = Map.toList S.runtimeImportKinds+ , moduleImportValues = (Map.toList S.runtimeImportTypes) ++ tsImports' + -- Data constructors and pattern matches should have been flattened+ -- into primops, so we don't need the data type definitions.+ , moduleDataDefsLocal = []+ , moduleBody = x2 } -- If this is the 'Main' module then add code to initialise the @@ -127,40 +124,69 @@ return $ mm_init +-- Exports ---------------------------------------------------------------------------------------- -- | Convert an export spec. convertExportM- :: (L.Name, Type L.Name) - -> ConvertM a (S.Name, Type S.Name)+ :: (L.Name, ExportSource L.Name) + -> ConvertM a (S.Name, ExportSource S.Name) -convertExportM (n, t)+convertExportM (n, esrc) = do n' <- convertBindNameM n- t' <- convertT Env.empty t- return (n', t')+ esrc' <- convertExportSourceM esrc+ return (n', esrc') +-- | Convert an export source specifier.+convertExportSourceM + :: ExportSource L.Name+ -> ConvertM a (ExportSource S.Name)++convertExportSourceM isrc+ = case isrc of+ ExportSourceLocal n t+ -> do n' <- convertBindNameM n+ t' <- convertT Env.empty t+ return $ ExportSourceLocal n' t'++ ExportSourceLocalNoType n+ -> do n' <- convertBindNameM n+ return $ ExportSourceLocalNoType n'+++-- Imports ---------------------------------------------------------------------------------------- -- | Convert an import spec. convertImportM- :: (L.Name, (QualName L.Name, Type L.Name))- -> ConvertM a (S.Name, (QualName S.Name, Type S.Name))+ :: (L.Name, ImportSource L.Name)+ -> ConvertM a (S.Name, ImportSource S.Name) -convertImportM (n, (qn, t))+convertImportM (n, isrc) = do n' <- convertBindNameM n- qn' <- convertQualNameM qn- t' <- convertT Env.empty t- return (n', (qn', t'))+ isrc' <- convertImportSourceM isrc+ return (n', isrc') --- | Convert a qualified name.-convertQualNameM- :: QualName L.Name - -> ConvertM a (QualName S.Name)+-- | Convert an import source specifier.+convertImportSourceM+ :: ImportSource L.Name + -> ConvertM a (ImportSource S.Name) -convertQualNameM (QualName mn n)- = do n' <- convertBindNameM n- return $ QualName mn n'+convertImportSourceM isrc+ = case isrc of+ ImportSourceAbstract t+ -> do t' <- convertT Env.empty t+ return $ ImportSourceAbstract t' + ImportSourceModule mn n t+ -> do t' <- convertT Env.empty t+ n' <- convertBindNameM n+ return $ ImportSourceModule mn n' t' --- Exp -------------------------------------------------------------------------+ ImportSourceSea str t+ -> do t' <- convertT Env.empty t+ return $ ImportSourceSea str t'+++-- Exp -------------------------------------------------------------------------------------------- -- | The context we're converting the expression in. -- We keep track of this during conversion to ensure we don't produce -- code outside the Salt language fragment. For example, in Salt we can only@@ -343,19 +369,19 @@ -- Types can only appear as the arguments in function applications.- XType t- | ExpArg <- ctx -> liftM XType (convertT kenv t)+ XType (AnTEC _ _ _ a') t+ | ExpArg <- ctx -> liftM (XType a') (convertT kenv t) | otherwise -> throw $ ErrorNotNormalized ("Unexpected type expresison.") -- Witnesses can only appear as the arguments to function applications.- XWitness w - | ExpArg <- ctx -> liftM XWitness (convertWitnessX kenv w)+ XWitness (AnTEC _ _ _ a') w + | ExpArg <- ctx -> liftM (XWitness a') (convertWitnessX kenv w) | otherwise -> throw $ ErrorNotNormalized ("Unexpected witness expression.") --------------------------------------------------------------------------------+--------------------------------------------------------------------------------------------------- -- | Convert a let-binding to Salt. convertLetsX :: Show a @@ -381,17 +407,20 @@ x1' <- convertExpX ExpBind pp defs kenv tenv' x1 return $ LLet b' x1' - LLetRegions b bs+ LPrivate b mt bs -> do b' <- mapM (convertB kenv) b let kenv' = Env.extends b kenv bs' <- mapM (convertB kenv') bs- return $ LLetRegions b' bs'+ mt' <- case mt of+ Nothing -> return Nothing+ Just t -> liftM Just $ convertT kenv t+ return $ LPrivate b' mt' bs' LWithRegion{} -> throw $ ErrorMalformed "LWithRegion should not appear in Lite code." --------------------------------------------------------------------------------+--------------------------------------------------------------------------------------------------- -- | Convert a witness expression to Salt convertWitnessX :: Show a@@ -426,7 +455,7 @@ (convertT kenv t) --------------------------------------------------------------------------------+--------------------------------------------------------------------------------------------------- -- | Convert a data constructor application to Salt. convertCtorAppX :: Show a@@ -459,7 +488,7 @@ = return $ S.xWord a i bits -- Handle the unit constructor.- | DaConUnit <- daConName dc+ | DaConUnit <- dc = do return $ S.xAllocBoxed a S.rTop 0 (S.xNat a 0) -- Construct algbraic data that has a finite number of data constructors.@@ -475,7 +504,7 @@ [] -> return S.rTop - XType (TVar u) : _+ XType _ (TVar u) : _ | Just tu <- Env.lookup u kenv -> if isRegionKind tu then do u' <- convertU u@@ -487,9 +516,8 @@ -- Convert the types of each field. let makeFieldType x- = case takeAnnotOfExp x of- Nothing -> return Nothing- Just a' -> liftM Just $ convertT kenv (annotType a')+ = let a' = annotOfExp x + in liftM Just $ convertT kenv (annotType a') xsArgs' <- mapM (convertExpX ExpArg pp defs kenv tenv) xsArgs tsArgs' <- mapM makeFieldType xsArgs@@ -504,7 +532,7 @@ = throw $ ErrorMalformed "Invalid constructor application." --- Alt ------------------------------------------------------------------------+-- Alt -------------------------------------------------------------------------------------------- -- | Convert a Lite alternative to Salt. convertAlt :: Show a@@ -542,9 +570,9 @@ -- 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+ | DaConUnit <- dc -> do xBody <- convertExpX ctx pp defs kenv tenv x- let dcTag = mkDaConAlg (S.NameLitTag 0) S.tTag+ let dcTag = DaConPrim (S.NameLitTag 0) S.tTag return $ AAlt (PData dcTag []) xBody -- Match against algebraic data with a finite number@@ -558,8 +586,8 @@ -- Get the tag of this alternative. let iTag = fromIntegral $ dataCtorTag ctorDef- let dcTag = mkDaConAlg (S.NameLitTag iTag) S.tTag-+ let dcTag = DaConPrim (S.NameLitTag iTag) S.tTag+ -- Get the address of the payload. bsFields' <- mapM (convertB kenv) bsFields @@ -577,7 +605,7 @@ -> throw ErrorInvalidAlt --- Data Constructor -----------------------------------------------------------+-- Data Constructor ------------------------------------------------------------------------------- -- | Expand out code to build a data constructor. convertCtor :: Show a@@ -590,7 +618,7 @@ -> ConvertM a (Exp a S.Name) convertCtor pp defs kenv tenv a dc- | DaConUnit <- daConName dc+ | DaConUnit <- dc = return $ S.xAllocBoxed a S.rTop 0 (S.xNat a 0) | Just n <- takeNameOfDaCon dc
DDC/Core/Lite/Convert/Base.hs view
@@ -11,7 +11,7 @@ -- | Conversion Monad-type ConvertM a x = G.CheckM (Error a) x+type ConvertM a x = G.CheckM () (Error a) x -- | Things that can go wrong during the conversion.
DDC/Core/Lite/Convert/Data.hs view
@@ -43,11 +43,11 @@ -- 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+ let xsFields = drop (length $ dataTypeParams dataDef) xsArgs -- Get the regions each of the objects are in. let Just tsFields = sequence - $ drop (length $ dataTypeParamKinds dataDef) tsArgs+ $ drop (length $ dataTypeParams dataDef) tsArgs -- Allocate the object. let arity = length tsFields@@ -88,7 +88,7 @@ -- 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+ let xsFields = drop (length $ dataTypeParams dataDef) xsArgs -- Get the offset of each field. let Just offsets = L.fieldOffsetsOfDataCtor pp ctorDef
DDC/Core/Lite/Convert/Type.hs view
@@ -15,7 +15,7 @@ import DDC.Type.Env import DDC.Type.Compounds import DDC.Type.Predicates-import DDC.Control.Monad.Check (throw)+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@@ -27,6 +27,7 @@ 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 @@ -72,10 +73,10 @@ -> liftM TVar $ convertU u | otherwise- -> error $ "convertT': unexpected var kind " ++ show tt+ -> error $ "ddc-core-salt.convertT: unexpected var kind " ++ show tt Nothing - -> error $ "convertT': type var not in kind environment " ++ show tt+ -> error $ "ddc-core-salt.convertT: type var not in kind environment " ++ show tt -- Convert unapplied type constructors.@@ -144,7 +145,7 @@ -> convertTyConPrim n -- Boxed data values are represented in generic form.- _ -> error "convertTyCon: cannot convert type"+ _ -> error "ddc-core-salt.convertTyCon: cannot convert type" -- | Convert a primitive type constructor to Salt form.@@ -153,7 +154,7 @@ = case n of L.NamePrimTyCon pc -> return $ TCon $ TyConBound (UPrim (O.NamePrimTyCon pc) kData) kData- _ -> error $ "convertTyConPrim: unknown prim name " ++ show n+ _ -> error $ "ddc-core-salt.convertTyConPrim: unknown prim name " ++ show n -- Names ----------------------------------------------------------------------@@ -163,19 +164,23 @@ -> ConvertM a (DaCon O.Name) convertDC kenv dc- = case daConName dc of- DaConUnit- -> error "convertDC: not converting unit DaConName"+ = case dc of+ DaConUnit + -> return DaConUnit - DaConNamed n+ DaConPrim n t -> do n' <- convertBoundNameM n- t' <- convertT kenv (daConType dc)- return $ DaCon- { daConName = DaConNamed n'- , daConType = t'- , daConIsAlgebraic = daConIsAlgebraic dc }+ t' <- convertT kenv t+ return $ DaConPrim+ { daConName = n'+ , daConType = t' } + DaConBound n+ -> do n' <- convertBoundNameM n+ return $ DaConBound+ { daConName = n' } + convertB :: KindEnv L.Name -> Bind L.Name -> ConvertM a (Bind O.Name) convertB kenv bb = case bb of@@ -209,5 +214,5 @@ 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"+ _ -> error $ "ddc-core-salt.convertBoundNameM: cannot convert name " ++ show nn
DDC/Core/Lite/Env.hs view
@@ -40,64 +40,63 @@ -- We need these so that we can match against unboxed patterns -- in case expressions. -- Bool#- [ DataDef (NamePrimTyCon PrimTyConBool) + [ makeDataDefAlg (NamePrimTyCon PrimTyConBool) [] (Just [ (NameLitBool True, []) , (NameLitBool False, []) ]) -- Nat#- , DataDef (NamePrimTyCon PrimTyConNat) [] Nothing+ , makeDataDefAlg (NamePrimTyCon PrimTyConNat) [] Nothing -- Int#- , DataDef (NamePrimTyCon PrimTyConInt) [] Nothing+ , makeDataDefAlg (NamePrimTyCon PrimTyConInt) [] Nothing -- WordN#- , DataDef (NamePrimTyCon (PrimTyConWord 64)) [] Nothing- , DataDef (NamePrimTyCon (PrimTyConWord 32)) [] Nothing- , DataDef (NamePrimTyCon (PrimTyConWord 16)) [] Nothing- , DataDef (NamePrimTyCon (PrimTyConWord 8)) [] Nothing-+ , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 64)) [] Nothing+ , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 32)) [] Nothing+ , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 16)) [] Nothing+ , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 8)) [] Nothing -- Boxed ---------------------------------------------------- -- Unit- , DataDef+ , makeDataDefAlg (NameDataTyCon DataTyConUnit) [] (Just [ ( NamePrimDaCon PrimDaConUnit , []) ]) -- Bool- , DataDef+ , makeDataDefAlg (NameDataTyCon DataTyConBool)- [kRegion]+ [BAnon kRegion] (Just [ ( NamePrimDaCon PrimDaConBoolU , [tBoolU]) ]) -- Nat- , DataDef+ , makeDataDefAlg (NameDataTyCon DataTyConNat)- [kRegion]+ [BAnon kRegion] (Just [ ( NamePrimDaCon PrimDaConNatU , [tNatU]) ]) -- Int- , DataDef+ , makeDataDefAlg (NameDataTyCon DataTyConInt)- [kRegion]+ [BAnon kRegion] (Just [ ( NamePrimDaCon PrimDaConIntU , [tIntU]) ]) -- Pair- , DataDef+ , makeDataDefAlg (NameDataTyCon DataTyConPair)- [kRegion, kData, kData]+ [BAnon kRegion, BAnon kData, BAnon kData] (Just [ ( NamePrimDaCon PrimDaConPr , [tIx kData 1, tIx kData 0]) ]) -- List- , DataDef+ , makeDataDefAlg (NameDataTyCon DataTyConList)- [kRegion, kData]+ [BAnon kRegion, BAnon kData] (Just [ (NamePrimDaCon PrimDaConNil, [tUnit]) , (NamePrimDaCon PrimDaConCons, [tIx kData 0, tList (tIx kRegion 1) (tIx kData 0)])])@@ -124,6 +123,7 @@ PrimTyConFloat _ -> kData PrimTyConTag -> kData PrimTyConString -> kData+ PrimTyConVec _ -> kData `kFun` kData -- | Take the kind of a primitive name.
DDC/Core/Lite/Layout.hs view
@@ -23,7 +23,7 @@ -- | 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 +-- 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@@ -37,7 +37,7 @@ heapObjectOfDataCtor :: Platform -> DataCtor Name -> Maybe HeapObject heapObjectOfDataCtor pp ctor - -- If all the fields are boxed objects then used a Boxed heap object, + -- 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@@ -72,16 +72,16 @@ -- | 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 +-- 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) + $ sequence+ $ map (fieldSizeOfType platform) $ dataCtorFieldTypes ctor @@ -100,7 +100,7 @@ -- We're not supporting polymorphic fields yet. TForall{} -> Nothing - -- Assume anything that isn't a primitive constructor is + -- Assume anything that isn't a primitive constructor is -- represented by a pointer. TApp{} -> Just $ platformAddrBytes platform @@ -119,7 +119,7 @@ fieldSizeOfPrimTyCon :: Platform -> PrimTyCon -> Maybe Integer fieldSizeOfPrimTyCon platform tc = case tc of- -- It might make sense to represent these as zero bytes, + -- 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 @@ -133,12 +133,15 @@ PrimTyConBool -> Just $ 1 PrimTyConWord bits- | bits `mod` 8 == 0 -> Just $ fromIntegral $ bits `div` 8+ | bits `rem` 8 == 0 -> Just $ fromIntegral $ bits `div` 8 | otherwise -> Nothing PrimTyConFloat bits- | bits `mod` 8 == 0 -> Just $ fromIntegral $ bits `div` 8+ | bits `rem` 8 == 0 -> Just $ fromIntegral $ bits `div` 8 | otherwise -> Nothing++ -- Vectors don't appear as raw fields.+ PrimTyConVec{} -> Nothing -- Strings shouldn't appear as raw fields, only pointers to them. PrimTyConString -> Nothing
DDC/Core/Lite/Name.hs view
@@ -20,7 +20,8 @@ , readName) where import DDC.Core.Salt.Name.PrimTyCon-import DDC.Core.Salt.Name.PrimOp+import DDC.Core.Salt.Name.PrimArith+import DDC.Core.Salt.Name.PrimCast import DDC.Core.Salt.Name.Lit import DDC.Base.Pretty import Control.DeepSeq
DDC/Core/Lite/Profile.hs view
@@ -10,7 +10,6 @@ import DDC.Core.Fragment import DDC.Core.Lexer import DDC.Data.Token-import qualified DDC.Type.Env as Env -- | Profile for Disciple Core Lite.@@ -20,13 +19,10 @@ { profileName = "Lite" , profileFeatures = features , profilePrimDataDefs = primDataDefs- , profilePrimSupers = Env.empty , profilePrimKinds = primKindEnv , profilePrimTypes = primTypeEnv-- -- As we allow unboxed instantiation,- -- this isn't needed by the compliance check.- , profileTypeIsUnboxed = const False }+ , profileTypeIsUnboxed = const False + , profileNameIsHole = Nothing } features :: Features@@ -36,6 +32,7 @@ , featuresTrackedClosures = True , featuresFunctionalEffects = True , featuresFunctionalClosures = True+ , featuresEffectCapabilities = False , featuresPartialPrims = False , featuresPartialApplication = True , featuresGeneralApplication = True
DDC/Core/Salt/Compounds.hs view
@@ -51,21 +51,21 @@ -- Expressions ---------------------------------------------------------------- xBool :: a -> Bool -> Exp a Name-xBool a b = XCon a (mkDaConAlg (NameLitBool b) tBool)+xBool a b = XCon a (DaConPrim (NameLitBool b) tBool) xNat :: a -> Integer -> Exp a Name-xNat a i = XCon a (mkDaConAlg (NameLitNat i) tNat)+xNat a i = XCon a (DaConPrim (NameLitNat i) tNat) xInt :: a -> Integer -> Exp a Name-xInt a i = XCon a (mkDaConAlg (NameLitInt i) tInt)+xInt a i = XCon a (DaConPrim (NameLitInt i) tInt) xWord :: a -> Integer -> Int -> Exp a Name-xWord a i bits = XCon a (mkDaConAlg (NameLitWord i bits) (tWord bits))+xWord a i bits = XCon a (DaConPrim (NameLitWord i bits) (tWord bits)) xTag :: a -> Integer -> Exp a Name-xTag a i = XCon a (mkDaConAlg (NameLitTag i) tTag)+xTag a i = XCon a (DaConPrim (NameLitTag i) tTag)
DDC/Core/Salt/Convert.hs view
@@ -9,643 +9,154 @@ -- (these are added by DDC.Core.Salt.Convert.Transfer) -- module DDC.Core.Salt.Convert- ( Error (..)- , seaOfSaltModule)+ ( seaOfSaltModule+ , initRuntime+ , seaNameOfSuper+ , seaNameOfLocal+ , sanitizeName+ , Error (..))+ where-import DDC.Core.Salt.Convert.Prim-import DDC.Core.Salt.Convert.Base import DDC.Core.Salt.Convert.Type+import DDC.Core.Salt.Convert.Init+import DDC.Core.Salt.Convert.Name+import DDC.Core.Salt.Convert.Super+import DDC.Core.Salt.Convert.Base 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 DDC.Control.Monad.Check (throw, evalCheck) 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.+ => Bool -- ^ Whether to emit top-level include macros.+ -- Emitting makes the code easier to read during testing. -> 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+ evalCheck () $ convModuleM withPrelude pp mm --- Module ------------------------------------------------------------------------ | Convert a Salt module to C source text.+-- | Convert a Disciple Core 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 ---------+ -- Top-level includes -------------------+ -- These include runtime system functions and macro definitions that+ -- the generated code refers to directly. let cIncludes- | not withPrelude- = []-+ | not withPrelude = empty | otherwise- = [ text "#include \"Runtime.h\""- , text "#include \"Primitive.h\""- , empty ]+ = vcat + $ [ text "// Includes for helper macros and the runtime system. -----------------"+ , text "#include \"Runtime.h\""+ , text "#include \"Primitive.h\"" + , line ] - -- 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.+ -- Globals for the runtime system -------+ -- If this is the main module then we define the globals for the+ -- runtime system at top-level. let cGlobals- | not withPrelude- = []+ | not withPrelude = empty | isMainModule mm- = [ text "addr_t _DDC_Runtime_heapTop = 0;"- , text "addr_t _DDC_Runtime_heapMax = 0;"- , empty ]+ = vcat + $ [ text "// Definitions of the runtime system variables. -----------------------"+ , text "addr_t _DDC__heapTop = 0;"+ , text "addr_t _DDC__heapMax = 0;" + , line ] | otherwise- = [ text "extern addr_t _DDC_Runtime_heapTop;"- , text "extern addr_t _DDC_Runtime_heapMax;"- , empty ]+ = vcat + $ [ text "// External definitions for the runtime system variables. -------------"+ , text "extern addr_t _DDC__heapTop;"+ , text "extern addr_t _DDC__heapMax;" + , line ] - -- 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+ -- Import external symbols --------------+ dsImport+ <- mapM (\(misrc, nSuper, tSuper)+ -> convSuperTypeM Env.empty misrc Nothing nSuper tSuper)+ [ (Just isrc, nSuper, tSuper)+ | (nSuper, isrc) <- C.moduleImportValues mm+ , let tSuper = typeOfImportSource isrc ] - | otherwise- = throw $ ErrorNoTopLevelLetrec mm+ let cExterns+ | not withPrelude = empty+ | otherwise + = vcat + $ [ text "// External definitions for imported symbols. -------------------------"]+ ++ [ text "extern " <> doc <> semi | doc <- dsImport ]+ ++ [ line ]+ + -- Function prototypes ------------------+ -- These are for the supers defined in this module, so that they+ -- can be recursive, and the function definitions don't need to+ -- be emitted in a particular order.+ + dsProto + <- mapM (\(mesrc, nSuper, tSuper) + -> convSuperTypeM Env.empty Nothing mesrc nSuper tSuper)+ [ (mesrc, nSuper, tSuper) + | (BName nSuper tSuper, _) <- bxs+ , let mesrc = lookup nSuper (moduleExportValues mm) ]+ + let cProtos+ | not withPrelude = empty+ | otherwise+ = vcat + $ [ text "// Function prototypes for locally defined supers. --------------------"]+ ++ [ doc <> semi | doc <- dsProto ]+ ++ [ line ] --- 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]+ -- Super-combinator definitions ---------+ -- This is the code for locally defined functions. - | 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 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 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'-+ -- Build the top-level kind environment.+ let kenv = Env.fromList+ $ [ BName n (typeOfImportSource isrc) + | (n, isrc) <- moduleImportTypes mm ] - -- Store primops.- PrimStore op- -> do let op' = convPrimStore op- xs' <- mapM (convRValueM pp kenv tenv) - $ filter (keepPrimArgX kenv) xs- return $ op' <> parenss xs'+ -- Build the top-level type environment.+ let tenv = Env.fromList + $ [ BName n (typeOfImportSource isrc)+ | (n, isrc) <- moduleImportValues mm ] - _ -> throw $ ErrorPrimCallInvalid p xs+ -- Convert all the super definitions to C code.+ let convSuperM' (BName n t) x+ = convSuperM pp mm kenv tenv n t x + convSuperM' _ x+ = throw $ ErrorFunctionInvalid x --- | 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 + dsSupers <- mapM (uncurry convSuperM') bxs+ let cSupers + = vcat + $ [ text "// Code for locally defined supers. -----------------------------------"]+ ++ dsSupers - XWitness{} -> False- _ -> True+ -- Paste everything together ------------+ return $ cIncludes -- Includes for helper macros and the runtime system.+ <> cGlobals -- Definitions of the runtime system variables.+ <> cExterns -- External definitions for imported symbols.+ <> cProtos -- Function prototypes for locally defined supers.+ <> cSupers -- Code for locally defined supers. + | otherwise+ = throw $ ErrorNoTopLevelLetrec mm -parenss :: [Doc] -> Doc-parenss xs = encloseSep lparen rparen (comma <> space) xs
DDC/Core/Salt/Convert/Base.hs view
@@ -15,10 +15,10 @@ -- | Conversion Monad-type ConvertM a x = G.CheckM (Error a) x+type ConvertM a x = G.CheckM () (Error a) x --- | Things that can go wrong when converting Disciple Core Salt to+-- | Things that can go wrong when converting a Disciple Core Salt module -- to C source text. data Error a -- | Variable is not in scope.@@ -28,14 +28,18 @@ -- | Binder has BNone form, binds no variable. | ErrorBindNone - -- | Modules must contain a top-level letrec.- | ErrorNoTopLevelLetrec- { errorModule :: Module a Name }+ -- | Invalid import.+ | ErrorImportInvalid+ { errorImportName :: Name } -- | A local variable has an invalid type. | ErrorTypeInvalid { errorType :: Type Name } + -- | Modules must contain a top-level letrec.+ | ErrorNoTopLevelLetrec+ { errorModule :: Module a Name }+ -- | An invalid function definition. | ErrorFunctionInvalid { errorExp :: Exp a Name }@@ -92,6 +96,9 @@ , empty , text "with:" <+> align (ppr tt) ] + ErrorImportInvalid n+ -> vcat [ text "Invalid import spec for '" <> ppr n <> text "'" ]+ ErrorFunctionInvalid xx -> vcat [ text "Invalid function definition." , empty
+ DDC/Core/Salt/Convert/Exp.hs view
@@ -0,0 +1,472 @@+module DDC.Core.Salt.Convert.Exp+ ( Config (..)+ , Context (..)+ , convBlockM+ , convAltM+ , convRValueM+ , convPrimCallM)+where+import DDC.Core.Salt.Convert.Name+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.Predicates+import DDC.Core.Compounds+import DDC.Core.Module+import DDC.Core.Exp+import DDC.Type.Env (KindEnv, TypeEnv)+import DDC.Base.Pretty+import DDC.Control.Monad.Check (throw)+import qualified DDC.Type.Env as Env+++-- Config -----------------------------------------------------------------------------------------+-- | Static configuration that doesn't change when we descend into the tree.+data Config a+ = Config+ { configPlatform :: Platform+ , configModule :: Module a Name }+++-- Context ----------------------------------------------------------------------------------------+-- | 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+++-- Block ------------------------------------------------------------------------------------------+-- | Convert an expression to a block of statements.+--+-- If this is the body of a top-level function then all code paths+-- 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+ => Config a+ -> Context -> KindEnv Name -> TypeEnv Name+ -> Exp a Name+ -> ConvertM a Doc++convBlockM config context kenv tenv xx+ = case xx of++ XApp{}+ -- At the top-level of a function body then the last statement+ -- expliticlty passes control.+ | ContextTop <- context+ -> case takeXPrimApps xx of+ Just (NamePrimOp p, xs)+ | isControlPrim p || isCallPrim p+ -> do x1 <- convPrimCallM config kenv tenv p xs+ return $ x1 <> semi++ _ -> throw $ ErrorBodyMustPassControl xx+++ -- When we're in a nested context, and the primop we're calling+ -- passes control then it doesn't produce a value to assign to + -- any result var.+ | ContextNest{} <- context+ , Just (NamePrimOp p, xs) <- takeXPrimApps xx+ , isControlPrim p || isCallPrim p+ -> do x1 <- convPrimCallM config 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+ , Just n' <- seaNameOfLocal n+ -> do xx' <- convRValueM config kenv tenv xx+ 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 config kenv tenv xx+ return $ vcat + [ xx' <> semi ]++ -- Binding from a case-expression.+ XLet _ (LLet 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 config (ContextNest b) kenv tenv x1++ -- Convert the rest of the function.+ let tenv' = Env.extend b tenv + x2' <- convBlockM config context kenv tenv' x2++ return $ vcat+ [ x1'+ , x2' ]++ -- Binding from an r-value.+ XLet _ (LLet b x1) x2+ -> do x1' <- convRValueM config kenv tenv x1+ x2' <- convBlockM config context kenv tenv x2++ let dst = case b of+ BName n@NameVar{} _+ | Just n' <- seaNameOfLocal n+ -> fill 12 n' <+> equals <> space+ _ -> empty++ return $ vcat+ [ dst <> x1' <> semi+ , x2' ]++ -- Ditch letregions.+ XLet _ (LPrivate bs _mt ws) x+ -> let kenv' = Env.extends bs kenv+ tenv' = Env.extends ws tenv+ in convBlockM config context 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 config kenv tenv x+ x1' <- convBlockM config context kenv tenv x1+ xFail' <- convBlockM config context 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 config kenv tenv x+ x1' <- convBlockM config context kenv tenv x1+ x2' <- convBlockM config context 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 config kenv tenv x+ alts' <- mapM (convAltM config context kenv tenv) alts++ return $ vcat+ [ text "switch" <+> parens x'+ , lbrace <> indent 1 (vcat alts')+ , rbrace ]++ -- Ditch casts.+ XCast _ _ x+ -> convBlockM config context 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 + => Config a+ -> Context -> KindEnv Name -> TypeEnv Name+ -> Alt a Name + -> ConvertM a Doc++convAltM config context kenv tenv aa+ = let end + | isContextNest context = line <> text "break;"+ | otherwise = empty+ + in case aa of+ AAlt PDefault x1 + -> do x1' <- convBlockM config context 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 config context 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 Right-value to C source text.+convRValueM + :: Show a + => Config a+ -> KindEnv Name -> TypeEnv Name + -> Exp a Name + -> ConvertM a Doc++convRValueM config kenv tenv xx+ = case xx of++ -- Plain variable.+ XVar _ (UName n)+ | Just n' <- seaNameOfLocal n+ -> return $ n'++ -- Literals+ XCon _ dc+ | DaConPrim n _ <- 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 config kenv tenv p args++ -- Super application.+ XApp{}+ | Just (XVar _ (UName nSuper), args) + <- takeXApps xx+ -> do + -- Get the C name to use when calling the super, + -- which depends on how it's imported and exported.+ let Just nSuper' + = seaNameOfSuper + (lookup nSuper $ moduleImportValues $ configModule config)+ (lookup nSuper $ moduleExportValues $ configModule config)+ nSuper++ -- Ditch type and witness arguments+ args' <- mapM (convRValueM config kenv tenv) + $ filter keepFunArgX args++ return $ nSuper' <> parenss args'++ -- Type argument.+ XType _ t+ -> do t' <- convTypeM kenv t+ return $ t'++ -- Ditch casts.+ XCast _ _ x+ -> convRValueM config 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 + => Config a+ -> KindEnv Name -> TypeEnv Name+ -> PrimOp -> [Exp a Name] + -> ConvertM a Doc++convPrimCallM config kenv tenv p xs+ = let pp = configPlatform config+ in case p of++ -- Binary arithmetic primops.+ PrimArith op+ | [XType _ _, x1, x2] <- xs+ , Just op' <- convPrimArith2 op+ -> do x1' <- convRValueM config kenv tenv x1+ x2' <- convRValueM config 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 config 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 config kenv tenv x1+ return $ parens tDst' <> parens x1'+++ -- Control primops.+ PrimControl PrimControlReturn+ | [XType _ _, x1] <- xs+ -> do x1' <- convRValueM config kenv tenv x1+ return $ text "return" <+> x1'++ PrimControl PrimControlFail+ | [XType _ _] <- 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 nSuper) <- xFun+ -> do + -- Get the C name to use when calling the super, + -- which depends on how it's imported and exported.+ let Just nSuper' + = seaNameOfSuper + (lookup nSuper $ moduleImportValues $ configModule config)+ (lookup nSuper $ moduleExportValues $ configModule config)+ nSuper++ xsArgs' <- mapM (convRValueM config kenv tenv) xsArgs+ return $ text "return" <+> nSuper' <> parenss xsArgs'+++ -- Store primops.+ PrimStore op+ -> do let op' = convPrimStore op+ xs' <- mapM (convRValueM config kenv tenv) + $ filter (keepPrimArgX kenv) xs+ return $ op' <> parenss xs'++ _ -> throw $ ErrorPrimCallInvalid p xs+++-- | Ditch 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/Init.hs view
@@ -8,11 +8,12 @@ import DDC.Core.Salt.Name import DDC.Core.Module import DDC.Core.Exp+import DDC.Core.Compounds import Data.List --- | If this it the Main module, --- then add code to the 'main' function to initialise the runtime system.+-- | If this it the Main module, then insert a main function for the posix+-- entry point that initialises the runtime system and calls the real main function. -- -- Returns Nothing if this is the Main module, -- but there is no main function.@@ -22,31 +23,62 @@ -> Maybe (Module a Name) initRuntime config mm@ModuleCore{}- | isMainModule mm- = case initRuntimeTopX config (moduleBody mm) of- Nothing -> Nothing- Just x' -> Just $ mm { moduleBody = x'}+ | isMainModule mm+ = case initRuntimeTopX config (moduleBody mm) of+ Nothing -> Nothing+ Just x' -> Just + $ mm { moduleExportValues = patchMainExports (moduleExportValues mm)+ , moduleBody = x'} - | otherwise - = Just mm+ | otherwise + = Just mm +-- | Type of the POSIX main function.+posixMainType :: Type Name+posixMainType+ = tFunPE tInt (tFunPE (tPtr rTop tString) tInt)+++-- | Patch the list of export definitions to export our wrapper instead+-- of the original main function.+patchMainExports + :: [(Name, ExportSource Name)] + -> [(Name, ExportSource Name)]++patchMainExports xx+ = case xx of+ [] -> []+ (x : xs)+ | (NameVar "main", ExportSourceLocal n _) <- x+ -> (NameVar "main", ExportSourceLocal n posixMainType) : xs++ | otherwise+ -> x : patchMainExports xs++ -- | 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+ , Just (bMainOrig, xMainOrig) <- find (isMainBind . fst) bxs+ , bxs_cut <- filter (not . isMainBind . fst) bxs+ , BName _ tMainOrig <- bMainOrig+ = let + -- Rename the old main function to '_main'+ bMainOrig' = BName (NameVar "_main") $ tMainOrig - xMain' = hackBodyX (XLet a (LLet (BNone tVoid) - (xCreate a bytes))) - xMain+ -- The new entry point of the program is called 'main'.+ bMainEntry = BName (NameVar "main") $ posixMainType+ + xMainEntry = makeMainEntryX config a - in Just $ XLet a (LRec $ bxs_cut ++ [(bMain, xMain')]) x2+ in Just $ XLet a + (LRec $ bxs_cut + ++ [ (bMainOrig', xMainOrig)+ , (bMainEntry, xMainEntry)])+ x2 -- This was supposed to be the main Module, -- but there was no 'main' function for the program entry point.@@ -54,20 +86,23 @@ = 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+++-- | Make the posix main function,+-- which is the entry point to the executable.+makeMainEntryX :: Config -> a -> Exp a Name+makeMainEntryX config a+ = XLam a (BName (NameVar "argc") tInt)+ $ XLam a (BName (NameVar "argv") (tPtr rTop tString))+ $ XLet a (LLet (BNone tVoid) (xCreate a (configHeapSize config)))+ $ XLet a (LLet (BNone (tPtr rTop tObj)) + (xApps a (XVar a (UName (NameVar "_main"))) + [xAllocBoxed a rTop 0 (xNat a 0)]))+ (xInt a 0)
+ DDC/Core/Salt/Convert/Name.hs view
@@ -0,0 +1,123 @@++module DDC.Core.Salt.Convert.Name+ ( sanitizeName+ , sanitizeGlobal+ , seaNameOfSuper+ , seaNameOfLocal)+where+import DDC.Core.Salt.Name+import DDC.Core.Module+import DDC.Base.Pretty+import Data.Maybe++++-- | Like 'sanitizeGlobal' but indicate that the name is going to be visible+-- globally.+sanitizeGlobal :: String -> String+sanitizeGlobal = sanitizeName+++-- | Convert the Salt name of a supercombinator to a name we can use when+-- defining the C function.+seaNameOfSuper + :: Maybe (ImportSource Name) -- ^ How the super is imported+ -> Maybe (ExportSource Name) -- ^ How the super is exported+ -> Name -- ^ Name of the super.+ -> Maybe Doc++seaNameOfSuper mImport mExport (NameVar str)++ -- Super is defined in this module and not exported.+ | Nothing <- mImport+ , Nothing <- mExport+ = Just $ text $ "_DDC_" ++ sanitizeName str++ -- Super is defined in this module and exported to C land.+ | Nothing <- mImport+ , Just _ <- mExport+ = Just $ text $ sanitizeName str++ -- Super is imported from another module and not exported.+ | Just (ImportSourceModule _ _ _) <- mImport+ , Nothing <- mExport+ = Just $ text $ "_DDC_" ++ sanitizeName str+ + -- Super is imported from C-land and not exported.+ | Just (ImportSourceSea strSea _) <- mImport+ , Nothing <- mExport+ = Just $ text strSea++ -- ISSUE #320: Handle all the import/export combinations.+ --+ -- We don't handle the other cases because we would need to+ -- produce a wrapper to conver the names.+ | otherwise+ = Nothing+ ++seaNameOfSuper _ _ _+ = Nothing+++-- | Convert the Salt name of a local variable to a name we can use in the+-- body of a C function.+seaNameOfLocal :: Name -> Maybe Doc+seaNameOfLocal nn+ = case nn of+ NameVar str -> Just $ text $ "_" ++ sanitizeGlobal str+ _ -> Nothing+++-- Sanitize ---------------------------------------------------------------------------------------+-- | Rewrite a name to make it safe to export as an external C symbol.+--+-- Names containing unfriendly characters like '&' are prefixed with '_sym_'+-- and the '&' is replaced by 'ZAn'. Literal 'Z's such a 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+++-- | 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/Convert/Super.hs view
@@ -0,0 +1,164 @@+module DDC.Core.Salt.Convert.Super+ (convSuperM)+where+import DDC.Core.Salt.Convert.Exp+import DDC.Core.Salt.Convert.Type+import DDC.Core.Salt.Convert.Name+import DDC.Core.Salt.Convert.Base+import DDC.Core.Salt.Name+import DDC.Core.Salt.Platform+import DDC.Core.Collect+import DDC.Core.Predicates+import DDC.Core.Compounds+import DDC.Core.Module+import DDC.Core.Exp+import DDC.Type.Env (KindEnv, TypeEnv)+import DDC.Base.Pretty+import DDC.Control.Monad.Check (throw)+import qualified DDC.Type.Env as Env+import Control.Monad+import Data.Maybe++++-- | Convert a supercombinator definition to C source text.+convSuperM + :: Show a + => Platform -- ^ Target platform specifiction.+ -> Module a Name -- ^ Enclosing module.+ -> KindEnv Name -- ^ Top-level kind environment.+ -> TypeEnv Name -- ^ Top-level type environment.+ -> Name -- ^ Name of the supercombinator.+ -> Type Name -- ^ Type of the supercombinator.+ -> Exp a Name -- ^ Body expression of the supercombiantor.+ -> ConvertM a Doc++convSuperM pp mm kenv0 tenv0 nSuper tSuper xx+ = convSuperM' pp mm kenv0 tenv0 nSuper tSuper [] xx++convSuperM' pp mm kenv tenv nSuper tSuper bsParam xx+ + -- Enter into type abstractions,+ -- adding the bound name to the environment.+ | XLAM _ b x <- xx+ = convSuperM' pp mm (Env.extend b kenv) tenv + nSuper tSuper bsParam x++ -- Enter into value abstractions,+ -- remembering that we're now in a function that has this parameter.+ | XLam _ b x <- xx+ = convSuperM' pp mm kenv (Env.extend b tenv) + nSuper tSuper (bsParam ++ [b]) x++ -- Convert the function body.+ | otherwise+ = do + -- Convert the function name.+ let Just nSuper' = seaNameOfSuper + (lookup nSuper (moduleImportValues mm))+ (lookup nSuper (moduleExportValues mm))+ nSuper+ + let (_, tResult) = takeTFunArgResult $ eraseTForalls tSuper++ -- Convert the function parameters.+ bsParam' <- sequence+ $ [ convBind kenv tenv i b+ | b <- filter keepBind bsParam+ | i <- [0..] ]++ -- Convert the result type.+ tResult' <- convTypeM kenv $ eraseWitArg tResult++ -- Emit automatic variable definitions for all the local variables+ -- used in the body of the function.+ 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.+ let config = Config+ { configPlatform = pp+ , configModule = mm }+ + xBody' <- convBlockM config ContextTop kenv tenv xx++ -- Paste everything together.+ return $ vcat+ [ -- Function header.+ tResult' -- Result type.+ <+> nSuper' -- Function name.+ <+> parenss bsParam' -- Argument list.+ + -- Function body.+ , lbrace+ , indent 8 $ vcat dsVal -- Local variable definitions.+ , empty+ , indent 8 xBody' -- Statements that do some things.+ , rbrace+ , empty]+ ++-- | Convert a function parameter binding to C source text.+convBind :: KindEnv Name -> TypeEnv Name -> Int -> Bind Name -> ConvertM a Doc+convBind kenv _tenv iPos b+ = case b of + -- Anonymous arguments.+ BNone t+ -> do t' <- convTypeM kenv t+ return $ t' <+> (text $ "_arg" ++ show iPos)++ -- Named variables binders.+ BName n t+ | Just n' <- seaNameOfLocal n+ -> do t' <- convTypeM kenv t+ return $ t' <+> n'++ _ -> throw $ ErrorParameterInvalid b+++-- | 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 n t+ | Just n' <- seaNameOfLocal n+ -> do t' <- convTypeM kenv t+ 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+ + _ -> True+++parenss :: [Doc] -> Doc+parenss xs = encloseSep lparen rparen (comma <> space) xs+
DDC/Core/Salt/Convert/Type.hs view
@@ -1,10 +1,11 @@ module DDC.Core.Salt.Convert.Type ( convTypeM- , convFunctionTypeM)+ , convSuperTypeM) where import DDC.Core.Salt.Convert.Prim import DDC.Core.Salt.Convert.Base+import DDC.Core.Salt.Convert.Name import DDC.Core.Salt.Name import DDC.Core.Predicates import DDC.Core.Compounds@@ -16,7 +17,7 @@ import qualified DDC.Type.Env as Env --- Type -----------------------------------------------------------------------+-- 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@@ -35,14 +36,13 @@ -> throw $ ErrorTypeInvalid tt TCon{}- | TCon (TyConBound (UPrim (NamePrimTyCon tc) _) _) <- tt+ | TCon (TyConBound (UPrim (NamePrimTyCon tc) _) _) <- tt , Just doc <- convPrimTyCon tc -> return doc - | TCon (TyConBound (UPrim NameObjTyCon _) _) <- tt+ | TCon (TyConBound (UPrim NameObjTyCon _) _) <- tt -> return $ text "Obj" - TApp{} | Just (NamePrimTyCon PrimTyConPtr, [_, t2]) <- takePrimTyConApps tt -> do t2' <- convTypeM kenv t2@@ -54,29 +54,43 @@ _ -> throw $ ErrorTypeInvalid tt +--------------------------------------------------------------------------------------------------- -- | Convert a Salt function type to a C source prototype.-convFunctionTypeM- :: KindEnv Name- -> QualName Name -- ^ Function name.- -> Type Name -- ^ Function type.+convSuperTypeM+ :: KindEnv Name+ -> Maybe (ImportSource Name)+ -> Maybe (ExportSource Name)+ -> Name -- ^ Local name of super.+ -> Type Name -- ^ Function type. -> ConvertM a Doc -convFunctionTypeM kenv nFunc tFunc- | TForall b t' <- tFunc- = convFunctionTypeM (Env.extend b kenv) nFunc t'+convSuperTypeM kenv misrc mesrc nSuper tSuper+ | TForall b t' <- tSuper+ = convSuperTypeM (Env.extend b kenv) misrc mesrc nSuper t' - | otherwise- = do -- Qualifiers aren't supported yet.- let QualName _ n = nFunc - let nFun' = text $ sanitizeGlobal (renderPlain $ ppr n)+ | Just nFun' <- seaNameOfSuper misrc mesrc nSuper+ = do+ -- Convert the argument and return types.+ let (tsArgs, tResult) = takeTFunArgResult tSuper+ tsArgs' <- mapM (convTypeM kenv) $ filter keepParamOfType tsArgs+ tResult' <- convTypeM kenv tResult - let (tsArgs, tResult) = takeTFunArgResult tFunc+ return $ tResult' <+> nFun' <+> parenss tsArgs' - tsArgs' <- mapM (convTypeM kenv) tsArgs- tResult' <- convTypeM kenv tResult+ | otherwise+ = throw $ ErrorImportInvalid nSuper - return $ tResult' <+> nFun' <+> parenss tsArgs'+ +keepParamOfType :: Type Name -> Bool+keepParamOfType tt+ | tc : _ <- takeTApps tt+ , isWitnessType tc+ = False + | otherwise = True + parenss :: [Doc] -> Doc parenss xs = encloseSep lparen rparen (comma <> space) xs++
DDC/Core/Salt/Env.hs view
@@ -37,29 +37,29 @@ primDataDefs = fromListDataDefs -- Bool- [ DataDef+ [ makeDataDefAlg (NamePrimTyCon PrimTyConBool) [] (Just [ (NameLitBool True, []) , (NameLitBool False, []) ]) -- Nat- , DataDef (NamePrimTyCon PrimTyConNat) [] Nothing+ , makeDataDefAlg (NamePrimTyCon PrimTyConNat) [] Nothing -- Int- , DataDef (NamePrimTyCon PrimTyConInt) [] Nothing+ , makeDataDefAlg (NamePrimTyCon PrimTyConInt) [] Nothing -- Tag- , DataDef (NamePrimTyCon PrimTyConTag) [] Nothing+ , makeDataDefAlg (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+ , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 8)) [] Nothing+ , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 16)) [] Nothing+ , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 32)) [] Nothing+ , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 64)) [] Nothing -- Float 32, 64- , DataDef (NamePrimTyCon (PrimTyConFloat 32)) [] Nothing- , DataDef (NamePrimTyCon (PrimTyConFloat 64)) [] Nothing+ , makeDataDefAbs (NamePrimTyCon (PrimTyConFloat 32)) []+ , makeDataDefAbs (NamePrimTyCon (PrimTyConFloat 64)) [] ] @@ -93,9 +93,10 @@ PrimTyConWord _ -> kData PrimTyConFloat _ -> kData PrimTyConAddr -> kData- PrimTyConPtr -> (kRegion `kFun` kData `kFun` kData)+ PrimTyConPtr -> kRegion `kFun` kData `kFun` kData PrimTyConTag -> kData PrimTyConString -> kData+ PrimTyConVec _ -> kData `kFun` kData -- Types ----------------------------------------------------------------------@@ -169,6 +170,9 @@ typeOfPrimCast :: PrimCast -> Type Name typeOfPrimCast cc = case cc of+ PrimCastConvert+ -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFunPE` t1+ PrimCastPromote -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFunPE` t1
DDC/Core/Salt/Name.hs view
@@ -15,40 +15,52 @@ -- * Primitive Operators , PrimOp (..) + -- * Primative Arithmetic , PrimArith (..) , readPrimArith + -- * Primitive Calls+ , PrimCall (..)+ , readPrimCall++ -- * Primitive Casts , PrimCast (..) , readPrimCast , primCastPromoteIsValid , primCastTruncateIsValid - , PrimStore (..)- , readPrimStore-- , PrimCall (..)- , readPrimCall-+ -- * Primitive Control , PrimControl (..) , readPrimControl + -- * Primitive Store+ , PrimStore (..)+ , readPrimStore++ -- * Primitive Vector+ , PrimVec (..)+ , readPrimVec+ , multiOfPrimVec+ , liftPrimArithToVec+ , lowerPrimVecToArith+ -- * Primitive Literals , readLitInteger , readLitPrimNat , readLitPrimInt , readLitPrimWordOfBits+ , readLitPrimFloatOfBits -- * Name Parsing- , readName-- -- * Name Sanitisation- , sanitizeName- , sanitizeGlobal- , sanitizeLocal)+ , readName) where-import DDC.Core.Salt.Name.Sanitize+import DDC.Core.Salt.Name.PrimArith+import DDC.Core.Salt.Name.PrimCall+import DDC.Core.Salt.Name.PrimCast+import DDC.Core.Salt.Name.PrimControl+import DDC.Core.Salt.Name.PrimStore import DDC.Core.Salt.Name.PrimTyCon-import DDC.Core.Salt.Name.PrimOp+import DDC.Core.Salt.Name.PrimVec import DDC.Core.Salt.Name.Lit import DDC.Base.Pretty import Data.Typeable@@ -195,4 +207,44 @@ | otherwise = Nothing+++-- 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
DDC/Core/Salt/Name/Lit.hs view
@@ -4,7 +4,9 @@ ( readLitInteger , readLitPrimNat , readLitPrimInt- , readLitPrimWordOfBits)+ , readLitPrimWordOfBits+ , readLitPrimFloatOfBits)+ where import Data.List import Data.Char@@ -37,7 +39,7 @@ = Nothing --- | Read an integer with an explicit format specifier like @1234i#@.+-- | Read an integer literal with an explicit format specifier like @1234i#@. readLitPrimInt :: String -> Maybe Integer readLitPrimInt str1 | '-' : str2 <- str1@@ -79,8 +81,30 @@ = Nothing +-- | Read a float literal with an explicit format specifier like @123.00f32#@.+readLitPrimFloatOfBits :: String -> Maybe (Double, Int)+readLitPrimFloatOfBits str1+ | '-' : str2 <- str1+ , Just (d, bs) <- readLitPrimFloatOfBits str2+ = Just (negate d, bs)++ | (ds1, str2) <- span isDigit str1+ , not $ null ds1+ , Just str3 <- stripPrefix "." str2+ , (ds2, str4) <- span isDigit str3+ , not $ null ds2+ , Just str5 <- stripPrefix "f" str4+ , (bs, "#") <- span isDigit str5+ , not $ null bs+ = Just (read (ds1 ++ "." ++ ds2), 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/PrimArith.hs view
@@ -0,0 +1,86 @@++module DDC.Core.Salt.Name.PrimArith+ ( PrimArith (..)+ , readPrimArith)+where+import DDC.Base.Pretty+import Control.DeepSeq+import Data.List+++-- | 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+ | PrimArithMod -- ^ Modulus+ | 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#")+ , (PrimArithMod, "mod#")+ , (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#") ]+
+ DDC/Core/Salt/Name/PrimCall.hs view
@@ -0,0 +1,43 @@++module DDC.Core.Salt.Name.PrimCall+ ( PrimCall (..)+ , readPrimCall)+where+import DDC.Base.Pretty+import Control.DeepSeq+import Data.Char+import Data.List+++-- | 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
+ DDC/Core/Salt/Name/PrimCast.hs view
@@ -0,0 +1,96 @@++module DDC.Core.Salt.Name.PrimCast+ ( PrimCast (..)+ , readPrimCast+ , primCastPromoteIsValid+ , primCastTruncateIsValid)+where+import DDC.Core.Salt.Name.PrimTyCon+import DDC.Core.Salt.Platform+import DDC.Base.Pretty+import Control.DeepSeq+++-- | 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+ -- | Convert a value to a new representation with the same precision.+ = PrimCastConvert++ -- | 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+ PrimCastConvert -> text "convert#"+ PrimCastPromote -> text "promote#"+ PrimCastTruncate -> text "truncate#"+++readPrimCast :: String -> Maybe PrimCast+readPrimCast str+ = case str of+ "convert#" -> Just PrimCastConvert+ "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 signed 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
+ DDC/Core/Salt/Name/PrimControl.hs view
@@ -0,0 +1,40 @@++module DDC.Core.Salt.Name.PrimControl+ ( PrimControl (..)+ , readPrimControl)+where+import DDC.Base.Pretty+import Control.DeepSeq+++-- | 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/PrimOp.hs
@@ -1,401 +0,0 @@---- | 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- | PrimArithMod -- ^ Modulus- | 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#")- , (PrimArithMod, "mod#")- , (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/PrimStore.hs view
@@ -0,0 +1,125 @@++module DDC.Core.Salt.Name.PrimStore+ ( PrimStore (..)+ , readPrimStore)+where+import DDC.Base.Pretty+import Control.DeepSeq+++-- | 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+
DDC/Core/Salt/Name/PrimTyCon.hs view
@@ -25,10 +25,15 @@ | PrimTyConBool -- | @Nat#@ natural numbers.- -- Big enough to count every addressable byte in the store.+ -- Enough precision to count every object in the heap,+ -- but NOT enough precision to count every byte of memory. | PrimTyConNat -- | @Int#@ signed integers.+ -- Enough precision to count every object in the heap,+ -- but NOT enough precision to count every byte of memory.+ -- If N is the total number of objects that can exist in the heap,+ -- then the range of @Int#@ is at least (-N .. +N) inclusive. | PrimTyConInt -- | @WordN#@ machine words of the given width.@@ -37,18 +42,26 @@ -- | @FloatN#@ floating point numbers of the given width. | PrimTyConFloat Int - -- | @Tag#@ data constructor tags.- | PrimTyConTag+ -- | @VecN#@ a packed vector of N values.+ -- This is intended to have kind (Data -> Data), + -- so we use concrete vector types like @Vec4# Word32#@.+ | PrimTyConVec Int - -- | @Addr#@ raw machine addresses. Unlike pointers below,- -- a raw @Addr#@ need not to refer to memory owned - -- by the current process.+ -- | @Addr#@ a relative or absolute machine address.+ -- Enough precision to count every byte of memory.+ -- Unlike pointers below, an absolute @Addr#@ need not refer to + -- memory owned by the current process. | PrimTyConAddr -- | @Ptr#@ should point to a well-formed object owned by the -- current process. | PrimTyConPtr + -- | @Tag#@ data constructor tags.+ -- Enough precision to count every possible alternative of an + -- enumerated type.+ | PrimTyConTag+ -- | @String#@ of UTF8 characters. -- -- These are primitive until we can define our own unboxed types.@@ -71,8 +84,9 @@ PrimTyConBool -> text "Bool#" PrimTyConNat -> text "Nat#" PrimTyConInt -> text "Int#"- PrimTyConWord bits -> text "Word" <> int bits <> text "#"- PrimTyConFloat bits -> text "Float" <> int bits <> text "#"+ PrimTyConWord bits -> text "Word" <> int bits <> text "#"+ PrimTyConFloat bits -> text "Float" <> int bits <> text "#"+ PrimTyConVec arity -> text "Vec" <> int arity <> text "#" PrimTyConTag -> text "Tag#" PrimTyConAddr -> text "Addr#" PrimTyConPtr -> text "Ptr#"@@ -111,6 +125,14 @@ , elem n [32, 64] = Just $ PrimTyConFloat n + -- VecN#+ | Just rest <- stripPrefix "Vec" str+ , (ds, "#") <- span isDigit rest+ , not $ null ds+ , n <- read ds+ , elem n [2, 4, 8, 16] + = Just $ PrimTyConVec n+ | otherwise = Nothing @@ -170,10 +192,12 @@ -- Bools are representable with a single bit, but we unpack -- them into a whole word. ----- The abstract constructors `Void` and `String` have no width.+-- The constructors @Void@ and @VecN#@ and @String@ have no width.+-- primTyConWidth :: Platform -> PrimTyCon -> Maybe Integer primTyConWidth pp tc = case tc of+ PrimTyConVoid -> Nothing PrimTyConBool -> Just $ 8 * platformNatBytes pp PrimTyConNat -> Just $ 8 * platformNatBytes pp PrimTyConInt -> Just $ 8 * platformNatBytes pp@@ -182,7 +206,6 @@ PrimTyConTag -> Just $ 8 * platformTagBytes pp PrimTyConAddr -> Just $ 8 * platformAddrBytes pp PrimTyConPtr -> Just $ 8 * platformAddrBytes pp-- PrimTyConVoid -> Nothing+ PrimTyConVec _ -> Nothing PrimTyConString -> Nothing
+ DDC/Core/Salt/Name/PrimVec.hs view
@@ -0,0 +1,162 @@++module DDC.Core.Salt.Name.PrimVec+ ( PrimVec (..)+ , readPrimVec+ , multiOfPrimVec+ , liftPrimArithToVec+ , lowerPrimVecToArith)+where+import DDC.Core.Salt.Name.PrimArith+import DDC.Base.Pretty+import Control.DeepSeq+import Data.List+import Data.Char+++-- | Primitive vector operators.+data PrimVec+ -- Arithmetic ---------------------------+ -- | Negate elements of a vector.+ = PrimVecNeg + { primVecMulti :: Int }++ -- | Add elements of a vector.+ | PrimVecAdd + { primVecMulti :: Int }++ -- | Subtract elements of a vector.+ | PrimVecSub + { primVecMulti :: Int }++ -- | Multiply elements of a vector.+ | PrimVecMul + { primVecMulti :: Int }++ -- | Divide elements of a vector.+ | PrimVecDiv + { primVecMulti :: Int }++ -- Constructors -------------------------+ -- | Replicate a scalar into a vector.+ | PrimVecRep + { primVecMulti :: Int }++ -- | Pack multiple scalars into a vector+ | PrimVecPack + { primVecMulti :: Int }++ -- Projections --------------------------+ -- | Extract a single element from a vector.+ | PrimVecProj+ { primVecMulti :: Int + , primVecIndex :: Int }++ -- Memory Access ------------------------+ -- | Read multiple elements from memory.+ | PrimVecGather + { primVecMulti :: Int }++ -- | Write multiple elements to memory.+ | PrimVecScatter + { primVecMulti :: Int }+ deriving (Eq, Ord, Show)+++instance NFData PrimVec+++instance Pretty PrimVec where+ ppr op+ = case op of+ PrimVecNeg n -> text "vneg$" <> int n <> text "#"+ PrimVecAdd n -> text "vadd$" <> int n <> text "#"+ PrimVecSub n -> text "vsub$" <> int n <> text "#"+ PrimVecMul n -> text "vmul$" <> int n <> text "#"+ PrimVecDiv n -> text "vdiv$" <> int n <> text "#"++ PrimVecRep n -> text "vrep$" <> int n <> text "#"+ PrimVecPack n -> text "vpack$" <> int n <> text "#"+ PrimVecProj n ix -> text "vproj$" <> int n <> text "$" <> int ix <> text "#"++ PrimVecGather n -> text "vgather$" <> int n <> text "#"+ PrimVecScatter n -> text "vscatter$" <> int n <> text "#"+++-- | Read a primitive vector operator.+readPrimVec :: String -> Maybe PrimVec+readPrimVec str+ | Just op <- readvop1 "vneg" PrimVecNeg = Just op+ | Just op <- readvop1 "vadd" PrimVecAdd = Just op+ | Just op <- readvop1 "vsub" PrimVecSub = Just op+ | Just op <- readvop1 "vmul" PrimVecMul = Just op+ | Just op <- readvop1 "vdiv" PrimVecDiv = Just op+ | Just op <- readvop1 "vrep" PrimVecRep = Just op+ | Just op <- readvop1 "vpack" PrimVecPack = Just op+ | Just op <- readvop2 "vproj" PrimVecProj = Just op+ | Just op <- readvop1 "vgather" PrimVecGather = Just op+ | Just op <- readvop1 "vscatter" PrimVecScatter = Just op+ | otherwise = Nothing++ where readvop1 prefix op+ | Just rest <- stripPrefix (prefix ++ "$") str+ , (ds, "#") <- span isDigit rest+ , not $ null ds+ , n <- read ds+ = Just (op n)++ | otherwise = Nothing++ readvop2 prefix op+ | Just rest <- stripPrefix (prefix ++ "$") str+ , (ds1, '$' : str2) <- span isDigit rest+ , not $ null ds1+ , n1 <- read ds1+ , (ds2, "#") <- span isDigit str2+ , not $ null ds2+ , n2 <- read ds2+ = Just (op n1 n2)++ | otherwise = Nothing+++-- | Yield the multiplicity of a vector operator.+multiOfPrimVec :: PrimVec -> Maybe Int+multiOfPrimVec pp+ = case pp of+ PrimVecNeg n -> Just n+ PrimVecAdd n -> Just n+ PrimVecSub n -> Just n+ PrimVecMul n -> Just n+ PrimVecDiv n -> Just n+ PrimVecRep n -> Just n+ PrimVecPack n -> Just n+ PrimVecProj n _ -> Just n+ PrimVecGather n -> Just n+ PrimVecScatter n -> Just n+++-- | Yield the `PrimVector` that corresponds to a `PrimArith` of the+-- given multiplicity, if any.+liftPrimArithToVec :: Int -> PrimArith -> Maybe PrimVec+liftPrimArithToVec n pp+ = case pp of+ PrimArithNeg -> Just $ PrimVecNeg n+ PrimArithAdd -> Just $ PrimVecAdd n+ PrimArithSub -> Just $ PrimVecSub n+ PrimArithMul -> Just $ PrimVecMul n+ PrimArithDiv -> Just $ PrimVecDiv n+ _ -> Nothing+++-- | Yield the `PrimArith` that corresponds to a `PrimVector`, if any.+lowerPrimVecToArith :: PrimVec -> Maybe PrimArith+lowerPrimVecToArith pp+ = case pp of+ PrimVecNeg{} -> Just PrimArithNeg+ PrimVecAdd{} -> Just PrimArithAdd+ PrimVecSub{} -> Just PrimArithSub+ PrimVecMul{} -> Just PrimArithMul+ PrimVecDiv{} -> Just PrimArithDiv+ _ -> Nothing++
− DDC/Core/Salt/Name/Sanitize.hs
@@ -1,73 +0,0 @@--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/Profile.hs view
@@ -10,7 +10,6 @@ import DDC.Core.Fragment import DDC.Core.Lexer import DDC.Data.Token-import qualified DDC.Type.Env as Env -- | Language profile for Disciple Core Salt.@@ -20,10 +19,10 @@ { profileName = "Salt" , profileFeatures = features , profilePrimDataDefs = primDataDefs- , profilePrimSupers = Env.empty , profilePrimKinds = primKindEnv , profilePrimTypes = primTypeEnv - , profileTypeIsUnboxed = typeIsUnboxed }+ , profileTypeIsUnboxed = typeIsUnboxed + , profileNameIsHole = Nothing } -- | The Salt fragment doesn't support many features.@@ -33,7 +32,8 @@ { featuresFunctionalEffects = True , featuresFunctionalClosures = True , featuresDebruijnBinders = True- , featuresUnusedBindings = True }+ , featuresUnusedBindings = True + , featuresEffectCapabilities = True } -- | Lex a string to tokens, using primitive names.
DDC/Core/Salt/Runtime.hs view
@@ -33,6 +33,7 @@ import DDC.Core.Compounds import DDC.Core.Module import DDC.Core.Exp+import DDC.Base.Pretty import qualified Data.Map as Map import Data.Map (Map) @@ -47,16 +48,16 @@ -- | Kind signatures for runtime types that we use when converting to Salt.-runtimeImportKinds :: Map Name (QualName Name, Kind Name)+runtimeImportKinds :: Map Name (ImportSource 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."+ where rn (UName n, t) = (n, ImportSourceModule (ModuleName ["Runtime"]) n t)+ rn _ = error "ddc-core-salt: all runtime bindings must be named." -- | Type signatures for runtime funtions that we use when converting to Salt.-runtimeImportTypes :: Map Name (QualName Name, Type Name)+runtimeImportTypes :: Map Name (ImportSource Name) runtimeImportTypes = Map.fromList [ rn utGetTag@@ -65,8 +66,8 @@ , 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."+ where rn (UName n, t) = (n, ImportSourceSea (renderPlain $ ppr n) t)+ rn _ = error "ddc-core-salt: all runtime bindings must be named." -- Regions ----------------------------@@ -87,7 +88,7 @@ xGetTag :: a -> Type Name -> Exp a Name -> Exp a Name xGetTag a tR x2 = xApps a (XVar a $ fst utGetTag)- [ XType tR, x2 ]+ [ XType a tR, x2 ] utGetTag :: (Bound Name, Type Name) utGetTag @@ -100,8 +101,8 @@ 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)+ [ XType a tR+ , XCon a (DaConPrim (NameLitTag tag) tTag) , x2] utAllocBoxed :: (Bound Name, Type Name)@@ -121,7 +122,7 @@ xGetFieldOfBoxed a trPrime tField x2 offset = xApps a (XVar a $ fst utGetFieldOfBoxed) - [ XType trPrime, XType tField+ [ XType a trPrime, XType a tField , x2 , xNat a offset ] @@ -147,7 +148,7 @@ xSetFieldOfBoxed a trPrime tField x2 offset val = xApps a (XVar a $ fst utSetFieldOfBoxed) - [ XType trPrime, XType tField+ [ XType a trPrime, XType a tField , x2 , xNat a offset , val]@@ -168,7 +169,7 @@ xAllocRawSmall :: a -> Type Name -> Integer -> Exp a Name -> Exp a Name xAllocRawSmall a tR tag x2 = xApps a (XVar a $ fst utAllocRawSmall)- [ XType tR+ [ XType a tR , xTag a tag , x2] @@ -182,7 +183,7 @@ xPayloadOfRawSmall :: a -> Type Name -> Exp a Name -> Exp a Name xPayloadOfRawSmall a tR x2 = xApps a (XVar a $ fst utPayloadOfRawSmall) - [XType tR, x2]+ [XType a tR, x2] utPayloadOfRawSmall :: (Bound Name, Type Name) utPayloadOfRawSmall@@ -206,7 +207,7 @@ 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))+ (XType a tField)) xAddr) (xNat a offset) @@ -219,7 +220,7 @@ 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))+ (XType a tField)) xAddr) (xNat a offset)) xVal@@ -234,8 +235,8 @@ 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)) + (XType a r)) + (XType a t)) castedPtr) (xNat a offset) @@ -249,8 +250,8 @@ 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)) + (XType a r)) + (XType a t)) castedPtr) (xNat a offset)) xVal@@ -264,9 +265,9 @@ 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))+ (XType a r)) + (XType a toType))+ (XType a fromType)) xPtr uCast :: Bound Name@@ -277,7 +278,7 @@ -- | Fail with an internal error. xFail :: a -> Type Name -> Exp a Name xFail a t - = XApp a (XVar a uFail) (XType t)+ = XApp a (XVar a uFail) (XType a t) where uFail = UPrim (NamePrimOp (PrimControl PrimControlFail)) tFail tFail = TForall (BAnon kData) (TVar $ UIx 0) @@ -288,6 +289,6 @@ xReturn a t x = XApp a (XApp a (XVar a (UPrim (NamePrimOp (PrimControl PrimControlReturn)) (tForall kData $ \t1 -> t1 `tFunPE` t1)))- (XType t))+ (XType a t)) x
DDC/Core/Salt/Transfer.hs view
@@ -100,7 +100,7 @@ p = PrimCallTail arity u = UPrim (NamePrimOp (PrimCall p)) (typeOfPrimCall p) in xApps a (XVar a u) - $ (map XType (tsValArgs ++ [tResult])) + $ (map (XType a) (tsValArgs ++ [tResult])) ++ [xApps a xv (xsArgsType ++ xsArgsWit)] ++ xsArgsVal @@ -143,7 +143,7 @@ = case lts of LLet b x -> LLet b (transX tails x) LRec bxs -> LRec [(b, transX tails x) | (b, x) <- bxs]- LLetRegions{} -> lts+ LPrivate{} -> lts LWithRegion{} -> lts
LICENSE view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2013 The Disciplined Disciple Compiler Strike Force+Copyrite (K) 2007-2014 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy@@ -13,18 +13,4 @@ The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.----------------------------------------------------------------------------------Under Australian law copyright is free and automatic.-By contributing to DDC authors grant all rights they have regarding their-contributions to the other members of the Disciplined Disciple Compiler Strike-Force, past, present and future, as well as placing their contributions under-the above license.--Use "darcs show authors" to get a list of Strike Force members.- ---------------------------------------------------------------------------------Redistributions of libraries in ./external are governed by their own licenses:-- - TinyPTC GNU Lesser General Public License-
ddc-core-salt.cabal view
@@ -1,5 +1,5 @@ Name: ddc-core-salt-Version: 0.3.2.1+Version: 0.4.1.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force@@ -14,22 +14,24 @@ Library Build-Depends: - base == 4.6.*,+ base >= 4.6 && < 4.8,+ array >= 0.4 && < 0.6, deepseq == 1.3.*, containers == 0.5.*,- array == 0.4.*, transformers == 0.3.*, mtl == 2.1.*,- ddc-base == 0.3.2.*,- ddc-core == 0.3.2.*+ ddc-base == 0.4.1.*,+ ddc-core == 0.4.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.Convert DDC.Core.Salt.Env+ DDC.Core.Salt.Name+ DDC.Core.Salt.Platform+ DDC.Core.Salt.Profile+ DDC.Core.Salt.Runtime+ DDC.Core.Salt.Transfer DDC.Core.Salt DDC.Core.Lite.Compounds@@ -38,6 +40,22 @@ DDC.Core.Lite Other-modules:+ DDC.Core.Salt.Convert.Exp+ DDC.Core.Salt.Convert.Init+ DDC.Core.Salt.Convert.Name+ DDC.Core.Salt.Convert.Prim+ DDC.Core.Salt.Convert.Super+ DDC.Core.Salt.Convert.Type+ + DDC.Core.Salt.Name.Lit+ DDC.Core.Salt.Name.PrimArith+ DDC.Core.Salt.Name.PrimCall+ DDC.Core.Salt.Name.PrimCast+ DDC.Core.Salt.Name.PrimControl+ DDC.Core.Salt.Name.PrimStore+ DDC.Core.Salt.Name.PrimTyCon+ DDC.Core.Salt.Name.PrimVec+ DDC.Core.Lite.Convert.Base DDC.Core.Lite.Convert.Data DDC.Core.Lite.Convert.Type@@ -46,21 +64,14 @@ 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-missing-methods -fno-warn-unused-do-bind Extensions: