diff --git a/DDC/Core/Lite/Compounds.hs b/DDC/Core/Lite/Compounds.hs --- a/DDC/Core/Lite/Compounds.hs +++ b/DDC/Core/Lite/Compounds.hs @@ -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# diff --git a/DDC/Core/Lite/Convert.hs b/DDC/Core/Lite/Convert.hs --- a/DDC/Core/Lite/Convert.hs +++ b/DDC/Core/Lite/Convert.hs @@ -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 diff --git a/DDC/Core/Lite/Convert/Base.hs b/DDC/Core/Lite/Convert/Base.hs --- a/DDC/Core/Lite/Convert/Base.hs +++ b/DDC/Core/Lite/Convert/Base.hs @@ -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. diff --git a/DDC/Core/Lite/Convert/Data.hs b/DDC/Core/Lite/Convert/Data.hs --- a/DDC/Core/Lite/Convert/Data.hs +++ b/DDC/Core/Lite/Convert/Data.hs @@ -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 diff --git a/DDC/Core/Lite/Convert/Type.hs b/DDC/Core/Lite/Convert/Type.hs --- a/DDC/Core/Lite/Convert/Type.hs +++ b/DDC/Core/Lite/Convert/Type.hs @@ -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 diff --git a/DDC/Core/Lite/Env.hs b/DDC/Core/Lite/Env.hs --- a/DDC/Core/Lite/Env.hs +++ b/DDC/Core/Lite/Env.hs @@ -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. diff --git a/DDC/Core/Lite/Layout.hs b/DDC/Core/Lite/Layout.hs --- a/DDC/Core/Lite/Layout.hs +++ b/DDC/Core/Lite/Layout.hs @@ -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 diff --git a/DDC/Core/Lite/Name.hs b/DDC/Core/Lite/Name.hs --- a/DDC/Core/Lite/Name.hs +++ b/DDC/Core/Lite/Name.hs @@ -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 diff --git a/DDC/Core/Lite/Profile.hs b/DDC/Core/Lite/Profile.hs --- a/DDC/Core/Lite/Profile.hs +++ b/DDC/Core/Lite/Profile.hs @@ -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 diff --git a/DDC/Core/Salt/Compounds.hs b/DDC/Core/Salt/Compounds.hs --- a/DDC/Core/Salt/Compounds.hs +++ b/DDC/Core/Salt/Compounds.hs @@ -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) diff --git a/DDC/Core/Salt/Convert.hs b/DDC/Core/Salt/Convert.hs --- a/DDC/Core/Salt/Convert.hs +++ b/DDC/Core/Salt/Convert.hs @@ -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 diff --git a/DDC/Core/Salt/Convert/Base.hs b/DDC/Core/Salt/Convert/Base.hs --- a/DDC/Core/Salt/Convert/Base.hs +++ b/DDC/Core/Salt/Convert/Base.hs @@ -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 diff --git a/DDC/Core/Salt/Convert/Exp.hs b/DDC/Core/Salt/Convert/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Convert/Exp.hs @@ -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 + diff --git a/DDC/Core/Salt/Convert/Init.hs b/DDC/Core/Salt/Convert/Init.hs --- a/DDC/Core/Salt/Convert/Init.hs +++ b/DDC/Core/Salt/Convert/Init.hs @@ -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) diff --git a/DDC/Core/Salt/Convert/Name.hs b/DDC/Core/Salt/Convert/Name.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Convert/Name.hs @@ -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 + diff --git a/DDC/Core/Salt/Convert/Super.hs b/DDC/Core/Salt/Convert/Super.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Convert/Super.hs @@ -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 + diff --git a/DDC/Core/Salt/Convert/Type.hs b/DDC/Core/Salt/Convert/Type.hs --- a/DDC/Core/Salt/Convert/Type.hs +++ b/DDC/Core/Salt/Convert/Type.hs @@ -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 + + diff --git a/DDC/Core/Salt/Env.hs b/DDC/Core/Salt/Env.hs --- a/DDC/Core/Salt/Env.hs +++ b/DDC/Core/Salt/Env.hs @@ -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 diff --git a/DDC/Core/Salt/Name.hs b/DDC/Core/Salt/Name.hs --- a/DDC/Core/Salt/Name.hs +++ b/DDC/Core/Salt/Name.hs @@ -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 diff --git a/DDC/Core/Salt/Name/Lit.hs b/DDC/Core/Salt/Name/Lit.hs --- a/DDC/Core/Salt/Name/Lit.hs +++ b/DDC/Core/Salt/Name/Lit.hs @@ -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 + diff --git a/DDC/Core/Salt/Name/PrimArith.hs b/DDC/Core/Salt/Name/PrimArith.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Name/PrimArith.hs @@ -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#") ] + diff --git a/DDC/Core/Salt/Name/PrimCall.hs b/DDC/Core/Salt/Name/PrimCall.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Name/PrimCall.hs @@ -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 diff --git a/DDC/Core/Salt/Name/PrimCast.hs b/DDC/Core/Salt/Name/PrimCast.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Name/PrimCast.hs @@ -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 diff --git a/DDC/Core/Salt/Name/PrimControl.hs b/DDC/Core/Salt/Name/PrimControl.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Name/PrimControl.hs @@ -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 + + diff --git a/DDC/Core/Salt/Name/PrimOp.hs b/DDC/Core/Salt/Name/PrimOp.hs deleted file mode 100644 --- a/DDC/Core/Salt/Name/PrimOp.hs +++ /dev/null @@ -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 - diff --git a/DDC/Core/Salt/Name/PrimStore.hs b/DDC/Core/Salt/Name/PrimStore.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Name/PrimStore.hs @@ -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 + diff --git a/DDC/Core/Salt/Name/PrimTyCon.hs b/DDC/Core/Salt/Name/PrimTyCon.hs --- a/DDC/Core/Salt/Name/PrimTyCon.hs +++ b/DDC/Core/Salt/Name/PrimTyCon.hs @@ -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 diff --git a/DDC/Core/Salt/Name/PrimVec.hs b/DDC/Core/Salt/Name/PrimVec.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Salt/Name/PrimVec.hs @@ -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 + + diff --git a/DDC/Core/Salt/Name/Sanitize.hs b/DDC/Core/Salt/Name/Sanitize.hs deleted file mode 100644 --- a/DDC/Core/Salt/Name/Sanitize.hs +++ /dev/null @@ -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 - diff --git a/DDC/Core/Salt/Profile.hs b/DDC/Core/Salt/Profile.hs --- a/DDC/Core/Salt/Profile.hs +++ b/DDC/Core/Salt/Profile.hs @@ -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. diff --git a/DDC/Core/Salt/Runtime.hs b/DDC/Core/Salt/Runtime.hs --- a/DDC/Core/Salt/Runtime.hs +++ b/DDC/Core/Salt/Runtime.hs @@ -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 diff --git a/DDC/Core/Salt/Transfer.hs b/DDC/Core/Salt/Transfer.hs --- a/DDC/Core/Salt/Transfer.hs +++ b/DDC/Core/Salt/Transfer.hs @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 - diff --git a/ddc-core-salt.cabal b/ddc-core-salt.cabal --- a/ddc-core-salt.cabal +++ b/ddc-core-salt.cabal @@ -1,5 +1,5 @@ Name: ddc-core-salt -Version: 0.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: