diff --git a/DDC/Build/Builder.hs b/DDC/Build/Builder.hs --- a/DDC/Build/Builder.hs +++ b/DDC/Build/Builder.hs @@ -9,11 +9,13 @@ where import DDC.Build.Platform import DDC.Base.Pretty hiding (()) +import Data.List import System.FilePath -import System.Exit +import System.Exit hiding (die) import System.Process import qualified DDC.Core.Salt.Platform as Llvm + -- | Configuration information for a builder that is not platform specific. data BuilderConfig = BuilderConfig @@ -23,9 +25,12 @@ -- | Directory that holds the shared objects for the runtime -- system and base library. - , builderConfigBaseLibDir :: FilePath } + , builderConfigBaseLibDir :: FilePath + -- | Runtime library link with. + , builderConfigLibFile :: FilePath -> FilePath -> FilePath } + -- | Actions to use to invoke external compilation tools. data Builder = Builder @@ -63,7 +68,7 @@ , buildAs :: FilePath -> FilePath -> IO () -- | Link an executable. - , buildLdExe :: FilePath -> FilePath -> IO () + , buildLdExe :: [FilePath] -> FilePath -> IO () -- | Link a static library. , buildLdLibStatic :: [FilePath] -> FilePath -> IO () @@ -175,19 +180,18 @@ , buildBaseSrcDir = builderConfigBaseSrcDir config , buildBaseLibDir = builderConfigBaseLibDir config - -- Use -disable-cfi to disable Call Frame Identification (CFI) directives - -- because the OSX system assembler doesn't support them. , buildLlc = \llFile sFile -> doCmd "LLVM compiler" [(2, BuilderCanceled)] - [ "llc -O3 -march=x86 -relocation-model=pic -disable-cfi" - , llFile + [ "opt -O3" + , llFile + , "| llc -O3 -march=x86 -relocation-model=pic" , "-o", sFile ] , buildCC = \cFile oFile -> doCmd "C compiler" [(2, BuilderCanceled)] - [ "gcc -Werror -std=c99 -O3 -m32" + [ "cc -Werror -std=c99 -O3 -m32" , "-c", cFile , "-o", oFile , "-I" ++ builderConfigBaseSrcDir config "sea/runtime" @@ -196,17 +200,20 @@ , buildAs = \sFile oFile -> doCmd "assembler" [(2, BuilderCanceled)] - [ "as -arch i386" + [ "llvm-mc -arch x86 -filetype=obj" , "-o", oFile , sFile ] , buildLdExe - = \oFile binFile + = \oFiles binFile -> doCmd "linker" [(2, BuilderCanceled)] - [ "gcc -m32" + [ "cc -m32 -Wl,-dead_strip" , "-o", binFile - , oFile - , builderConfigBaseLibDir config "libddc-runtime.dylib" ] + , intercalate " " oFiles + , builderConfigBaseLibDir config + builderConfigLibFile config + "libddc-runtime.a" + "libddc-runtime.dylib" ] , buildLdLibStatic = \oFiles libFile @@ -216,7 +223,7 @@ , buildLdLibShared = \oFiles libFile -> doCmd "linker" [(2, BuilderCanceled)] - $ [ "gcc -m32 -dynamiclib -undefined dynamic_lookup" + $ [ "cc -m32 -dynamiclib -undefined dynamic_lookup" , "-o", libFile ] ++ oFiles } @@ -230,19 +237,18 @@ , buildBaseSrcDir = builderConfigBaseSrcDir config , buildBaseLibDir = builderConfigBaseLibDir config - -- Use -disable-cfi to disable Call Frame Identification (CFI) directives - -- because the OSX system assembler doesn't support them. , buildLlc = \llFile sFile -> doCmd "LLVM compiler" [(2, BuilderCanceled)] - [ "llc -O3 -march=x86-64 -relocation-model=pic -disable-cfi" - , llFile + [ "opt -O3" + , llFile + , "| llc -O3 -march=x86-64 -relocation-model=pic" , "-o", sFile ] , buildCC = \cFile oFile -> doCmd "C compiler" [(2, BuilderCanceled)] - [ "gcc -Werror -std=c99 -O3 -m64" + [ "cc -Werror -std=c99 -O3 -m64" , "-c", cFile , "-o", oFile , "-I" ++ builderConfigBaseSrcDir config "sea/runtime" @@ -251,17 +257,20 @@ , buildAs = \sFile oFile -> doCmd "assembler" [(2, BuilderCanceled)] - [ "as -arch x86_64" + [ "llvm-mc -arch x86-64 -filetype=obj" , "-o", oFile , sFile ] , buildLdExe - = \oFile binFile + = \oFiles binFile -> doCmd "linker" [(2, BuilderCanceled)] - [ "gcc -m64" + [ "cc -m64 -Wl,-dead_strip" , "-o", binFile - , oFile - , builderConfigBaseLibDir config "libddc-runtime.dylib" ] + , intercalate " " oFiles + , builderConfigBaseLibDir config + builderConfigLibFile config + "libddc-runtime.a" + "libddc-runtime.dylib" ] , buildLdLibStatic = \oFiles libFile @@ -271,7 +280,7 @@ , buildLdLibShared = \oFiles libFile -> doCmd "linker" [(2, BuilderCanceled)] - $ [ "gcc -m64 -dynamiclib -undefined dynamic_lookup" + $ [ "cc -m64 -dynamiclib -undefined dynamic_lookup" , "-o", libFile ] ++ oFiles } @@ -311,12 +320,15 @@ , sFile ] , buildLdExe - = \oFile binFile + = \oFiles binFile -> doCmd "linker" [(2, BuilderCanceled)] [ "gcc -m32" , "-o", binFile - , oFile - , builderConfigBaseLibDir config "libddc-runtime.so" ] + , intercalate " " oFiles + , builderConfigBaseLibDir config + builderConfigLibFile config + "libddc-runtime.a" + "libddc-runtime.so" ] , buildLdLibStatic = \oFiles libFile @@ -365,12 +377,15 @@ , sFile ] , buildLdExe - = \oFile binFile + = \oFiles binFile -> doCmd "linker" [(2, BuilderCanceled)] [ "gcc -m64" , "-o", binFile - , oFile - , builderConfigBaseLibDir config "libddc-runtime.so" ] + , intercalate " " oFiles + , builderConfigBaseLibDir config + builderConfigLibFile config + "libddc-runtime.a" + "libddc-runtime.so" ] , buildLdLibStatic = \oFiles libFile @@ -418,12 +433,15 @@ , sFile ] , buildLdExe - = \oFile binFile + = \oFiles binFile -> doCmd "linker" [(2, BuilderCanceled)] [ "gcc -m32" , "-o", binFile - , oFile - , builderConfigBaseLibDir config "libddc-runtime.so" ] + , intercalate " " $ map normalise oFiles + , builderConfigBaseLibDir config + builderConfigLibFile config + "libddc-runtime.a" + "libddc-runtime.so" ] , buildLdLibStatic = \oFiles libFile @@ -473,12 +491,14 @@ -- Note on Cygwin we need to use 'gcc-4' explicitly because plain 'gcc' -- is a symlink, which Windows doesn't really support. , buildLdExe - = \oFile binFile + = \oFiles binFile -> doCmd "linker" [(2, BuilderCanceled)] [ "gcc-4 -m32" , "-o", normalise binFile - , normalise oFile - , normalise $ builderConfigBaseLibDir config "libddc-runtime.a" ] + , intercalate " " $ map normalise oFiles + , normalise $ builderConfigBaseLibDir config + "libddc-runtime.a" ] + -- configRuntimeLinkStrategy is ignored , buildLdLibStatic = \oFiles libFile @@ -526,12 +546,14 @@ , normalise sFile ] , buildLdExe - = \oFile binFile + = \oFiles binFile -> doCmd "linker" [(2, BuilderCanceled)] [ "gcc -m32" , "-o", normalise binFile - , normalise oFile - , normalise $ builderConfigBaseLibDir config "libddc-runtime.a" ] + , intercalate " " $ map normalise oFiles + , normalise $ builderConfigBaseLibDir config + "libddc-runtime.a" ] + -- configRuntimeLinkStrategy is ignored , buildLdLibStatic = \oFiles libFile diff --git a/DDC/Build/Interface/Base.hs b/DDC/Build/Interface/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Build/Interface/Base.hs @@ -0,0 +1,93 @@ + +module DDC.Build.Interface.Base + ( Interface (..) + , makeInterfaceTearLine + , takeInterfaceTearLine + , isInterfaceTearLine) +where +import DDC.Core.Module +import DDC.Core.Pretty +import DDC.Core.Exp.Annot +import Data.Maybe +import Data.Time.Clock +import qualified Data.Char as Char +import qualified DDC.Core.Tetra as Tetra +import qualified DDC.Core.Salt as Salt + + +--------------------------------------------------------------------------------------------------- +-- | Module interface. +data Interface ta sa + = Interface + { -- | Path that the interface was loaded from. + interfaceFilePath :: FilePath + + -- | Last modification time of the interface file, + -- used to determine when the source needs to be rebuilt. + , interfaceTimeStamp :: UTCTime + + , interfaceVersion :: String + , interfaceModuleName :: ModuleName + , interfaceTetraModule :: Maybe (Module ta Tetra.Name) + , interfaceSaltModule :: Maybe (Module sa Salt.Name) } + + +--------------------------------------------------------------------------------------------------- +instance Pretty (Interface ta sa) where + ppr i + = (text "ddc interface" <+> text (interfaceVersion i)) + <> line <> line + <> vcat [ text $ makeInterfaceTearLine "Meta" + , text "module-meta" <+> lbrace <> line + <> indent 8 (vcat + [ hsep [text "name:", ppr $ interfaceModuleName i ] ]) + <> line <> rbrace] + + -- Include the full unoptimised core code in interface files. + -- We include the unoptimised code so that the modules that inline + -- functions from this one are not sensitive to the optimisation flags + -- use here. If we included the optimised code it would make it harder + -- to reason about the overall compilation process. + <> (case interfaceTetraModule i of + Just m -> vcat [ line + , text $ makeInterfaceTearLine "Tetra" + , ppr m ] + Nothing -> empty) + + -- Include the header of the Salt module. + -- We don't need the function definitions because inlining is performed + -- using the higher level Tetra code. + <> (case interfaceSaltModule i of + Just m -> + -- zap the module body so we don't get the function definitions. + let m' = m { moduleBody = xUnit (annotOfExp $ moduleBody m) } + in vcat [ line + , text $ makeInterfaceTearLine "Salt" + , ppr m' ] + Nothing -> empty) + + +--------------------------------------------------------------------------------------------------- +-- | Tear line to separate sections of the interface file. +-- We use '~' because it's not used in the core language syntax. +makeInterfaceTearLine :: String -> String +makeInterfaceTearLine name + = "~~ " ++ name ++ " " ++ replicate (80 - 4 - length name) '~' + +-- | Take the name from an interface tear line, if it is one. +takeInterfaceTearLine :: String -> Maybe String +takeInterfaceTearLine str + | '~' : '~' : ' ' : str2 <- str + , (name, str3) <- span (not . Char.isSpace) str2 + , (' ' : rest) <- str3 + , all (== '~') rest + = Just name + + | otherwise + = Nothing + +-- | Check if this string is an interface tear line. +isInterfaceTearLine :: String -> Bool +isInterfaceTearLine str + = isJust $ takeInterfaceTearLine str + diff --git a/DDC/Build/Interface/Load.hs b/DDC/Build/Interface/Load.hs new file mode 100644 --- /dev/null +++ b/DDC/Build/Interface/Load.hs @@ -0,0 +1,285 @@ + +-- | Loader for DDC interface files. +module DDC.Build.Interface.Load + ( loadInterface + , Error (..) + , InterfaceAA) +where +import DDC.Build.Interface.Base +import DDC.Core.Check (AnTEC) +import DDC.Core.Module +import DDC.Base.Pretty +import DDC.Core.Transform.Reannotate +import Data.Time.Clock +import Control.Monad +import qualified DDC.Core.Load as Load +import qualified DDC.Core.Tetra as Tetra +import qualified DDC.Build.Language.Tetra as Tetra +import qualified DDC.Core.Salt as Salt +import qualified DDC.Build.Language.Salt as Salt +import qualified DDC.Data.SourcePos as BP +import qualified Data.Char as Char +import qualified Data.List as List + + +--------------------------------------------------------------------------------------------------- +-- | Problems that can arise when loading an interface file. +data Error + -- | Empty Interface file. + = ErrorEmpty + + -- | No module meta information. + | ErrorNoMeta + + -- | Duplicate module information. + | ErrorDuplicate + + -- | Bad magic numbers / header information in alleged interface file. + -- This probably isn't an interface file. + | ErrorBadMagic + { errorFilePath :: FilePath + , errorLine :: Int } + + -- | Parse error in Interface file. + | ErrorParse + { errorFilePath :: FilePath + , errorLine :: Int} + + -- | Parser error at end of input. + | ErrorParseEnd + + -- | Error when loading a tetra core module from the interface file. + | ErrorLoadTetra (Load.Error Tetra.Name Tetra.Error) + + -- | Error when loading a salt core module from the interface file. + | ErrorLoadSalt (Load.Error Salt.Name Salt.Error) + + +instance Pretty Error where + ppr ErrorEmpty + = vcat [ text "Empty interface file." ] + + ppr ErrorNoMeta + = vcat [ text "No metadata section in interface file." ] + + ppr ErrorDuplicate + = vcat [ text "Duplicate section in interface file." ] + + ppr (ErrorBadMagic path l) + = vcat [ text path <> text ":" <> int l + , text "Bad header in interface file." ] + + ppr (ErrorParse path l) + = vcat [ text path <> text ":" <> int l + , text "Parse error in interface file." ] + + ppr ErrorParseEnd + = vcat [ text "Parse error at end of interface file." ] + + ppr (ErrorLoadTetra err) + = vcat [ text "Error when loading Tetra module from interface file." + , indent 2 $ ppr err ] + + ppr (ErrorLoadSalt err) + = vcat [ text "Error when loading Salt module from interface file." + , indent 2 $ ppr err ] + + +--------------------------------------------------------------------------------------------------- +-- | Line numbers. +type LineNumber = Int + +-- | Parser for some thing. +type Parser a + = [(LineNumber, String)] + -> Either Error a + +-- | Type of annotated interface. +-- As don't store full Salt code in interface files, +-- we just set the annotation for it to () +type InterfaceAA + = Interface (AnTEC BP.SourcePos Tetra.Name) () + + +--------------------------------------------------------------------------------------------------- +-- | Load an interface file. +loadInterface + :: FilePath -- ^ File path of interface file, for error messages. + -> UTCTime -- ^ TimeStamp of interface file. + -> String -- ^ Interface file source. + -> Either Error InterfaceAA + +loadInterface pathInterface timeStamp str + = let -- Attach line numbers to ach line + ls = lines str + lsNum = zip [1..] ls + in pInterface pathInterface timeStamp lsNum + + +-- | Parse an interface file. +pInterface + :: FilePath -- ^ Path of interface file. + -> UTCTime -- ^ TimeStamp of interface file. + -> Parser InterfaceAA + +pInterface _pathInt _timeStamp [] + = Left ErrorEmpty + +pInterface pathInt timeStamp ((n, str) : rest) + -- Skip over blank lines + | all (\c -> Char.isSpace c || c == '\n') str + = pInterface pathInt timeStamp rest + + -- The interface needs to start with the magic words and version number. + | ["ddc", "interface", version] <- words str + = do cs <- pComponents pathInt rest + + -- We need exactly one module meta-data component. + modName <- case [m | m@ComponentMeta{} <- cs] of + [m] -> return $ componentModuleName m + _ -> Left $ ErrorNoMeta + + -- Accept a tetra module in the interface file. + mTetra <- case [m | m@ComponentTetraModule{} <- cs] of + [] -> return Nothing + [m] -> return $ Just $ componentTetraModule m + _ -> Left ErrorDuplicate + + -- Accept a salt module in the interface file. + mSalt <- case [m | m@ComponentSaltModule{} <- cs] of + [] -> return Nothing + [m] -> return $ Just $ componentSaltModule m + _ -> Left ErrorDuplicate + + return $ Interface + { interfaceFilePath = pathInt + , interfaceTimeStamp = timeStamp + , interfaceVersion = version + , interfaceModuleName = modName + , interfaceTetraModule = mTetra + , interfaceSaltModule = liftM (reannotate (const ())) mSalt } + + | otherwise + = Left $ ErrorBadMagic pathInt n + + +--------------------------------------------------------------------------------------------------- +-- | A component of the interface file. +-- We use this as an intermediate form during parsing. +data Component + = ComponentMeta + { componentModuleName :: ModuleName} + + | ComponentTetraModule + { componentTetraModule :: Module (AnTEC BP.SourcePos Tetra.Name) Tetra.Name } + + | ComponentSaltModule + { componentSaltModule :: Module (AnTEC BP.SourcePos Salt.Name) Salt.Name } + deriving Show + + +--------------------------------------------------------------------------------------------------- +-- | Parse some components of an interface file. +pComponents :: FilePath -> Parser [Component] +pComponents _ [] + = return [] + +pComponents pathInterface (l : ls) + -- skip blank lines + | all Char.isSpace (snd l) + = pComponents pathInterface ls + + -- parse a single section + | isInterfaceTearLine (snd l) + = do let (ls', rest) = List.break (isInterfaceTearLine . snd) ls + c <- pComponent pathInterface (l : ls') + cs <- pComponents pathInterface rest + return $ c : cs + + | otherwise + = Left $ ErrorParse pathInterface (fst l) + + +--------------------------------------------------------------------------------------------------- +-- | Parse a single component of an interface file. +pComponent :: FilePath -> Parser Component +pComponent _ [] + = Left $ ErrorParseEnd + +pComponent pathInt ((n, l) : rest) + -- skip blank lines + | all Char.isSpace l + = pComponent pathInt rest + + -- load a module meta-data section. + | Just "Meta" <- takeInterfaceTearLine l + = pComponentMeta pathInt rest + + -- load a Tetra core module section. + | Just "Tetra" <- takeInterfaceTearLine l + = case Load.loadModuleFromString Tetra.fragment pathInt (n + 1) + Load.Recon (unlines $ map snd rest) of + (Left err, _) -> Left $ ErrorLoadTetra err + (Right m, _) -> return $ ComponentTetraModule m + + -- load a Salt core module section. + | Just "Salt" <- takeInterfaceTearLine l + = case Load.loadModuleFromString Salt.fragment pathInt (n + 1) + Load.Recon (unlines $ map snd rest) of + (Left err, _) -> Left $ ErrorLoadSalt err + (Right m, _) -> return $ ComponentSaltModule m + + -- this thing didn't parse. + | otherwise + = Left $ ErrorParse pathInt n + + +--------------------------------------------------------------------------------------------------- +-- | Parse module meta data from an interface file. +pComponentMeta :: FilePath -> Parser Component +pComponentMeta _pathInt [] + = Left ErrorParseEnd + +pComponentMeta pathInt nls@((n, _) : _) + | "module-meta" : "{" : "name:" : strModName : "}" : [] + <- tokenize $ concatMap snd nls + , Just modName <- moduleNameOfString strModName + = return $ ComponentMeta + { componentModuleName = modName } + + | otherwise + = Left $ ErrorParse pathInt n + + +--------------------------------------------------------------------------------------------------- +-- | Tokenise the interface header containing module meta data. +tokenize :: String -> [String] +tokenize str + = go [] str + where go acc [] = pop acc [] + + go acc (c : cs) + | Char.isSpace c = pop acc (go [] cs) + | c == '{' = pop acc ("{" : go [] cs) + | c == '}' = pop acc ("}" : go [] cs) + | otherwise = go (c : acc) cs + + pop acc x + = case acc of + [] -> x + _ -> reverse acc : x + + +-- | Parse a String as a `ModuleName`, or Nothing if it isn't one. +moduleNameOfString :: String -> Maybe ModuleName +moduleNameOfString str + = Just $ ModuleName $ go str + where + go s + | elem '.' s + , (n, '.' : rest) <- span (/= '.') s + = n : go rest + + | otherwise + = [s] + diff --git a/DDC/Build/Interface/Store.hs b/DDC/Build/Interface/Store.hs new file mode 100644 --- /dev/null +++ b/DDC/Build/Interface/Store.hs @@ -0,0 +1,256 @@ + +module DDC.Build.Interface.Store + ( Store + , new, wrap, load + + , Meta (..) + , getMeta + , getModuleNames + , getInterfaces + + , Super (..) + , findSuper) +where +import DDC.Base.Pretty +import DDC.Build.Interface.Base +import DDC.Build.Interface.Load +import DDC.Core.Call +import DDC.Core.Module +import DDC.Type.Exp +import System.Directory +import Data.Time.Clock +import Data.IORef +import Data.Maybe +import Data.Map (Map) +import qualified DDC.Core.Tetra as E +import qualified DDC.Core.Salt as A +import qualified Data.Map as Map + + +--------------------------------------------------------------------------------------------------- +-- | Abstract API to a collection of module interfaces. +-- +-- This lives in IO land because in future we want to demand-load the +-- inferface files as needed, rather than loading the full dependency +-- tree. Keeping it in IO means that callers must also be in IO. +data Store + = Store + { -- | Metadata for interface files currently in the store. + storeMeta :: IORef [Meta] + + -- | Lookup the definition of the given top-level super, + -- from one or more of the provided modules. + , storeSupers :: IORef (Map ModuleName (Map E.Name Super)) + + -- | Fully loaded interface files. + -- In future we want to load parts of interface files on demand, + -- and not the whole lot. + , storeInterfaces :: IORef [InterfaceAA] } + + +--------------------------------------------------------------------------------------------------- +-- | Metadata for interfaces currently loaded into the store. +data Meta + = Meta + { metaFilePath :: FilePath + , metaTimeStamp :: UTCTime + , metaModuleName :: ModuleName } + deriving Show + +instance Pretty Meta where + ppr (Meta path stamp name) + = hsep [ padL 60 $ text (show path) + , padL 30 $ text (show stamp) + , text (show name)] + + +-- | Interface for some top-level super. +data Super + = Super + { -- | Name of the super. + superName :: E.Name + + -- | Where the super was imported from. + -- + -- This is the module that the name was resolved from. If that + -- module re-exported an imported name then this may not be the + -- module the super was actually defined in. + , superModuleName :: ModuleName + + -- | Tetra type for the super. + , superTetraType :: Type E.Name + + -- | Salt type for the super. + , superSaltType :: Type A.Name + + -- | Import source for the super. + -- + -- This can be used to refer to the super from a client module. + , superImportValue :: ImportValue E.Name } + + +--------------------------------------------------------------------------------------------------- +-- | An empty interface store. +new :: IO Store +new + = do refMeta <- newIORef [] + refSupers <- newIORef Map.empty + refInterfaces <- newIORef [] + return $ Store + { storeMeta = refMeta + , storeSupers = refSupers + , storeInterfaces = refInterfaces } + + +-- | Add a pre-loaded interface file to the store. +wrap :: Store -> InterfaceAA -> IO () +wrap store ii + = do modifyIORef (storeMeta store) + $ \meta -> meta ++ [metaOfInterface ii] + + modifyIORef (storeSupers store) + $ \supers -> Map.insert (interfaceModuleName ii) + (supersOfInterface ii) + supers + + modifyIORef (storeInterfaces store) + $ \iis -> iis ++ [ii] + + +-- | Load a new interface from a file. +load :: FilePath -> IO (Either Error InterfaceAA) +load filePath + = do timeStamp <- getModificationTime filePath + str <- readFile filePath + return $ loadInterface filePath timeStamp str + + +-- | Get metadata of interfaces currently in the store. +getMeta :: Store -> IO [Meta] +getMeta store + = do mm <- readIORef (storeMeta store) + return $ mm + + +-- | Get names of the modules currently in the store. +getModuleNames :: Store -> IO [ModuleName] +getModuleNames store + = do supers <- readIORef (storeSupers store) + return $ Map.keys supers + + +-- | Get the fully loaded interfaces. +getInterfaces :: Store -> IO [InterfaceAA] +getInterfaces store + = do ints <- readIORef (storeInterfaces store) + return ints + + +-- | See if a super is defined in any of the given modules, and if so +-- return the module name and super type. +-- +-- NOTE: This function returns an IO [Super] in preparation for the case +-- where we load data from interface files on demand. We want to ensure +-- that the caller is also in IO, to make the refactoring easier later. +-- +findSuper + :: Store + -> E.Name -- ^ Name of desired super. + -> [ModuleName] -- ^ Names of modules to search. + -> IO [Super] + +findSuper store n modNames + = do supers <- readIORef (storeSupers store) + return $ mapMaybe + (\modName -> do + nSupers <- Map.lookup modName supers + Map.lookup n nSupers) + modNames + + +--------------------------------------------------------------------------------------------------- +-- | Extract metadata from an interface. +metaOfInterface :: InterfaceAA -> Meta +metaOfInterface ii + = Meta + { metaFilePath = interfaceFilePath ii + , metaTimeStamp = interfaceTimeStamp ii + , metaModuleName = interfaceModuleName ii } + + +-- | Extract a map of super interfaces from the given module interface. +-- +-- This contains all the information needed to import a super into +-- a client module. +-- +supersOfInterface :: InterfaceAA -> Map E.Name Super +supersOfInterface ii + | Just mmTetra <- interfaceTetraModule ii + , Just mmSalt <- interfaceSaltModule ii + = let + -- The current module name. + modName = interfaceModuleName ii + + -- Collect Tetra types for all supers exported by the module. + ntsTetra + = Map.fromList + [ (n, t) | (n, esrc) <- moduleExportValues mmTetra + , let Just t = takeTypeOfExportSource esrc ] + + -- Collect Salt types of all supers exported by the module. + ntsSalt + = Map.fromList + [ (n, t) | (n, esrc) <- moduleExportValues mmSalt + , let Just t = takeTypeOfExportSource esrc ] + + -- Build call patterns for all locally defined supers. + -- The call pattern is the number of type parameters then value parameters + -- for the super. We assume all supers are in prenex form, so they take + -- all their type arguments before their value arguments. + makeLocalArity b x + | BName nSuper _ <- b + , cs <- takeCallConsFromExp x + , Just (csType, csValue, csBox) <- splitStdCallCons cs + = (nSuper, (length csType, length csValue, length csBox)) + + | otherwise = error "ddc-build.supersOfInterface: type is not in prenex form." + + nsLocalArities :: Map E.Name (Int, Int, Int) + = Map.fromList + $ mapTopBinds makeLocalArity + $ mmTetra + + -- Build an ImportSource for the given super name. A client module + -- can use this to import the super into itself. + makeImportValue n + + -- Super was defined as a top-level binding in the current module. + | Just (aType, aValue, nBoxes) <- Map.lookup n nsLocalArities + , Just tTetra <- Map.lookup n ntsTetra + = ImportValueModule modName n tTetra (Just (aType, aValue, nBoxes)) + + -- Super was imported into the current module from somewhere else. + -- Pass along the same import declaration to the client. + | Just impt <- lookup n (moduleImportValues mmTetra) + = impt + + | otherwise = error $ "ddc-build.supersOfInterface: no source" ++ show n + + makeSuper n tTetra + | E.NameVar s <- n + = Just $ Super + { superName = n + , superModuleName = moduleName mmTetra + , superTetraType = tTetra + , superSaltType = let Just t = Map.lookup (A.NameVar s) ntsSalt in t + , superImportValue = makeImportValue n } + | otherwise = Nothing + + + in Map.fromList + [ (n, super) | (n, tTetra) <- Map.toList ntsTetra + , let Just super = makeSuper n tTetra ] + + | otherwise + = Map.empty + diff --git a/DDC/Build/Language.hs b/DDC/Build/Language.hs --- a/DDC/Build/Language.hs +++ b/DDC/Build/Language.hs @@ -8,9 +8,7 @@ where import DDC.Core.Fragment import DDC.Build.Language.Base -import DDC.Build.Language.Lite as Lite import DDC.Build.Language.Salt as Salt -import DDC.Build.Language.Eval as Eval import DDC.Build.Language.Flow as Flow import DDC.Build.Language.Zero as Zero import DDC.Build.Language.Tetra as Tetra @@ -18,19 +16,17 @@ -- | Supported language profiles. -- --- One of @Tetra@, @Lite@, @Salt@, @Eval@, @Flow@, @Zero@. +-- One of @Tetra@, @Salt@, @Eval@, @Flow@, @Zero@. languages :: [(String, Language)] languages = [ ( "Tetra", Tetra.language) - , ( "Lite", Lite.language) , ( "Salt", Salt.language) - , ( "Eval", Eval.language) , ( "Flow", Flow.language) , ( "Zero", Zero.language) ] -- | Return the language fragment definition corresponding to the given --- file extension. eg @dcl@ gives the definition of the Lite language. +-- file extension. eg @dct@ gives the definition of the Tetra language. languageOfExtension :: String -> Maybe Language languageOfExtension ext = let -- Strip of dots at the front. @@ -41,9 +37,7 @@ _ -> ext in case ext' of "dct" -> Just Tetra.language - "dcl" -> Just Lite.language "dcs" -> Just Salt.language - "dcv" -> Just Eval.language "dcf" -> Just Flow.language "dcz" -> Just Zero.language _ -> Nothing diff --git a/DDC/Build/Language/Base.hs b/DDC/Build/Language/Base.hs --- a/DDC/Build/Language/Base.hs +++ b/DDC/Build/Language/Base.hs @@ -10,6 +10,7 @@ import DDC.Core.Transform.Namify import DDC.Core.Transform.Rewrite import DDC.Base.Pretty +import DDC.Base.Name import Control.DeepSeq import Data.Typeable import Data.Map (Map) @@ -27,7 +28,8 @@ , Pretty n , Pretty (err (AnTEC BP.SourcePos n)) , Pretty (err (AnTEC () n)) - , NFData n) + , NFData n + , CompoundName n) => Language (Bundle s n err) diff --git a/DDC/Build/Language/Eval.hs b/DDC/Build/Language/Eval.hs deleted file mode 100644 --- a/DDC/Build/Language/Eval.hs +++ /dev/null @@ -1,75 +0,0 @@ - --- | The `Eval` fragment can be interpreted with our semantic interpreter. -module DDC.Build.Language.Eval - ( language - , bundle - , fragment - , profile) -where -import DDC.Build.Language.Base -import DDC.Core.Simplifier -import DDC.Core.Transform.Namify -import DDC.Core.Eval.Profile -import DDC.Core.Eval.Name -import DDC.Core.Fragment -import DDC.Core.Eval.Check as Eval -import DDC.Type.Exp -import DDC.Type.Env (Env) -import qualified DDC.Type.Env as Env -import qualified Data.Map as Map -import Control.Monad.State.Strict - - --- | Language definition for Disciple Core Eval. -language :: Language -language = Language bundle - - --- | Language bundle for Disciple Core Eval. -bundle :: Bundle Int Name Eval.Error -bundle = Bundle - { bundleFragment = fragment - , bundleModules = Map.empty - , bundleStateInit = 0 :: Int - , bundleSimplifier = Trans Id - , bundleMakeNamifierT = makeNamifier freshT - , bundleMakeNamifierX = makeNamifier freshX - , bundleRewriteRules = Map.empty } - - --- | Fragment definition for Disciple Core Eval. -fragment :: Fragment Name Eval.Error -fragment - = Fragment - { fragmentProfile = evalProfile - , fragmentExtension = "dcv" - , fragmentReadName = readName - , fragmentLexModule = lexModuleString - , fragmentLexExp = lexExpString - , fragmentCheckModule = checkCapsModule - , fragmentCheckExp = checkCapsX } - - -profile = evalProfile - --- | Create a new type variable name that is not in the given environment. -freshT :: Env Name -> Bind Name -> State Int Name -freshT env bb - = do i <- get - put (i + 1) - let n = NameVar ("t" ++ show i) - case Env.lookupName n env of - Nothing -> return n - _ -> freshT env bb - - --- | Create a new value variable name that is not in the given environment. -freshX :: Env Name -> Bind Name -> State Int Name -freshX env bb - = do i <- get - put (i + 1) - let n = NameVar ("v" ++ show i) - case Env.lookupName n env of - Nothing -> return n - _ -> freshX env bb - diff --git a/DDC/Build/Language/Flow.hs b/DDC/Build/Language/Flow.hs --- a/DDC/Build/Language/Flow.hs +++ b/DDC/Build/Language/Flow.hs @@ -18,15 +18,14 @@ import qualified Data.Map as Map --- | Language definition for Disciple Core Lite. +-- | Language definition for Disciple Core Flow. language :: Language language = Language bundle --- | Language bundle for Disciple Core Lite. +-- | Language bundle for Disciple Core Flow. bundle :: Bundle Int Name Error -bundle - = Bundle +bundle = Bundle { bundleFragment = fragment , bundleModules = Map.empty , bundleStateInit = 0 :: Int @@ -36,7 +35,7 @@ , bundleRewriteRules = Map.empty } --- | Fragement definition for Disciple Core Lite. +-- | Fragement definition for Disciple Core Flow. fragment :: Fragment Name Error fragment = Fragment diff --git a/DDC/Build/Language/Lite.hs b/DDC/Build/Language/Lite.hs deleted file mode 100644 --- a/DDC/Build/Language/Lite.hs +++ /dev/null @@ -1,73 +0,0 @@ - --- | The `Lite` fragment is a desugared version of Disciple Core that has all --- the polymorphism of System-F2 along with algebraic data types. -module DDC.Build.Language.Lite - ( language - , bundle - , fragment - , freshT - , freshX) -where -import DDC.Build.Language.Base -import DDC.Core.Simplifier -import DDC.Core.Transform.Namify -import DDC.Core.Fragment -import DDC.Core.Lite as Lite -import DDC.Type.Exp -import DDC.Type.Env (Env) -import qualified DDC.Type.Env as Env -import qualified Data.Map as Map -import Control.Monad.State.Strict - - --- | Language definition for Disciple Core Lite. -language :: Language -language = Language bundle - - --- | Language bundle for Disciple Core Lite. -bundle :: Bundle Int Name Lite.Error -bundle - = Bundle - { bundleFragment = fragment - , bundleModules = Map.empty - , bundleStateInit = 0 :: Int - , bundleSimplifier = Trans Id - , bundleMakeNamifierT = makeNamifier freshT - , bundleMakeNamifierX = makeNamifier freshX - , bundleRewriteRules = Map.empty } - - --- | Fragement definition for Disciple Core Lite. -fragment :: Fragment Name Lite.Error -fragment - = Fragment - { fragmentProfile = profile - , fragmentExtension = "dcl" - , fragmentReadName = readName - , fragmentLexModule = lexModuleString - , fragmentLexExp = lexExpString - , fragmentCheckModule = const Nothing - , fragmentCheckExp = const Nothing } - - --- | Create a new type variable name that is not in the given environment. -freshT :: Env Name -> Bind Name -> State Int Name -freshT env bb - = do i <- get - put (i + 1) - let n = NameVar ("t" ++ show i) - case Env.lookupName n env of - Nothing -> return n - _ -> freshT env bb - - --- | Create a new value variable name that is not in the given environment. -freshX :: Env Name -> Bind Name -> State Int Name -freshX env bb - = do i <- get - put (i + 1) - let n = NameVar ("x" ++ show i) - case Env.lookupName n env of - Nothing -> return n - _ -> freshX env bb diff --git a/DDC/Build/Language/Salt.hs b/DDC/Build/Language/Salt.hs --- a/DDC/Build/Language/Salt.hs +++ b/DDC/Build/Language/Salt.hs @@ -12,9 +12,9 @@ import DDC.Core.Simplifier import DDC.Core.Transform.Namify import DDC.Core.Fragment -import DDC.Core.Salt as Salt import DDC.Type.Exp import DDC.Type.Env (Env) +import qualified DDC.Core.Salt as A import qualified DDC.Type.Env as Env import qualified Data.Map as Map import Control.Monad.State.Strict @@ -26,7 +26,7 @@ -- | Language bundle for Disciple Core Salt. -bundle :: Bundle Int Name Salt.Error +bundle :: Bundle Int A.Name A.Error bundle = Bundle { bundleFragment = fragment , bundleModules = Map.empty @@ -38,35 +38,35 @@ -- | Fragment definition for Disciple Core Salt. -fragment :: Fragment Name Salt.Error +fragment :: Fragment A.Name A.Error fragment = Fragment - { fragmentProfile = profile + { fragmentProfile = A.profile , fragmentExtension = "dcs" - , fragmentReadName = readName - , fragmentLexModule = lexModuleString - , fragmentLexExp = lexExpString + , fragmentReadName = A.readName + , fragmentLexModule = A.lexModuleString + , fragmentLexExp = A.lexExpString , fragmentCheckModule = const Nothing , fragmentCheckExp = const Nothing } -- | Create a new type variable name that is not in the given environment. -freshT :: Env Name -> Bind Name -> State Int Name +freshT :: Env A.Name -> Bind A.Name -> State Int A.Name freshT env bb = do i <- get put (i + 1) - let n = NameVar ("t" ++ show i) + let n = A.NameVar ("t" ++ show i) case Env.lookupName n env of Nothing -> return n _ -> freshT env bb -- | Create a new value variable name that is not in the given environment. -freshX :: Env Name -> Bind Name -> State Int Name +freshX :: Env A.Name -> Bind A.Name -> State Int A.Name freshX env bb = do i <- get put (i + 1) - let n = NameVar ("x" ++ show i) + let n = A.NameVar ("x" ++ show i) case Env.lookupName n env of Nothing -> return n _ -> freshX env bb diff --git a/DDC/Build/Language/Tetra.hs b/DDC/Build/Language/Tetra.hs --- a/DDC/Build/Language/Tetra.hs +++ b/DDC/Build/Language/Tetra.hs @@ -44,4 +44,3 @@ , fragmentLexExp = E.lexExpString , fragmentCheckModule = E.checkModule , fragmentCheckExp = const Nothing } - diff --git a/DDC/Build/Language/Zero.hs b/DDC/Build/Language/Zero.hs --- a/DDC/Build/Language/Zero.hs +++ b/DDC/Build/Language/Zero.hs @@ -13,6 +13,7 @@ import DDC.Core.Fragment hiding (Error) import DDC.Core.Transform.Namify import DDC.Base.Pretty +import DDC.Base.Name import DDC.Data.Token import DDC.Type.Exp import Data.Typeable @@ -65,16 +66,31 @@ -- Wrap the names we use for the zero fragment, -- so they get pretty printed properly. data Name - = Name String + = Name String + | NameExt Name String deriving (Eq, Ord, Show, Typeable) + instance NFData Name where - rnf (Name str) = rnf str + rnf (Name str) = rnf str + rnf (NameExt n str) = rnf n `seq` rnf str + instance Pretty Name where - ppr (Name str) = text str + ppr (Name str) = text str + ppr (NameExt n str) = ppr n <> text "$" <> text str +instance CompoundName Name where + extendName n str + = NameExt n str + + splitName nn + = case nn of + NameExt n str -> Just (n, str) + _ -> Nothing + + -- | Lex a string to tokens, using primitive names. -- -- The first argument gives the starting source line number. @@ -84,7 +100,7 @@ where rn (Token t sp) = case renameTok (Just . Name) t of Just t' -> Token t' sp - Nothing -> Token (KJunk "lexical error") sp + Nothing -> Token (KErrorJunk "lexical error") sp -- | Lex a string to tokens, using primitive names. @@ -96,7 +112,7 @@ where rn (Token t sp) = case renameTok (Just . Name) t of Just t' -> Token t' sp - Nothing -> Token (KJunk "lexical error") sp + Nothing -> Token (KErrorJunk "lexical error") sp -- | Create a new type variable name that is not in the given environment. diff --git a/DDC/Build/Pipeline.hs b/DDC/Build/Pipeline.hs --- a/DDC/Build/Pipeline.hs +++ b/DDC/Build/Pipeline.hs @@ -21,10 +21,6 @@ , PipeTetra (..) , pipeTetra - -- * Core Lite modules - , PipeLite (..) - , pipeLite - -- * Core Flow modules , PipeFlow (..) , pipeFlow diff --git a/DDC/Build/Pipeline/Core.hs b/DDC/Build/Pipeline/Core.hs --- a/DDC/Build/Pipeline/Core.hs +++ b/DDC/Build/Pipeline/Core.hs @@ -7,9 +7,6 @@ , PipeTetra (..) , pipeTetra - , PipeLite (..) - , pipeLite - , PipeFlow (..) , pipeFlow) where @@ -19,40 +16,46 @@ import DDC.Build.Language import DDC.Core.Simplifier import DDC.Base.Pretty +import DDC.Base.Name import DDC.Data.Canned import DDC.Llvm.Pretty () import qualified DDC.Core.Flow as Flow import qualified DDC.Core.Flow.Profile as Flow -import qualified DDC.Core.Flow.Transform.Slurp as Flow +import qualified DDC.Core.Flow.Transform.Forward as Flow import qualified DDC.Core.Flow.Transform.Melt as Flow import qualified DDC.Core.Flow.Transform.Wind as Flow import qualified DDC.Core.Flow.Transform.Rates.SeriesOfVector as Flow +import qualified DDC.Core.Flow.Convert as Flow -import qualified DDC.Core.Tetra as Tetra +import qualified DDC.Core.Tetra.Transform.Curry as Tetra import qualified DDC.Core.Tetra.Transform.Boxing as Tetra +import qualified DDC.Core.Tetra as Tetra -import qualified DDC.Core.Lite as Lite +import qualified DDC.Core.Babel.PHP as PHP import qualified DDC.Core.Salt.Platform as Salt import qualified DDC.Core.Salt.Runtime as Salt import qualified DDC.Core.Salt as Salt +import qualified DDC.Core.Transform.Unshare as C import qualified DDC.Core.Transform.Reannotate as C -import qualified DDC.Core.Transform.Deannotate as C import qualified DDC.Core.Transform.Namify as C -import qualified DDC.Core.Transform.Forward as Forward import qualified DDC.Core.Transform.Snip as Snip import qualified DDC.Core.Transform.Flatten as Flatten import qualified DDC.Core.Transform.Eta as Eta +import qualified DDC.Core.Transform.Beta as Beta +import qualified DDC.Core.Transform.Lambdas as Lambdas +import qualified DDC.Core.Transform.Forward as Forward import qualified DDC.Core.Simplifier as C import qualified DDC.Core.Fragment as C import qualified DDC.Core.Check as C import qualified DDC.Core.Pretty as C import qualified DDC.Core.Module as C -import qualified DDC.Core.Exp as C +import qualified DDC.Core.Exp.Annot as C + import qualified DDC.Type.Env as Env import qualified Control.Monad.State.Strict as S @@ -60,6 +63,7 @@ import Control.DeepSeq +--------------------------------------------------------------------------------------------------- -- | Process a core module. data PipeCore a n where -- Plumb the module on without transforming it. @@ -99,7 +103,8 @@ -- Apply a simplifier to a module. PipeCoreSimplify - :: !(Fragment n err) + :: (Pretty a, CompoundName n) + => !(Fragment n err) -> !s -> !(Simplifier s a n) -> ![PipeCore () n] @@ -107,21 +112,16 @@ -- Treat a module as belonging to the Core Tetra fragment from now on. PipeCoreAsTetra - :: ![PipeTetra (C.AnTEC a Tetra.Name)] - -> PipeCore (C.AnTEC a Tetra.Name) Tetra.Name - - -- Treat a module as belonging to the Core Lite fragment from now on. - PipeCoreAsLite - :: ![PipeLite] - -> PipeCore (C.AnTEC () Lite.Name) Lite.Name + :: ![PipeTetra a] + -> PipeCore a Tetra.Name - -- Treat a module as beloning to the Core Flow fragment from now on. + -- Treat a module as belonging to the Core Flow fragment from now on. PipeCoreAsFlow :: Pretty a => ![PipeFlow a] -> PipeCore a Flow.Name - -- Treat a module as beloning to the Core Salt fragment from now on. + -- Treat a module as belonging to the Core Salt fragment from now on. PipeCoreAsSalt :: Pretty a => ![PipeSalt a] @@ -217,10 +217,6 @@ -> {-# SCC "PipeCoreAsTetra" #-} liftM concat $ mapM (pipeTetra mm) pipes - PipeCoreAsLite !pipes - -> {-# SCC "PipeCoreAsLite" #-} - liftM concat $ mapM (pipeLite mm) pipes - PipeCoreAsFlow !pipes -> {-# SCC "PipeCoreAsFlow" #-} liftM concat $ mapM (pipeFlow mm) pipes @@ -248,7 +244,7 @@ go (errs ++ err) rest --- PipeTetra ------------------------------------------------------------------ +-- PipeTetra -------------------------------------------------------------------------------------- -- | Process a Core Tetra module. data PipeTetra a where -- Output the module in core language syntax. @@ -256,6 +252,12 @@ :: !Sink -> PipeTetra a + -- Manage currying of functions. + PipeTetraCurry + :: (NFData a, Show a) + => ![PipeCore () Tetra.Name] + -> PipeTetra (C.AnTEC a Tetra.Name) + -- Manage boxing of numeric values. PipeTetraBoxing :: (NFData a, Show a) @@ -270,7 +272,14 @@ -> ![PipeCore a Salt.Name] -> PipeTetra (C.AnTEC a Tetra.Name) + -- Print as PHP code + PipeTetraToPHP + :: (NFData a, Show a) + => !Sink + -> PipeTetra a + + -- | Process a Core Tetra module. pipeTetra :: C.Module a Tetra.Name @@ -281,8 +290,14 @@ = case pp of PipeTetraOutput !sink -> {-# SCC "PipeTetraOutput" #-} - pipeSink (renderIndent $ ppr mm) sink + pipeSink (renderIndent $ ppr mm) sink + PipeTetraCurry !pipes + -> {-# SCC "PipeTetraCurry" #-} + case Tetra.curryModule (C.unshareModule mm) of + Left err -> return [ErrorTetraConvert err] + Right mm' -> pipeCores mm' pipes + PipeTetraBoxing !pipes -> {-# SCC "PipeTetraBoxing" #-} pipeCores (Tetra.boxingModule mm) pipes @@ -297,43 +312,22 @@ of Left err -> return [ErrorTetraConvert err] Right mm' -> pipeCores mm' pipes - - --- PipeLite ------------------------------------------------------------------- --- | Process a Core Lite module. -data PipeLite - -- | Output the module in core language syntax. - = PipeLiteOutput !Sink - - -- | Convert the module to the Core Salt Fragment. - | PipeLiteToSalt !Salt.Platform - !Salt.Config - ![PipeCore () Salt.Name] - - --- | Process a Core Lite module. -pipeLite :: C.Module (C.AnTEC () Lite.Name) Lite.Name - -> PipeLite - -> IO [Error] + PipeTetraToPHP !sink + -> {-# SCC "PipeTetraToPHP" #-} + let -- Snip program to expose intermediate bindings. + mm_snip = Flatten.flatten + $ Snip.snip (Snip.configZero) mm -pipeLite !mm !pp - = case pp of - PipeLiteOutput !sink - -> {-# SCC "PipeLiteOutput" #-} - pipeSink (renderIndent $ ppr mm) sink + -- The floater needs bindings to be fully named. + namifierT = C.makeNamifier Tetra.freshT Env.empty + namifierX = C.makeNamifier Tetra.freshX Env.empty + mm_namified = S.evalState (C.namify namifierT namifierX mm_snip) 0 - PipeLiteToSalt !platform !runConfig !pipes - -> {-# SCC "PipeLiteToSalt" #-} - case Lite.saltOfLiteModule platform runConfig - (C.profilePrimDataDefs Lite.profile) - (C.profilePrimKinds Lite.profile) - (C.profilePrimTypes Lite.profile) - mm - of Left err -> return [ErrorLiteConvert err] - Right mm' -> pipeCores mm' pipes + doc = PHP.phpOfModule mm_namified + in pipeSink (renderIndent doc) sink --- PipeFlow ------------------------------------------------------------------- +-- PipeFlow --------------------------------------------------------------------------------------- -- | Process a Core Flow module. data PipeFlow a where -- Output the module in core language syntax. @@ -378,7 +372,12 @@ :: [PipeCore () Flow.Name] -> PipeFlow (C.AnTEC () Flow.Name) + -- Wind loop# primops into tail recursive loops. + PipeFlowToTetra + :: [PipeCore () Salt.Name] + -> PipeFlow (C.AnTEC () Flow.Name) + -- | Process a Core Flow module. pipeFlow :: C.Module a Flow.Name -> PipeFlow a @@ -416,16 +415,7 @@ -- Float worker functions and initializers into their use sites, -- leaving only flow operators at the top-level. - isFloatable lts - = case lts of - C.LLet (C.BName _ _) x - | Flow.isSeriesOperator (C.deannotate (const Nothing) x) - -> Forward.FloatDeny - _ -> Forward.FloatForce - - mm_float = C.result $ Forward.forwardModule Flow.profile - (Forward.Config isFloatable False) - mm_namified + mm_float = Flow.forwardProcesses mm_namified in pipeCores mm_float pipes @@ -448,20 +438,26 @@ namifierX = C.makeNamifier Flow.freshX Env.empty mm_namified = S.evalState (C.namify namifierT namifierX mm_snip) 0 - -- Float worker functions and initializers into their use sites, - -- leaving only flow operators at the top-level. - isFloatable lts - = case lts of - C.LLet (C.BName _ _) x - | Flow.isVectorOperator (C.deannotate (const Nothing) x) - -> Forward.FloatDeny - _ -> Forward.FloatForce - mm_float = C.result $ Forward.forwardModule Flow.profile - (Forward.Config isFloatable False) - mm_namified + floatControl l + = case l of + C.LLet _ x + | Just _ <- C.takeXLamFlags x + -> Forward.FloatForceUsedOnce + _ -> Forward.FloatDeny + -- Force forward all worker functions. + -- Anything that's not a vector op will be treated as an external, + -- so that's fine. + mm_float = C.result + $ Forward.forwardModule Flow.profile + (Forward.Config floatControl False) + $ C.reannotate (const ()) mm_namified + + + goRate + -- Rate inference uses the types = case C.checkModule (C.configOfProfile Flow.profile) mm_float C.Recon of (Left err, _) -> return [ErrorCoreTransform err] @@ -470,8 +466,8 @@ -> let mm_stripped = C.reannotate (const ()) mm' mm_flow = fst $ Flow.seriesOfVectorModule mm_stripped - -- Check again to synthesise types - in case C.checkModule (C.configOfProfile Flow.profile) mm_flow C.Recon of + -- Synthesise the types of any newly created bindings. + in case C.checkModule (C.configOfProfile Flow.profile) mm_flow C.Synth of (Left err, _ct) -> return [ErrorCoreTransform err] @@ -500,6 +496,59 @@ let mm_stripped = C.reannotate (const ()) mm mm_wound = Flow.windModule mm_stripped in pipeCores mm_wound pipes + + PipeFlowToTetra !pipes + -> {-# SCC "PipeFlowToTetra" #-} + let + -- Apply any lambdas we can + mm_beta = C.result $ Beta.betaReduce Flow.profile + (Beta.configZero { Beta.configBindRedexes = True}) + mm + + -- Eta-expand all the leftovers so they can be lifted + mm_eta = C.result $ Eta.etaModule Flow.profile + (Eta.configZero { Eta.configExpand = True}) + mm_beta + + + -- Lift up any remaining lambdas + mm_lift = Lambdas.lambdasModule Flow.profile mm_eta + + -- Snip program so arguments and case scrutinees are just variables + mm_snip = Flatten.flatten + $ Snip.snip + Snip.configZero + mm_lift + + -- The floater needs bindings to be fully named. + namifierT = C.makeNamifier Flow.freshT Env.empty + namifierX = C.makeNamifier Flow.freshX Env.empty + mm_namified = S.evalState (C.namify namifierT namifierX mm_snip) 0 + + in case Flow.tetraOfFlowModule mm_namified of + Left err -> return [ErrorFlowConvert err] + Right mm' -> + case C.checkModule (C.configOfProfile Salt.profile) mm' C.Recon of + (Left err, _ct) + -> return [ErrorCoreTransform err] + (Right mm_check', _ct) + -> let mm_reannot' = C.reannotate (const ()) mm_check' + + floatControl l + = case l of + C.LLet b _ + | Just _ <- C.takeTFun $ C.typeOfBind b + -> Forward.FloatForce + _ -> Forward.FloatAllow + + -- Forward all functions + mm_float = C.result + $ Forward.forwardModule Salt.profile + (Forward.Config floatControl True) + $ C.reannotate (const ()) mm_reannot' + + in pipeCores mm_float pipes + -- | Process a Flow module with several different pipes. diff --git a/DDC/Build/Pipeline/Error.hs b/DDC/Build/Pipeline/Error.hs --- a/DDC/Build/Pipeline/Error.hs +++ b/DDC/Build/Pipeline/Error.hs @@ -27,8 +27,8 @@ -- | Error converting the module from Tetra to Salt. | forall err. Pretty err => ErrorTetraConvert !err - -- | Error converting the module from Lite to Salt. - | forall err. Pretty err => ErrorLiteConvert !err + -- | Error converting the module from Tetra to Salt. + | forall err. Pretty err => ErrorFlowConvert !err -- | Error when transforming core program. | forall err. Pretty err => ErrorCoreTransform !err @@ -51,15 +51,15 @@ , indent 2 (ppr err') ] ErrorSaltConvert err' - -> vcat [ text "Fragment violation when converting Salt module to C code." + -> vcat [ text "Fragment violation when converting Salt module to target code." , indent 2 (ppr err') ] ErrorTetraConvert err' -> vcat [ text "Fragment violation when converting Tetra module to Salt module." , indent 2 (ppr err') ] - ErrorLiteConvert err' - -> vcat [ text "Fragment violation when converting Lite module to Salt module." + ErrorFlowConvert err' + -> vcat [ text "Fragment violation when converting Flow module to Tetra module." , indent 2 (ppr err') ] ErrorCoreTransform err' @@ -67,5 +67,6 @@ , indent 2 (ppr err') ] -instance NFData Error +instance NFData Error where + rnf !_ = () diff --git a/DDC/Build/Pipeline/Llvm.hs b/DDC/Build/Pipeline/Llvm.hs --- a/DDC/Build/Pipeline/Llvm.hs +++ b/DDC/Build/Pipeline/Llvm.hs @@ -22,7 +22,8 @@ , pipeFileLlvm :: FilePath , pipeFileAsm :: FilePath , pipeFileObject :: FilePath - , pipeFileExe :: Maybe FilePath + , pipeFileExe :: Maybe FilePath + , pipeLinkOtherObjects :: [FilePath] , pipeKeepLlvmFiles :: Bool , pipeKeepAsmFiles :: Bool } deriving (Show) @@ -43,7 +44,7 @@ pipeSink (renderIndent $ ppr mm) sink PipeLlvmCompile - !builder !llPath !sPath !oPath !mExePath + !builder !llPath !sPath !oPath !mExePath !osLinkOther !keepLlvmFiles !keepAsmFiles -> {-# SCC "PipeLlvmCompile" #-} do -- Write out the LLVM source file. @@ -62,7 +63,7 @@ -> return () Just exePath - -> do buildLdExe builder oPath exePath + -> do buildLdExe builder (oPath : osLinkOther) exePath return ()) -- Remove LLVM IR files if we weren't asked for them. diff --git a/DDC/Build/Pipeline/Salt.hs b/DDC/Build/Pipeline/Salt.hs --- a/DDC/Build/Pipeline/Salt.hs +++ b/DDC/Build/Pipeline/Salt.hs @@ -101,9 +101,11 @@ PipeSaltToLlvm !platform !more -> {-# SCC "PipeSaltToLlvm" #-} do let !mm_cut = C.reannotate (const ()) mm - let !mm' = Llvm.convertModule platform mm_cut - results <- mapM (pipeLlvm mm') more - return $ concat results + case Llvm.convertModule platform mm_cut of + Left err -> return [ErrorSaltConvert err] + Right mm' + -> do results <- mapM (pipeLlvm mm') more + return $ concat results PipeSaltCompile !platform !builder !cPath !oPath !mExePath @@ -124,7 +126,7 @@ (case mExePath of Nothing -> return () Just exePath - -> do buildLdExe builder oPath exePath + -> do buildLdExe builder [oPath] exePath return ()) -- Remove intermediate .c files if we weren't asked for them. diff --git a/DDC/Build/Pipeline/Text.hs b/DDC/Build/Pipeline/Text.hs --- a/DDC/Build/Pipeline/Text.hs +++ b/DDC/Build/Pipeline/Text.hs @@ -1,17 +1,22 @@ {-# LANGUAGE GADTs #-} module DDC.Build.Pipeline.Text - ( PipeText (..) + ( -- InterfaceAA + PipeText (..) , pipeText) where import DDC.Build.Pipeline.Error import DDC.Build.Pipeline.Sink import DDC.Build.Pipeline.Core import DDC.Build.Language +import DDC.Build.Interface.Store (Store) import DDC.Base.Pretty -import qualified DDC.Source.Tetra.ToCore as SE +import qualified DDC.Build.Transform.Resolve as B + +import qualified DDC.Source.Tetra.Convert as SE import qualified DDC.Source.Tetra.Transform.Defix as SE import qualified DDC.Source.Tetra.Transform.Expand as SE +import qualified DDC.Source.Tetra.Pretty () import qualified DDC.Source.Tetra.Parser as SE import qualified DDC.Source.Tetra.Lexer as SE import qualified DDC.Source.Tetra.Env as SE @@ -20,13 +25,14 @@ import qualified DDC.Core.Tetra as CE import qualified DDC.Core.Tetra.Env as CE -import qualified DDC.Core.Parser as C +import qualified DDC.Core.Fragment as C import qualified DDC.Core.Transform.SpreadX as C import qualified DDC.Core.Check as C import qualified DDC.Core.Load as C import qualified DDC.Core.Lexer as C import qualified DDC.Base.Parser as BP import qualified DDC.Data.SourcePos as SP +import qualified DDC.Data.Token as Token import Control.DeepSeq @@ -45,9 +51,12 @@ -> PipeText n err PipeTextLoadSourceTetra - :: !Sink -- Sink for source tokens. - -> !Sink -- Sink for core code before final type checking. - -> !Sink -- Sink for type checker trace. + :: !Sink -- Sink for source tokens. + -> !Sink -- Sink for desugared source code. + -> !Sink -- Sink for core tetra code after conversoin. + -> !Sink -- Sink for core tetra code before type checking. + -> !Sink -- Sink for type checker trace. + -> !Store -- Interface store. -> ![PipeCore (C.AnTEC BP.SourcePos CE.Name) CE.Name] -> PipeText n err @@ -83,29 +92,27 @@ PipeTextLoadSourceTetra sinkTokens - sinkPreCheck - sinkCheckerTrace pipes + sinkDesugared sinkCore sinkPreCheck sinkCheckerTrace + store pipes -> {-# SCC "PipeTextLoadSourceTetra" #-} - let goParse + let + goParse = do -- Lex the input text into source tokens. let tokens = SE.lexModuleString srcName srcLine str - pipeSink (unlines $ map show $ tokens) sinkTokens - - -- Parse the source tokens. - let context = C.Context - { C.contextTrackedEffects = True - , C.contextTrackedClosures = True - , C.contextFunctionalEffects = False - , C.contextFunctionalClosures = False } + -- Dump tokens to file. + pipeSink (unlines $ map (show . Token.tokenTok) $ tokens) + sinkTokens + -- Parse the tokens into a Source Tetra module. case BP.runTokenParser C.describeTok srcName - (SE.pModule context) tokens of + (SE.pModule SE.context) tokens of Left err -> return [ErrorLoad err] Right mm -> goDesugar mm goDesugar mm - = case SE.defix SE.defaultFixTable mm of + = -- Resolve fixity of infix operators. + case SE.defix SE.defaultFixTable mm of Left err -> return [ErrorLoad err] Right mm' -> goToCore mm' @@ -114,23 +121,50 @@ let mm_expand = SE.expand SE.configDefault SE.primKindEnv SE.primTypeEnv mm + -- Dump desguared source code. + pipeSink (renderIndent $ ppr mm_expand) sinkDesugared + -- Convert Source Tetra to Core Tetra. - -- This source position is used to annotate the let expression - -- that holds all the top-level bindings. - let sp = SP.SourcePos "" 1 1 - let mm_core = SE.toCoreModule sp mm_expand + -- This source position is used to annotate the + -- let-expression that holds all the top-level bindings. + let sp = SP.SourcePos "" 1 1 + case SE.coreOfSourceModule sp mm_expand of + Left err + -> return [ErrorLoad err] + Right mm_core + -> do -- Dump Core Tetra. + pipeSink (renderIndent $ ppr mm_core) sinkCore + + -- Discover which module imported names are from, and + -- attach the meta-data which will be needed by follow-on + -- compilation, such as the arity of each super. + result <- B.resolveNamesInModule + CE.primKindEnv CE.primTypeEnv + store mm_core + + case result of + Left err -> return [ErrorLoad err] + Right mm_resolved -> goSpread mm_resolved + + goSpread mm + = do -- Spread types of data constructors into uses. - let mm_spread = C.spreadX - CE.primKindEnv CE.primTypeEnv mm_core + let mm_spread = C.spreadX CE.primKindEnv CE.primTypeEnv mm - -- Dump code before checking for debugging purposes. + -- Dump loaded code before type checking. pipeSink (renderIndent $ ppr mm_spread) sinkPreCheck - -- Use the existing checker pipeline to Synthesise - -- missing type annotations. + -- Type check the code, synthesising missing type annotations. + -- Insert casts to implicitly run suspended bindings along the way. + let fragment_implicit + = flip C.mapProfileOfFragment CE.fragment + $ C.mapFeaturesOfProfile + $ ( C.setFeature C.ImplicitRun True + . C.setFeature C.ImplicitBox True) + pipeCore mm_spread - $ PipeCoreCheck CE.fragment C.Synth sinkCheckerTrace pipes + $ PipeCoreCheck fragment_implicit C.Synth sinkCheckerTrace pipes in goParse @@ -138,8 +172,5 @@ = case mct of Nothing -> return [] Just (C.CheckTrace doc) -> pipeSink (renderIndent doc) sink - - - diff --git a/DDC/Build/Spec.hs b/DDC/Build/Spec.hs new file mode 100644 --- /dev/null +++ b/DDC/Build/Spec.hs @@ -0,0 +1,9 @@ + +module DDC.Build.Spec + ( Spec (..) + , Component (..) + , specFieldsLibrary) +where +import DDC.Build.Spec.Base + + diff --git a/DDC/Build/Spec/Base.hs b/DDC/Build/Spec/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Build/Spec/Base.hs @@ -0,0 +1,73 @@ + +module DDC.Build.Spec.Base + ( Spec (..) + , Component (..) + , specFieldsLibrary) +where +import DDC.Core.Module (ModuleName) + +-- | A build specification. +-- This specifies how to build a particular library or exectutable, +-- and is equivalent to a Haskell Cabal file. +data Spec + = Spec + { -- | Version number set by the first line of the file. + specVersion :: String + + -- | Components in this build specification. + , specComponents :: [Component] } + deriving Show + + +-- | A build component. +data Component + = SpecLibrary + { -- | Name of the library. + specLibraryName :: String + + -- | Library version. + , specLibraryVersion :: String + + -- | Tetra modules to build, in dependency order. + , specLibraryTetraModules :: [ModuleName] + + -- | Optional library meta-data. + -- These fields are for informational purposes and are not + -- nessesary to build the library itself. + , specLibraryMeta :: [(String, String)] } + + + | SpecExecutable + { -- | Name of executable + specExecutableName :: String + + -- | Name of main module. + , specExecutableTetraMain :: ModuleName + + -- | Tetra modules to build, in dependency order. + , specExecutableTetraOther :: [ModuleName] + + -- | Optional library meta-data. + -- These fields are for informational purposes and are not + -- nessesary to build the executable itself. + , specExecutableMeta :: [(String, String)] } + deriving Show + + +------------------------------------------------------------------------------- + +-- | Names of all allowable fields in library metadata, and whether each +-- field is nessesary or optional. +specFieldsLibrary :: [(String, Bool)] +specFieldsLibrary + = [ (str, True) | str <- + [ "name" + , "version" + , "tetra-modules" ]] + + ++ [ (str, False) | str <- + [ "author" + , "maintainer" + , "homepage" + , "license" + , "synopsis" ]] diff --git a/DDC/Build/Spec/Check.hs b/DDC/Build/Spec/Check.hs new file mode 100644 --- /dev/null +++ b/DDC/Build/Spec/Check.hs @@ -0,0 +1,11 @@ + +module DDC.Build.Spec.Check + (Error(..)) +where + +-- | Errors that can appear in a Build Spec file. +data Error + = ErrorUnrecognisedField + { errorField :: String + , errorValue :: String } + deriving Show diff --git a/DDC/Build/Spec/Parser.hs b/DDC/Build/Spec/Parser.hs new file mode 100644 --- /dev/null +++ b/DDC/Build/Spec/Parser.hs @@ -0,0 +1,234 @@ + +-- | Parser for DDC build spec files. +module DDC.Build.Spec.Parser + ( parseBuildSpec + , Error(..) ) +where +import DDC.Build.Spec.Base +import DDC.Base.Pretty +import Control.Monad +import Data.List +import Data.Char +import Data.Maybe +import qualified DDC.Core.Module as C + + +--------------------------------------------------------------------------------------------------- +-- | Problems that can arise when parsing a build spec file. +data Error + -- | Empty Spec file. + = ErrorEmpty + { errorFilePath :: FilePath } + + -- | Parse error in Spec file. + | ErrorParse + { errorFilePath :: FilePath + , errorLine :: Int } + + -- | Required field is missing. + | ErrorMissingField + { errorFilePath :: FilePath + , errorMissing :: String } + deriving Show + + +instance Pretty Error where + ppr err + = case err of + ErrorEmpty filePath + -> vcat [ text filePath + , text "Empty file" ] + + ErrorParse filePath n + -> vcat [ text filePath <> text ":" <> int n + , text "Parse error" ] + + ErrorMissingField filePath field + -> vcat [ text filePath + , text "Missing field '" <> text field <> text "'" ] + + +--------------------------------------------------------------------------------------------------- +type LineNumber = Int +type StartCol = Int + +type Parser a = [(LineNumber, StartCol, String)] + -> Either Error a + + +-- | Parse a build specification. +parseBuildSpec :: FilePath -> String -> Either Error Spec +parseBuildSpec path str + = let -- Attach line numbers and starting column to each line. + ls = lines str + lsNum = zip [1..] ls + lsNumCols = attachCols lsNum + in pBuildSpec path lsNumCols + + +-- | Parse a build specification. +pBuildSpec :: FilePath -> Parser Spec +pBuildSpec path [] + = Left $ ErrorEmpty path + +pBuildSpec path ((n, _s, str) : rest) + -- Skip over blank lines + | all (\c -> isSpace c || c == '\n') str + = pBuildSpec path rest + + -- The build spec needs to start with the magic words and version number. + | ["ddc", "build", version] <- words str + = do cs <- pComponents path rest + return $ Spec + { specVersion = version + , specComponents = cs } + + | otherwise + = Left $ ErrorParse path n + + +-- | Parse a build component specification. +pComponents :: FilePath -> Parser [Component] +pComponents _path [] + = return [] + +pComponents path ((n, start, str) : rest) + -- skip over blank lines + | all (\c -> isSpace c || c == '\n') str + = pComponents path rest + + -- parse a library specification + | str == "library" + , (lsLibrary, lsMore) + <- span (\(_, start', _) -> start' == 0 || start' > start) rest + = do fs <- pLibraryFields path lsLibrary + more <- pComponents path lsMore + return $ fs : more + + -- parse an executable specification + | str == "executable" + , (lsExecutable, lsMore) + <- span (\(_, start', _) -> start' == 0 || start' > start) rest + = do fs <- pExecutableFields path lsExecutable + more <- pComponents path lsMore + return $ fs : more + + | otherwise + = Left $ ErrorParse path n + + +--------------------------------------------------------------------------------------------------- +-- | Parse the fields of a library specification. +pLibraryFields :: FilePath -> Parser Component +pLibraryFields path str + = do fs <- pFields path str + (sName, fs_name) <- takeField path "name" fs + (sVersion, fs_version) <- takeField path "version" fs_name + (sTetraModules, fs_modules) <- takeField path "tetra-modules" fs_version + + let Just msTetra + = sequence + $ map C.readModuleName + $ words $ sTetraModules + + return $ SpecLibrary + { specLibraryName = sName + , specLibraryVersion = sVersion + , specLibraryTetraModules = msTetra + , specLibraryMeta = fs_modules } + + +--------------------------------------------------------------------------------------------------- +-- | Parse the fields of an executable specification. +pExecutableFields :: FilePath -> Parser Component +pExecutableFields path str + = do fs <- pFields path str + (sName, fs_name) <- takeField path "name" fs + (sTetraMain, fs_main) <- takeField path "tetra-main" fs_name + let (sTetraOther, fs_other) = takeFieldMaybe path "tetra-other" fs_main + + let Just mTetraMain + = C.readModuleName sTetraMain + + let Just msTetra + = sequence $ map C.readModuleName + $ concat $ maybeToList $ liftM words sTetraOther + + return $ SpecExecutable + { specExecutableName = sName + , specExecutableTetraMain = mTetraMain + , specExecutableTetraOther = msTetra + , specExecutableMeta = fs_other } + + +--------------------------------------------------------------------------------------------------- +-- | Parse fields of a build specification. +pFields :: FilePath -> Parser [(String, String)] +pFields _path [] + = return [] + +pFields path ((n, start, str) : rest) + -- skip over blank lines + | all (\c -> isSpace c || c == '\n') str + = pFields path rest + + -- parse a single field. + | (lsField, lsMore) + <- span (\(_, start', _) -> start' == 0 || start' > start) rest + + , (fieldName, ':' : fieldValue) + <- span (\c -> c /= ':') + $ str ++ concat [ s | (_, _, s) <- lsField] + + = do let f = (chomp fieldName, chomp fieldValue) + more <- pFields path lsMore + return $ f : more + + | otherwise + = Left $ ErrorParse path n + + +-- | Take a named field from this list of fields. +takeField :: FilePath + -> String -> [(String, String)] + -> Either Error (String, [(String, String)]) + +takeField path name fs + = case lookup name fs of + Nothing -> Left $ ErrorMissingField path name + Just s -> return (s, delete (name, s) fs) + + +-- | Take a named field from this list of fields. +takeFieldMaybe + :: FilePath + -> String -> [(String, String)] + -> (Maybe String, [(String, String)]) + +takeFieldMaybe _path name fs + = case lookup name fs of + Nothing -> (Nothing, fs) + Just s -> (Just s, delete (name, s) fs) + + +--------------------------------------------------------------------------------------------------- +-- | Attach starting column number to these lines. +attachCols + :: [(LineNumber, String)] + -> [(LineNumber, StartCol, String)] + +attachCols lstrs + = [ (ln, startCol 1 str, str) | (ln, str) <- lstrs ] + where startCol n ss + = case ss of + [] -> 0 + ' ' : ss' -> startCol (n + 1) ss' + '\t' : ss' -> startCol (n + 8) ss' + _ : _ -> n + + +-- | Remove whitespace from the beginning and end of a string. +chomp :: String -> String +chomp str + = reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace str + diff --git a/DDC/Build/Transform/Resolve.hs b/DDC/Build/Transform/Resolve.hs new file mode 100644 --- /dev/null +++ b/DDC/Build/Transform/Resolve.hs @@ -0,0 +1,186 @@ + +-- | Gather up the set of free names and try to find matching export statements +-- in the imported modules. Add explicit imports that refer to the module where +-- each name is bound. +module DDC.Build.Transform.Resolve + ( resolveNamesInModule ) +where +import DDC.Core.Module +import DDC.Core.Exp +import DDC.Core.Collect.Support +import DDC.Type.DataDef +import DDC.Type.Env (KindEnv, TypeEnv) +import DDC.Base.Pretty +import DDC.Base.Panic +import Data.Map (Map) +import DDC.Build.Interface.Store (Store) +import DDC.Build.Interface.Base (Interface (..)) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified DDC.Build.Interface.Store as Store +import qualified DDC.Core.Tetra as E +import Data.List +import Data.Function + + +-- | For all the names that are free in this module, if there is a +-- corresponding export in one of the modules in the given map, +-- then add the appropriate import definition. +resolveNamesInModule + :: KindEnv E.Name -- ^ Kinds of primitive types. + -> TypeEnv E.Name -- ^ Types of primitive values. + -> Store -- ^ Interface store. + -> Module a E.Name -- ^ Module to resolve names in. + -> IO (Either [Error] (Module a E.Name)) + +resolveNamesInModule kenv tenv store mm + = do + let sp = support kenv tenv mm + ints <- Store.getInterfaces store + let deps = Map.fromList + [ ( interfaceModuleName i + , let Just m = interfaceTetraModule i in m) + | i <- ints ] + modNames <- Store.getModuleNames store + + let getDaVarImport (UName n) = do + eImport <- findImportSourceForDaVar store modNames n + case eImport of + Left err -> return $ Left err + Right isrc -> return $ Right (n, isrc) + + getDaVarImport u = panic "ddc-build" "resolveNamesInModule" + $ text "Cannot resolve anonymous binder:" + <+> ppr u + + eimportsDaVar <- mapM getDaVarImport $ Set.toList $ supportDaVar sp + + case sequence eimportsDaVar of + Left err -> return $ Left [err] + + Right importsDaVar + -> return $ Right $ mm + { moduleImportTypes + = moduleImportTypes mm + ++ importsForTyCons deps (Set.toList $ supportTyCon sp) + + , moduleImportDataDefs + = nubBy ((==) `on` dataDefTypeName) + $ moduleImportDataDefs mm + ++ importsForDaTyCons deps (Set.toList $ supportTyCon sp) + + , moduleImportCaps + = moduleImportCaps mm + ++ importsCap deps + + , moduleImportValues + = moduleImportValues mm + ++ importsDaVar } + + +--------------------------------------------------------------------------------------------------- +-- | Import tycons defined in other modules. +importsForTyCons + :: Ord n + => Map ModuleName (Module b n) -- ^ Modules which this one depends on. + -> [Bound n] -- ^ Unbound type constructors to find imports for. + -> [(n, ImportType n)] + +importsForTyCons deps _tyCons + = concat + [ [(n, ImportTypeAbstract k) + | (n, k) <- Map.toList $ Map.unions + $ map importedTyConsAbs $ Map.elems deps] + + , [(n, ImportTypeAbstract k) + | (n, (_, k)) <- Map.toList $ Map.unions + $ map exportedTyConsLocal $ Map.elems deps] + + , [(n, ImportTypeBoxed k) + | (n, k) <- Map.toList $ Map.unions + $ map importedTyConsBoxed $ Map.elems deps] ] + + +--------------------------------------------------------------------------------------------------- +-- | Import caps defined in other modules. +importsCap + :: Ord n + => Map ModuleName (Module b n) + -> [(n, ImportCap n)] + +importsCap deps + = concatMap moduleImportCaps $ Map.elems deps + + +--------------------------------------------------------------------------------------------------- +-- | Import data defs defined in other modules. +importsForDaTyCons + :: Ord n + => Map ModuleName (Module b n) + -> [Bound n] + -> [DataDef n] + +importsForDaTyCons deps _tycons + = concat + $ [ moduleImportDataDefs m ++ moduleDataDefsLocal m + | m <- Map.elems deps ] + + +--------------------------------------------------------------------------------------------------- +-- | Build import statements for the given list of unbound value variables. +-- +-- We look in dependency modules for a matching export, +-- and produce the corresponding import statement to use it. +-- +findImportSourceForDaVar + :: Store -- ^ Interface store. + -> [ModuleName] -- ^ Modules to search for matching exports. + -> E.Name -- ^ Name of value. + -> IO (Either Error (ImportValue E.Name)) + +findImportSourceForDaVar store modNames nSuper + = do result <- Store.findSuper store nSuper modNames + case result of + [] -> return $ Left $ ErrorNotFound nSuper + [super] -> return $ Right $ Store.superImportValue super + supers -> return $ Left $ ErrorMultiple nSuper (map Store.superModuleName supers) + + +--------------------------------------------------------------------------------------------------- +-- | Get the tycons that are locally defined, then exported by a module. +exportedTyConsLocal :: Ord n => Module b n -> Map n (ModuleName, Kind n) +exportedTyConsLocal mm + = Map.fromList + $ [ (n, (moduleName mm, t)) + | (n, ExportSourceLocal _ t) <- moduleExportTypes mm ] + +-- | Get the type constructors that are imported abstractly by a module. +importedTyConsAbs :: Ord n => Module b n -> Map n (Kind n) +importedTyConsAbs mm + = Map.fromList + $ [ (n, k) | (n, ImportTypeAbstract k) <- moduleImportTypes mm ] + + +-- | Get the type constructors that are imported as boxed foreign types. +importedTyConsBoxed :: Ord n => Module b n -> Map n (Kind n) +importedTyConsBoxed mm + = Map.fromList + $ [ (n, k) | (n, ImportTypeBoxed k) <- moduleImportTypes mm ] + + +--------------------------------------------------------------------------------------------------- +-- | Problems that can be uncovered when resolving names. +data Error + = ErrorNotFound E.Name + | ErrorMultiple E.Name [ModuleName] + +instance Pretty Error where + ppr err + = case err of + ErrorNotFound n + -> vcat [ text "Not in scope: " <> squotes (ppr n) ] + + ErrorMultiple n ms + -> vcat $ [ text "Variable" <+> squotes (ppr n) <+> text "defined in multiple modules:" ] + ++ (map ppr ms) + diff --git a/ddc-build.cabal b/ddc-build.cabal --- a/ddc-build.cabal +++ b/ddc-build.cabal @@ -1,5 +1,5 @@ Name: ddc-build -Version: 0.4.1.3 +Version: 0.4.2.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -14,27 +14,30 @@ Library Build-depends: - base >= 4.6 && < 4.8, + base >= 4.6 && < 4.9, process >= 1.1 && < 1.3, - deepseq == 1.3.*, + deepseq >= 1.3 && < 1.5, containers == 0.5.*, - filepath == 1.3.*, + filepath >= 1.3 && < 1.5, directory == 1.2.*, - mtl == 2.2.*, - ddc-base == 0.4.1.*, - ddc-core == 0.4.1.*, - ddc-core-eval == 0.4.1.*, - ddc-core-simpl == 0.4.1.*, - ddc-core-salt == 0.4.1.*, - ddc-core-llvm == 0.4.1.*, - ddc-core-flow == 0.4.1.*, - ddc-core-tetra == 0.4.1.*, - ddc-source-tetra == 0.4.1.* + mtl == 2.2.1.*, + time >= 1.4 && < 1.6, + ddc-base == 0.4.2.*, + ddc-core == 0.4.2.*, + ddc-core-simpl == 0.4.2.*, + ddc-core-salt == 0.4.2.*, + ddc-core-llvm == 0.4.2.*, + ddc-core-flow == 0.4.2.*, + ddc-core-tetra == 0.4.2.*, + ddc-core-babel == 0.4.2.*, + ddc-source-tetra == 0.4.2.* Exposed-modules: - DDC.Build.Language.Eval + DDC.Build.Interface.Base + DDC.Build.Interface.Load + DDC.Build.Interface.Store + DDC.Build.Language.Flow - DDC.Build.Language.Lite DDC.Build.Language.Salt DDC.Build.Language.Tetra DDC.Build.Language.Zero @@ -46,13 +49,19 @@ DDC.Build.Pipeline.Sink DDC.Build.Pipeline.Text + DDC.Build.Spec.Check + DDC.Build.Spec.Parser + DDC.Build.Builder DDC.Build.Language DDC.Build.Pipeline DDC.Build.Platform + DDC.Build.Spec Other-modules: DDC.Build.Language.Base + DDC.Build.Spec.Base + DDC.Build.Transform.Resolve Extensions: BangPatterns @@ -65,6 +74,7 @@ KindSignatures RankNTypes DeriveDataTypeable + ScopedTypeVariables ghc-options: -Wall