ddc-build (empty) → 0.3.1.1
raw patch · 12 files changed
+1739/−0 lines, 12 filesdep +basedep +containersdep +ddc-basesetup-changed
Dependencies added: base, containers, ddc-base, ddc-core, ddc-core-eval, ddc-core-llvm, ddc-core-salt, ddc-core-simpl, deepseq, directory, filepath, mtl, process
Files
- DDC/Build/Builder.hs +520/−0
- DDC/Build/Language.hs +43/−0
- DDC/Build/Language/Base.hs +57/−0
- DDC/Build/Language/Eval.hs +74/−0
- DDC/Build/Language/Lite.hs +73/−0
- DDC/Build/Language/Salt.hs +72/−0
- DDC/Build/Language/Zero.hs +121/−0
- DDC/Build/Pipeline.hs +531/−0
- DDC/Build/Platform.hs +156/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- ddc-build.cabal +60/−0
+ DDC/Build/Builder.hs view
@@ -0,0 +1,520 @@++module DDC.Build.Builder+ ( BuilderConfig (..)+ , Builder (..)+ , builders++ , determineDefaultBuilder)+where+import DDC.Build.Platform+import DDC.Base.Pretty hiding ((</>))+import System.FilePath +import System.Exit+import System.Cmd+import qualified DDC.Core.Salt.Platform as Llvm++-- | Configuration information for a builder that is not platform specific.+data BuilderConfig+ = BuilderConfig+ { -- | Directory that holds the source for the runtime system+ -- and base library.+ builderConfigBaseSrcDir :: FilePath ++ -- | Directory that holds the shared objects for the runtime+ -- system and base library.+ , builderConfigBaseLibDir :: FilePath }+++-- | Actions to use to invoke external compilation tools.+data Builder+ = Builder+ { -- | The name of this platform.+ builderName :: String++ -- | The platform the build is being performed on.+ , buildHost :: Platform++ -- | The platform we're compiling code for.+ , buildTarget :: Platform++ -- | The LLVM target specification.+ -- Gives the widths of pointers and primitive numeric types.+ , buildSpec :: Llvm.Platform++ -- | Directory that holds the source for the runtime system+ -- and base library.+ , buildBaseSrcDir :: FilePath++ -- | Directory that holds the shared objects for the runtime+ -- system and base library.+ , buildBaseLibDir :: FilePath ++ -- | Invoke the C compiler+ -- to compile a .c file into a .o file.+ , buildCC :: FilePath -> FilePath -> IO ()++ -- | Invoke the LLVM compiler+ -- to compile a .ll file into a .s file.+ , buildLlc :: FilePath -> FilePath -> IO ()++ -- | Invoke the system assembler+ -- to assemble a .s file into a .o file.+ , buildAs :: FilePath -> FilePath -> IO ()++ -- | Link an executable.+ , buildLdExe :: FilePath -> FilePath -> IO () ++ -- | Link a static library.+ , buildLdLibStatic :: [FilePath] -> FilePath -> IO ()++ -- | Link a shared library.+ , buildLdLibShared :: [FilePath] -> FilePath -> IO () }+++-- | The result of a build command.+--+-- We use these so that the called doesn't need to worry about+-- interpreting numeric exit codes. +data BuilderResult+ -- | Build command completed successfully.+ = BuilderSuccess++ -- | Build command was cancelled or killed by the user.+ -- eg by Control-C on the console.+ | BuilderCanceled ++ -- | Build command failed. + -- There is probably something wrong with the generated file.+ -- Unrecognised exit codes also result in this BuilderResult.+ | BuilderFailed+ deriving (Show, Eq)+++instance Show Builder where+ show builder+ = "Builder " ++ show (builderName builder)+++instance Pretty Builder where+ ppr builder+ = vcat+ [ text "Builder Name : " <> text (builderName builder) + , empty+ , text "Host Platform"+ , indent 1 $ ppr $ buildHost builder + , empty+ , text "Target Platform"+ , indent 1 $ ppr $ buildTarget builder+ , empty+ , text "LLVM Target Spec"+ , indent 1 $ ppr $ buildSpec builder ]+++-- builders -------------------------------------------------------------------+-- | All supported builders.+-- The host and target platforms are the same.+-- +-- Supported builders are: +-- @x86_32-darwin@, @x86_64-darwin@,+-- @x86_32-linux@, @x86_64-linux@,+-- @x86_32-cygwin@,+-- @ppc32-linux@+--+builders :: BuilderConfig -> [Builder]+builders config+ = [ builder_X8632_Darwin config+ , builder_X8664_Darwin config+ , builder_X8632_Linux config + , builder_X8664_Linux config+ , builder_PPC32_Linux config ]+++-- defaultBuilder -------------------------------------------------------------+-- | Determine the default builder based on the 'arch' and 'uname' commands.+-- This assumes that the 'host' and 'target' platforms are the same.+--+-- If we don't recognise the result of 'arch' or 'uname', or don't have +-- a default builder config for this platform then `Nothing`.+determineDefaultBuilder :: BuilderConfig -> IO (Maybe Builder)+determineDefaultBuilder config+ = do mPlatform <- determineHostPlatform++ case mPlatform of+ Just (Platform ArchX86_32 OsDarwin) + -> return $ Just (builder_X8632_Darwin config)++ Just (Platform ArchX86_64 OsDarwin) + -> return $ Just (builder_X8664_Darwin config)++ Just (Platform ArchX86_32 OsLinux)+ -> return $ Just (builder_X8632_Linux config)++ Just (Platform ArchX86_64 OsLinux)+ -> return $ Just (builder_X8664_Linux config)++ Just (Platform ArchPPC_32 OsLinux)+ -> return $ Just (builder_PPC32_Linux config)++ Just (Platform ArchX86_32 OsCygwin)+ -> return $ Just (builder_X8632_Cygwin config)++ _ -> return Nothing+++-- x86_32-darwin ----------------------------------------------------------------+builder_X8632_Darwin config+ = Builder + { builderName = "x86_32-darwin" + , buildHost = Platform ArchX86_32 OsDarwin+ , buildTarget = Platform ArchX86_32 OsDarwin+ , buildSpec = Llvm.platform32+ , 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 + , "-o", sFile ]++ , buildCC+ = \cFile oFile+ -> doCmd "C compiler" [(2, BuilderCanceled)]+ [ "gcc -Werror -std=c99 -O3 -m32"+ , "-c", cFile+ , "-o", oFile+ , "-I" ++ builderConfigBaseSrcDir config </> "sea/runtime"+ , "-I" ++ builderConfigBaseSrcDir config </> "sea/primitive" ]++ , buildAs+ = \sFile oFile+ -> doCmd "assembler" [(2, BuilderCanceled)]+ [ "as -arch i386" + , "-o", oFile+ , sFile ]++ , buildLdExe+ = \oFile binFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ [ "gcc -m32" + , "-o", binFile+ , oFile+ , builderConfigBaseLibDir config </> "libddc-runtime.dylib" ]++ , buildLdLibStatic+ = \oFiles libFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ $ ["ar r", libFile] ++ oFiles ++ , buildLdLibShared+ = \oFiles libFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ $ [ "gcc -m32 -dynamiclib -undefined dynamic_lookup"+ , "-o", libFile ] ++ oFiles+ }++-- x86_64-darwin --------------------------------------------------------------+builder_X8664_Darwin config+ = Builder+ { builderName = "x86_64-darwin"+ , buildHost = Platform ArchX86_64 OsDarwin+ , buildTarget = Platform ArchX86_64 OsDarwin+ , buildSpec = Llvm.platform64+ , 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 + , "-o", sFile ]++ , buildCC+ = \cFile oFile+ -> doCmd "C compiler" [(2, BuilderCanceled)]+ [ "gcc -Werror -std=c99 -O3 -m64"+ , "-c", cFile+ , "-o", oFile+ , "-I" ++ builderConfigBaseSrcDir config </> "sea/runtime"+ , "-I" ++ builderConfigBaseSrcDir config </> "sea/primitive" ]++ , buildAs+ = \sFile oFile+ -> doCmd "assembler" [(2, BuilderCanceled)]+ [ "as -arch x86_64" + , "-o", oFile+ , sFile ]++ , buildLdExe + = \oFile binFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ [ "gcc -m64" + , "-o", binFile+ , oFile+ , builderConfigBaseLibDir config </> "libddc-runtime.dylib" ]++ , buildLdLibStatic+ = \oFiles libFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ $ ["ar r", libFile] ++ oFiles ++ , buildLdLibShared+ = \oFiles libFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ $ [ "gcc -m64 -dynamiclib -undefined dynamic_lookup"+ , "-o", libFile ] ++ oFiles+ }+++-- x86_32-linux ---------------------------------------------------------------+builder_X8632_Linux config+ = Builder+ { builderName = "x86_32-linux"+ , buildHost = Platform ArchX86_32 OsLinux+ , buildTarget = Platform ArchX86_32 OsLinux+ , buildSpec = Llvm.platform32+ , buildBaseSrcDir = builderConfigBaseSrcDir config+ , buildBaseLibDir = builderConfigBaseLibDir config++ , buildLlc + = \llFile sFile+ -> doCmd "LLVM compiler" [(2, BuilderCanceled)]+ [ "llc -O3 -march=x86 -relocation-model=pic" + , llFile + , "-o", sFile ]++ , buildCC+ = \cFile oFile+ -> doCmd "C compiler" [(2, BuilderCanceled)]+ [ "gcc -Werror -std=c99 -O3 -m32"+ , "-c", cFile+ , "-o", oFile+ , "-I" ++ builderConfigBaseSrcDir config </> "sea/runtime"+ , "-I" ++ builderConfigBaseSrcDir config </> "sea/primitive" ]+++ , buildAs+ = \sFile oFile+ -> doCmd "assembler" [(2, BuilderCanceled)]+ [ "as --32" + , "-o", oFile+ , sFile ]++ , buildLdExe + = \oFile binFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ [ "gcc -m32" + , "-o", binFile+ , oFile+ , builderConfigBaseLibDir config </> "libddc-runtime.so" ]++ , buildLdLibStatic+ = \oFiles libFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ $ ["ar r", libFile] ++ oFiles ++ , buildLdLibShared+ = \oFiles libFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ $ [ "gcc -shared", "-o", libFile ] ++ oFiles+ }+++-- x86_64-linux ---------------------------------------------------------------+builder_X8664_Linux config+ = Builder+ { builderName = "x86_64-linux"+ , buildHost = Platform ArchX86_64 OsLinux+ , buildTarget = Platform ArchX86_64 OsLinux+ , buildSpec = Llvm.platform64+ , buildBaseSrcDir = builderConfigBaseSrcDir config+ , buildBaseLibDir = builderConfigBaseLibDir config++ , buildLlc + = \llFile sFile+ -> doCmd "LLVM compiler" [(2, BuilderCanceled)]+ [ "llc -O3 -march=x86-64 -relocation-model=pic" + , llFile + , "-o", sFile ]++ , buildCC+ = \cFile oFile+ -> doCmd "C compiler" [(2, BuilderCanceled)]+ [ "gcc -Werror -std=c99 -O3 -m64"+ , "-c", cFile+ , "-o", oFile+ , "-I" ++ builderConfigBaseSrcDir config </> "sea/runtime"+ , "-I" ++ builderConfigBaseSrcDir config </> "sea/primitive" ]+++ , buildAs+ = \sFile oFile+ -> doCmd "assembler" [(2, BuilderCanceled)]+ [ "as --64" + , "-o", oFile+ , sFile ] ++ , buildLdExe + = \oFile binFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ [ "gcc -m64"+ , "-o", binFile+ , oFile+ , builderConfigBaseLibDir config </> "libddc-runtime.so" ]++ , buildLdLibStatic+ = \oFiles libFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ $ ["ar r", libFile] ++ oFiles ++ , buildLdLibShared+ = \oFiles libFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ $ [ "gcc -shared", "-o", libFile ] ++ oFiles+ }+++-- ppc32-linux ---------------------------------------------------------------+builder_PPC32_Linux config+ = Builder+ { builderName = "ppc32-linux"+ , buildHost = Platform ArchPPC_32 OsLinux+ , buildTarget = Platform ArchPPC_32 OsLinux+ , buildSpec = Llvm.platform32+ , buildBaseSrcDir = builderConfigBaseSrcDir config+ , buildBaseLibDir = builderConfigBaseLibDir config++ , buildLlc + = \llFile sFile+ -> doCmd "LLVM compiler" [(2, BuilderCanceled)]+ [ "llc -O3 -march=ppc32 -relocation-model=pic" + , llFile + , "-o", sFile ]++ , buildCC+ = \cFile oFile+ -> doCmd "C compiler" [(2, BuilderCanceled)]+ [ "gcc -Werror -std=c99 -O3 -m32"+ , "-c", cFile+ , "-o", oFile+ , "-I" ++ builderConfigBaseSrcDir config </> "sea/runtime"+ , "-I" ++ builderConfigBaseSrcDir config </> "sea/primitive" ]++ , buildAs+ = \sFile oFile+ -> doCmd "assembler" [(2, BuilderCanceled)]+ [ "as"+ , "-o", oFile+ , sFile ]++ , buildLdExe + = \oFile binFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ [ "gcc -m32" + , "-o", binFile+ , oFile+ , builderConfigBaseLibDir config </> "libddc-runtime.so" ]++ , buildLdLibStatic+ = \oFiles libFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ $ ["ar r", libFile] ++ oFiles ++ , buildLdLibShared+ = \oFiles libFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ $ [ "gcc -shared", "-o", libFile ] ++ oFiles+ }+++-- x86_32-cygwin ---------------------------------------------------------------+builder_X8632_Cygwin config+ = Builder+ { builderName = "x86_32-cygwin"+ , buildHost = Platform ArchX86_32 OsCygwin+ , buildTarget = Platform ArchX86_32 OsCygwin+ , buildSpec = Llvm.platform32+ , buildBaseSrcDir = builderConfigBaseSrcDir config+ , buildBaseLibDir = builderConfigBaseLibDir config++ , buildLlc + = \llFile sFile+ -> doCmd "LLVM compiler" [(2, BuilderCanceled)]+ [ "llc -O3 -march=x86 " + , normalise llFile+ , "-o", normalise sFile ]++ , buildCC+ = \cFile oFile+ -> doCmd "C compiler" [(2, BuilderCanceled)]+ [ "gcc-4 -Werror -std=c99 -O3 -m32"+ , "-c", cFile+ , "-o", oFile+ , "-I" ++ builderConfigBaseSrcDir config </> "sea/runtime"+ , "-I" ++ builderConfigBaseSrcDir config </> "sea/primitive" ]++ , buildAs+ = \sFile oFile+ -> doCmd "assembler" [(2, BuilderCanceled)]+ [ "as --32"+ , "-o", normalise oFile+ , normalise sFile ]++ -- 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+ -> doCmd "linker" [(2, BuilderCanceled)]+ [ "gcc-4 -m32" + , "-o", normalise binFile+ , normalise oFile+ , normalise $ builderConfigBaseLibDir config </> "libddc-runtime.a" ]++ , buildLdLibStatic+ = \oFiles libFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ $ ["ar r", libFile] ++ oFiles ++ , buildLdLibShared+ = \oFiles libFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ $ [ "gcc -shared", "-o", libFile ] ++ oFiles+ }+++-- Utils ----------------------------------------------------------------------+-- | Run a system command, and if it fails quit the program.+doCmd :: String -- ^ Description of tool being invoked.+ -> [(Int, BuilderResult)] -- ^ How to interpret exit codes.+ -> [String] -- ^ System command to run.+ -> IO ()++doCmd thing exitCodeMeanings cmdParts+ = do + code <- system cmd+ case code of+ ExitSuccess + -> return ()++ ExitFailure c+ | Just meaning <- lookup c exitCodeMeanings+ -> case meaning of+ BuilderSuccess -> return ()+ BuilderCanceled -> exitWith $ ExitFailure 2+ BuilderFailed -> die c++ | otherwise -> die c++ where cmd = unwords cmdParts+ die c = error+ $ unlines+ [ "System command failed when invoking external " ++ thing ++ "."+ , " Command was: " ++ cmd+ , " Exit code: " ++ show c ]+
+ DDC/Build/Language.hs view
@@ -0,0 +1,43 @@++module DDC.Build.Language+ ( Language (..)+ , Bundle (..)+ , Fragment (..)+ , languages+ , languageOfExtension)+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.Zero as Zero+++-- | Supported language profiles.+-- +-- One of @Lite@, @Salt@, @Eval@, @Zero@.+languages :: [(String, Language)]+languages+ = [ ( "Lite", Lite.language)+ , ( "Salt", Salt.language)+ , ( "Eval", Eval.language)+ , ( "Zero", Zero.language) ]+++-- | Return the language fragment definition corresponding to the given +-- file extension. eg @dcl@ gives the definition of the Lite language.+languageOfExtension :: String -> Maybe Language+languageOfExtension ext+ = let -- Strip of dots at the front.+ -- the 'takeExtension' function from System.FilePath+ -- doens't do this itself.+ ext' = case ext of + '.' : rest -> rest+ _ -> ext+ in case ext' of+ "dcl" -> Just Lite.language+ "dcs" -> Just Salt.language+ "dcv" -> Just Eval.language+ "dcz" -> Just Zero.language+ _ -> Nothing
+ DDC/Build/Language/Base.hs view
@@ -0,0 +1,57 @@++module DDC.Build.Language.Base+ ( Language (..)+ , Bundle (..))+where+import DDC.Core.Module+import DDC.Core.Fragment+import DDC.Core.Check+import DDC.Core.Simplifier+import DDC.Core.Transform.Namify+import DDC.Core.Transform.Rewrite+import DDC.Base.Pretty+import Control.DeepSeq+import Data.Typeable+import Data.Map (Map)+import DDC.Type.Env (Env)+++-- | Existential container for a language fragment, and the dictionaries+-- we need to work with its type parameters.+data Language+ = forall s n err+ . ( Typeable n+ , Ord n+ , Show n+ , Pretty n+ , Pretty (err (AnTEC () n))+ , NFData n)+ => Language (Bundle s n err)+++-- | Existential container for a language fragment, +-- the simplifier for it,+-- and the dictionaries we need to work with its type parameters.+data Bundle s n err+ = Bundle + { -- | Language fragment definition.+ bundleFragment :: Fragment n err++ -- | Modules being used for inliner templates.+ , bundleModules :: Map ModuleName (Module (AnTEC () n) n)++ -- | Initial simplifier state.+ , bundleStateInit :: s++ -- | Current simplifier to apply to module.+ , bundleSimplifier :: Simplifier s (AnTEC () n) n++ -- | Make a namifier for level-1 names.+ , bundleMakeNamifierT :: Env n -> Namifier s n++ -- | Make a namifier for level-0 names.+ , bundleMakeNamifierX :: Env n -> Namifier s n++ -- | Current rewrite rules to apply to module.+ , bundleRewriteRules :: Map String (RewriteRule (AnTEC () n) n) }+
+ DDC/Build/Language/Eval.hs view
@@ -0,0 +1,74 @@++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+
+ DDC/Build/Language/Lite.hs view
@@ -0,0 +1,73 @@++-- | 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
+ DDC/Build/Language/Salt.hs view
@@ -0,0 +1,72 @@++-- | The `Salt` fragment contains just those features that can be easily mapped+-- onto C or LLVM code.+module DDC.Build.Language.Salt+ ( 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.Salt as Salt+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 Salt.+language :: Language+language = Language bundle+++-- | Language bundle for Disciple Core Salt.+bundle :: Bundle Int Name Salt.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 Salt.+fragment :: Fragment Name Salt.Error+fragment + = Fragment+ { fragmentProfile = profile + , fragmentExtension = "dcs"+ , 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
+ DDC/Build/Language/Zero.hs view
@@ -0,0 +1,121 @@++-- | The `Zero` fragment has no features and no primops.+-- It it provides the first order calculus, and is good for debugging.+module DDC.Build.Language.Zero+ ( language+ , bundle+ , fragment+ , Name+ , Error)+where+import DDC.Core.Simplifier+import DDC.Build.Language.Base+import DDC.Core.Fragment hiding (Error)+import DDC.Core.Transform.Namify+import DDC.Base.Pretty+import DDC.Data.Token+import DDC.Type.Exp+import Data.Typeable+import DDC.Type.Env (Env)+import DDC.Core.Lexer as Core+import qualified DDC.Type.Env as Env+import qualified Data.Map as Map+import Control.Monad.State.Strict+import Control.DeepSeq+++-- | Language definitition for Disciple Core Zero.+language :: Language+language = Language bundle+++-- | Language bundle for Disciple Core Zero+bundle :: Bundle Int Name 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 Error+fragment+ = Fragment+ { fragmentProfile = zeroProfile+ , fragmentExtension = "dcz"+ , fragmentReadName = \x -> Just (Name x)+ , fragmentLexModule = lexModuleZero+ , fragmentLexExp = lexExpZero+ , fragmentCheckModule = const Nothing+ , fragmentCheckExp = const Nothing }+++data Error a+ = Error+ deriving Show++instance Pretty (Error a) where+ ppr Error = text (show Error)+++-- Wrap the names we use for the zero fragment, +-- so they get pretty printed properly.+data Name + = Name String+ deriving (Eq, Ord, Show, Typeable)++instance NFData Name where+ rnf (Name str) = rnf str++instance Pretty Name where+ ppr (Name str) = text str+++-- | Lex a string to tokens, using primitive names.+--+-- The first argument gives the starting source line number.+lexModuleZero :: String -> Int -> String -> [Token (Tok Name)]+lexModuleZero srcName srcLine str+ = map rn $ Core.lexModuleWithOffside srcName srcLine str+ where rn (Token t sp) + = case renameTok (Just . Name) t of+ Just t' -> Token t' sp+ Nothing -> Token (KJunk "lexical error") sp+++-- | Lex a string to tokens, using primitive names.+--+-- The first argument gives the starting source line number.+lexExpZero :: String -> Int -> String -> [Token (Tok Name)]+lexExpZero srcName srcLine str+ = map rn $ Core.lexExp srcName srcLine str+ where rn (Token t sp) + = case renameTok (Just . Name) t of+ Just t' -> Token t' sp+ Nothing -> Token (KJunk "lexical error") sp+++-- | 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 = Name $ "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 = Name $ "x" ++ show i+ case Env.lookupName n env of+ Nothing -> return n+ _ -> freshX env bb
+ DDC/Build/Pipeline.hs view
@@ -0,0 +1,531 @@+{-# LANGUAGE GADTs #-}+-- | A pipeline is an abstraction of a single compiler pass.+--+-- NOTE: The Haddock documentation on pipeline constructors is missing+-- because Haddock does not support commenting GADTs.+-- See the source code for documentation.+--+module DDC.Build.Pipeline+ ( -- * Errors+ Error(..)++ -- * Source code+ , PipeText (..)+ , pipeText++ -- * Generic Core modules+ , PipeCore (..)+ , pipeCore++ -- * Core Lite modules+ , PipeLite (..)+ , pipeLite++ -- * Core Salt modules+ , PipeSalt (..)+ , pipeSalt++ -- * LLVM modules+ , PipeLlvm (..)+ , pipeLlvm++ -- * Emitting output+ , Sink (..)+ , pipeSink)+where+import DDC.Build.Language+import DDC.Build.Builder+import DDC.Core.Simplifier+import DDC.Base.Pretty+import DDC.Data.Canned+import DDC.Llvm.Pretty ()+import DDC.Core.Check (AnTEC)+import qualified DDC.Core.Transform.Reannotate as C+import qualified DDC.Core.Fragment as C+import qualified DDC.Core.Check as C+import qualified DDC.Core.Module as C+import qualified DDC.Core.Load as CL+import qualified DDC.Core.Llvm.Convert as Llvm+import qualified DDC.Core.Salt.Transfer as Salt+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.Lite as Lite+import qualified DDC.Llvm.Syntax as Llvm+import qualified Control.Monad.State.Strict as S+import Control.Monad+import Control.DeepSeq+import System.Directory++-- Error ----------------------------------------------------------------------+data Error+ = ErrorSaltLoad (CL.Error Salt.Name)++ -- | Error converting the module to Disciple Core Salt.+ | forall err. Pretty err => ErrorSaltConvert !err++ -- | Error converting the module to Disciple Core Lite.+ | forall err. Pretty err => ErrorLiteConvert !err++ -- | Error when loading a module.+ -- Blame it on the user.+ | forall err. Pretty err => ErrorLoad !err++ -- | Error when type checking a transformed module.+ -- Blame it on the compiler.+ | forall err. Pretty err => ErrorLint !err+++instance Pretty Error where+ ppr err+ = case err of+ ErrorSaltLoad err'+ -> vcat [ text "Type error when loading Salt module."+ , indent 2 (ppr err') ]++ ErrorSaltConvert err'+ -> vcat [ text "Fragment violation when converting Salt module to C code."+ , indent 2 (ppr err') ]++ ErrorLiteConvert err'+ -> vcat [ text "Fragment violation when converting Lite module to Salt module."+ , indent 2 (ppr err') ]++ ErrorLoad err'+ -> vcat [ text "Error loading module"+ , indent 2 (ppr err') ]++ ErrorLint err'+ -> vcat [ text "Error in transformed module."+ , indent 2 (ppr err') ]++instance NFData Error+++-- PipeSource -----------------------------------------------------------------+-- | Process program text.+data PipeText n (err :: * -> *) where+ PipeTextOutput + :: !Sink+ -> PipeText n err++ PipeTextLoadCore + :: (Ord n, Show n, Pretty n)+ => !(Fragment n err)+ -> ![PipeCore (C.AnTEC () n) n]+ -> PipeText n err+++-- | Process a text module.+--+-- Returns empty list on success.+pipeText+ :: NFData n+ => String+ -> Int+ -> String+ -> PipeText n err+ -> IO [Error]++pipeText !srcName !srcLine !str !pp+ = case pp of+ PipeTextOutput !sink+ -> {-# SCC "PipeTextOutput" #-}+ pipeSink str sink++ PipeTextLoadCore !frag !pipes+ -> {-# SCC "PipeTextLoadCore" #-}+ let toks = fragmentLexModule frag srcName srcLine str+ in case CL.loadModuleFromTokens (fragmentProfile frag) srcName toks of+ Left err -> return $ [ErrorLoad err]+ Right mm -> pipeCores mm pipes+++-- PipeCoreModule -------------------------------------------------------------+-- | Process a core module.+data PipeCore a n where+ -- Plumb the module on without transforming it.+ PipeCoreId+ :: ![PipeCore a n]+ -> PipeCore a n++ -- Output a module to console or file.+ PipeCoreOutput + :: !Sink + -> PipeCore a n++ -- Type check a module.+ PipeCoreCheck + :: !(Fragment n err)+ -> ![PipeCore (C.AnTEC a n) n]+ -> PipeCore a n++ -- Type check a module, discarding previous per-node type annotations.+ PipeCoreReCheck+ :: (Show a, NFData a)+ => !(Fragment n err)+ -> ![PipeCore (C.AnTEC a n) n]+ -> PipeCore (C.AnTEC a n') n++ -- Strip annotations from a module.+ PipeCoreStrip+ :: ![PipeCore () n]+ -> PipeCore a n++ -- Apply a simplifier to a module.+ PipeCoreSimplify + :: !(Fragment n err)+ -> !s+ -> !(Simplifier s a n)+ -> ![PipeCore () n] + -> PipeCore a n++ -- Treat a module as belonging to the Core Lite fragment from now on.+ PipeCoreAsLite+ :: ![PipeLite]+ -> PipeCore (C.AnTEC () Lite.Name) Lite.Name++ -- Treat a module as beloning to the Core Salt fragment from now on.+ PipeCoreAsSalt+ :: Pretty a + => ![PipeSalt a] + -> PipeCore a Salt.Name++ -- Apply a canned function to a module.+ -- This is helpful for debugging, and tweaking the output before pretty printing.+ -- More reusable transforms should be made into their own pipeline stage.+ PipeCoreHacks+ :: Canned (C.Module a n -> IO (C.Module a n))+ -> ![PipeCore a n]+ -> PipeCore a n+++-- | Process a Core module.+--+-- Returns empty list on success.+pipeCore+ :: (NFData a, Show a, NFData n, Eq n, Ord n, Show n, Pretty n)+ => C.Module a n+ -> PipeCore a n+ -> IO [Error]++pipeCore !mm !pp+ = case pp of+ PipeCoreId !pipes+ -> {-# SCC "PipeCoreId" #-}+ pipeCores mm pipes++ PipeCoreOutput !sink+ -> {-# SCC "PipeCoreOutput" #-}+ pipeSink (renderIndent $ ppr mm) sink++ PipeCoreCheck !fragment !pipes+ -> {-# SCC "PipeCoreCheck" #-}+ let profile = fragmentProfile fragment++ goCheck mm1+ = case C.checkModule (C.configOfProfile profile) mm1 of+ Left err -> return [ErrorLint err]+ Right mm2 -> goComplies mm2++ goComplies mm1+ = case C.complies profile mm1 of+ Just err -> return [ErrorLint err]+ Nothing -> pipeCores mm1 pipes++ in goCheck mm++ PipeCoreReCheck !fragment !pipes+ -> {-# SCC "PipeCoreReCheck" #-}+ pipeCore (C.reannotate C.annotTail mm)+ $ PipeCoreCheck fragment pipes++ PipeCoreStrip !pipes+ -> {-# SCC "PipeCoreStrip" #-}+ let mm' = (C.reannotate (const ()) mm)+ in pipeCores mm' pipes++ PipeCoreSimplify !fragment !nameZero !simpl !pipes+ -> {-# SCC "PipeCoreSimplify" #-}+ let profile = fragmentProfile fragment+ primKindEnv = C.profilePrimKinds profile+ primTypeEnv = C.profilePrimTypes profile++ !mm' = (flip S.evalState nameZero+ $ applySimplifier profile primKindEnv primTypeEnv simpl mm)++ !mm2 = C.reannotate (const ()) mm'++ -- NOTE: It is helpful to deepseq here so that we release + -- references to the unsimplified version of the code.+ -- Because we've just applied reannotate, we also+ -- release type annotations on the expression tree.+ in mm2 `deepseq` pipeCores mm2 pipes++ PipeCoreAsLite !pipes+ -> {-# SCC "PipeCoreAsLite" #-}+ liftM concat $ mapM (pipeLite mm) pipes++ PipeCoreAsSalt !pipes+ -> {-# SCC "PipeCoreAsSalt" #-}+ liftM concat $ mapM (pipeSalt mm) pipes++ PipeCoreHacks !(Canned f) !pipes+ -> {-# SCC "PipeCoreHacks" #-} + do mm' <- f mm+ pipeCores mm' pipes+++pipeCores :: (NFData a, Show a, NFData n, Eq n, Ord n, Show n, Pretty n)+ => C.Module a n -> [PipeCore a n] -> IO [Error]++pipeCores !mm !pipes + = go [] pipes+ where go !errs [] + = return errs++ go !errs (pipe : rest)+ = do !err <- pipeCore mm pipe+ go (errs ++ err) rest+++-- PipeLiteModule -------------------------------------------------------------+-- | 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]++pipeLite !mm !pp+ = case pp of+ PipeLiteOutput !sink+ -> {-# SCC "PipeLiteOutput" #-}+ pipeSink (renderIndent $ ppr mm) sink++ 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 ++-- PipeSaltModule --------------------------------------------------------------+-- | Process a Core Salt module.+data PipeSalt a where+ -- Plumb the module on without doing anything to it.+ PipeSaltId+ :: ![PipeSalt a]+ -> PipeSalt a++ -- Output the module in core language syntax.+ PipeSaltOutput + :: !Sink+ -> PipeSalt a++ -- Insert control-transfer primops.+ -- This needs to be done before we convert the module to C or LLVM.+ PipeSaltTransfer+ :: ![PipeSalt (AnTEC a Salt.Name)]+ -> PipeSalt (AnTEC a Salt.Name)++ -- Print the module as a C source code.+ PipeSaltPrint + :: !Bool -- With C prelude.+ -> !Salt.Platform -- Target platform specification+ -> !Sink + -> PipeSalt a++ -- Convert the module to LLVM.+ PipeSaltToLlvm+ :: !Salt.Platform + -> ![PipeLlvm]+ -> PipeSalt a++ -- Compile the module via C source code.+ PipeSaltCompile+ :: !Salt.Platform -- Target platform specification+ -> !Builder -- Builder to use.+ -> !FilePath -- Intermediate C file.+ -> !FilePath -- Object file.+ -> !(Maybe FilePath) -- Link into this exe file+ -> !Bool -- Keep intermediate .c files+ -> PipeSalt a++deriving instance Show a => Show (PipeSalt a)+++-- | Process a Core Salt module.+-- +-- Returns empty list on success.+pipeSalt :: (Show a, Pretty a, NFData a)+ => C.Module a Salt.Name+ -> PipeSalt a+ -> IO [Error]++pipeSalt !mm !pp+ = case pp of+ PipeSaltId !pipes+ -> {-# SCC "PipeSaltId" #-}+ liftM concat $ mapM (pipeSalt mm) pipes++ PipeSaltOutput !sink+ -> {-# SCC "PipeSaltOutput" #-}+ pipeSink (renderIndent $ ppr mm) sink++ PipeSaltTransfer !pipes+ -> {-# SCC "PipeSaltTransfer" #-}+ case Salt.transferModule mm of+ Left err -> return [ErrorSaltConvert err]+ Right mm' -> liftM concat $ mapM (pipeSalt mm') pipes++ PipeSaltPrint !withPrelude !platform !sink+ -> {-# SCC "PipeSaltPrint" #-}+ case Salt.seaOfSaltModule withPrelude platform mm of+ Left err + -> return $ [ErrorSaltConvert err]++ Right doc + -> pipeSink (renderIndent doc) sink++ 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++ PipeSaltCompile + !platform !builder !cPath !oPath !mExePath+ !keepSeaFiles+ -> {-# SCC "PipeSaltCompile" #-}+ case Salt.seaOfSaltModule True platform mm of+ Left errs+ -> error $ show errs++ Right cDoc+ -> do let cSrc = renderIndent cDoc+ writeFile cPath cSrc++ -- Compile C source file into .o file.+ buildCC builder cPath oPath++ -- Link .o file into an executable if we were asked for one. + (case mExePath of+ Nothing -> return ()+ Just exePath+ -> do buildLdExe builder oPath exePath+ return ())++ -- Remove intermediate .c files if we weren't asked for them.+ when (not keepSeaFiles)+ $ removeFile cPath++ return []+++-- PipeLlvmModule -------------------------------------------------------------+-- | Process an LLVM module.+data PipeLlvm+ = PipeLlvmPrint Sink++ | PipeLlvmCompile + { pipeBuilder :: Builder+ , pipeFileLlvm :: FilePath+ , pipeFileAsm :: FilePath+ , pipeFileObject :: FilePath+ , pipeFileExe :: Maybe FilePath + , pipeKeepLlvmFiles :: Bool + , pipeKeepAsmFiles :: Bool }+ deriving (Show)+++-- | Process an LLVM module.+--+-- Returns empty list on success.+pipeLlvm + :: Llvm.Module + -> PipeLlvm + -> IO [Error]++pipeLlvm !mm !pp+ = case pp of+ PipeLlvmPrint !sink+ -> {-# SCC "PipeLlvmPrint" #-} + pipeSink (renderIndent $ ppr mm) sink++ PipeLlvmCompile + !builder !llPath !sPath !oPath !mExePath+ !keepLlvmFiles !keepAsmFiles+ -> {-# SCC "PipeLlvmCompile" #-}+ do -- Write out the LLVM source file.+ let llSrc = renderIndent $ ppr mm+ writeFile llPath llSrc++ -- Compile LLVM source file into .s file.+ buildLlc builder llPath sPath++ -- Assemble .s file into .o file+ buildAs builder sPath oPath++ -- Link .o file into an executable if we were asked for one. + (case mExePath of+ Nothing + -> return ()++ Just exePath+ -> do buildLdExe builder oPath exePath+ return ())++ -- Remove LLVM IR files if we weren't asked for them.+ when (not keepLlvmFiles)+ $ removeFile llPath++ -- Remove Asm IR files if we weren't asked for them.+ when (not keepAsmFiles)+ $ removeFile sPath++ return []+++-- Target ---------------------------------------------------------------------+-- | What to do with program text.+data Sink+ -- | Drop it on the floor.+ = SinkDiscard++ -- | Emit it to stdout.+ | SinkStdout++ -- | Write it to this file.+ | SinkFile FilePath+ deriving (Show)+++-- | Emit a string to the given `Sink`.+pipeSink :: String -> Sink -> IO [Error]+pipeSink !str !tg+ = case tg of+ SinkDiscard+ -> do return []++ SinkStdout+ -> do putStrLn str+ return []++ SinkFile path+ -> do writeFile path str+ return []+
+ DDC/Build/Platform.hs view
@@ -0,0 +1,156 @@++module DDC.Build.Platform+ ( Platform (..)+ , staticFileExtensionOfPlatform+ , sharedFileExtensionOfPlatform++ , Arch (..)+ , archPointerWidth++ , Os (..)++ -- * Host platform+ , determineHostPlatform+ , determineHostArch+ , determineHostOs)+where+import DDC.Base.Pretty+import System.Process+import System.Exit+import Data.List+++-------------------------------------------------------------------------------+-- | Describes a build or target platform.+data Platform+ = Platform+ { platformArch :: Arch+ , platformOs :: Os }+ deriving (Eq, Show)++instance Pretty Platform where+ ppr platform+ = vcat+ [ text "Processor Architecture : " <> ppr (platformArch platform)+ , text "Operating System : " <> ppr (platformOs platform) ]+++-- | Get the file extension to use for a static library on this platform.+staticFileExtensionOfPlatform :: Platform -> String+staticFileExtensionOfPlatform pp+ = case platformOs pp of+ OsDarwin -> "a"+ OsLinux -> "a"+ OsCygwin -> "a"+++-- | Get the file extension to use for a shared library on this platform.+sharedFileExtensionOfPlatform :: Platform -> String+sharedFileExtensionOfPlatform pp+ = case platformOs pp of+ OsDarwin -> "dylib"+ OsLinux -> "so"+ OsCygwin -> "so"+++-------------------------------------------------------------------------------+-- | Processor Architecture.+data Arch+ = ArchX86_32+ | ArchX86_64+ | ArchPPC_32+ | ArchPPC_64+ deriving (Eq, Show)++instance Pretty Arch where+ ppr arch+ = case arch of+ ArchX86_32 -> text "x86 32-bit"+ ArchX86_64 -> text "x86 64-bit"+ ArchPPC_32 -> text "PPC 32-bit"+ ArchPPC_64 -> text "PPC 64-bit"+++-- | Get the width of a pointer on the architecture, in bits.+archPointerWidth :: Arch -> Int+archPointerWidth arch+ = case arch of+ ArchX86_32 -> 32+ ArchX86_64 -> 64+ ArchPPC_32 -> 32+ ArchPPC_64 -> 64+++-------------------------------------------------------------------------------+-- | Operating System.+data Os+ = OsDarwin+ | OsLinux+ | OsCygwin+ deriving (Eq, Show)++instance Pretty Os where+ ppr os+ = case os of+ OsDarwin -> text "Darwin"+ OsLinux -> text "Linux"+ OsCygwin -> text "Cygwin"+++-- Determinators --------------------------------------------------------------+-- | Determine the default host platform.+--+-- Uses the @arch@ and @uname@ commands which must be in the current path.+--+-- Returns `Nothing` if @arch@ or @uname@ cannot be found, returned+-- an error, or we didn't recognise their response.+--+-- For Platforms like Darwin which can run both 32-bit and 64-bit binaries,+-- we return whatever the default is reported by 'arch' and 'uname'.+determineHostPlatform :: IO (Maybe Platform)+determineHostPlatform+ = do mArch <- determineHostArch+ mOs <- determineHostOs++ case (mArch, mOs) of+ (Just arch, Just os) -> return $ Just (Platform arch os)+ _ -> return Nothing+++-- | Determine the host archicture.+-- Uses the 'arch' command which must be in the current path.+determineHostArch :: IO (Maybe Arch)+determineHostArch+ = do (exitCode, strArch, _) + <- readProcessWithExitCode "uname" ["-m"] ""++ let result+ | ExitFailure{} <- exitCode = Nothing+ | isPrefixOf "i386" strArch = Just ArchX86_32+ | isPrefixOf "i486" strArch = Just ArchX86_32+ | isPrefixOf "i586" strArch = Just ArchX86_32+ | isPrefixOf "i686" strArch = Just ArchX86_32+ | isPrefixOf "x86_64" strArch = Just ArchX86_64+ | isPrefixOf "ppc" strArch = Just ArchPPC_32+ | isPrefixOf "ppc64" strArch = Just ArchPPC_64+ | otherwise = Nothing++ return result+++-- | Determine the host OS.+-- Uses the 'uname' command which must be in the current path.+determineHostOs :: IO (Maybe Os)+determineHostOs + = do (exitCode, strOs, _)+ <- readProcessWithExitCode "uname" [] ""+ + let result+ | ExitFailure{} <- exitCode = Nothing+ | isPrefixOf "Darwin" strOs = Just OsDarwin+ | isPrefixOf "Linux" strOs = Just OsLinux+ | isPrefixOf "CYGWIN" strOs = Just OsCygwin+ | otherwise = Nothing++ return result+
+ LICENSE view
@@ -0,0 +1,30 @@+--------------------------------------------------------------------------------+The Disciplined Disciple Compiler License (MIT style)++Copyrite (K) 2007-2012 The Disciplined Disciple Compiler Strike Force+All rights reversed.++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++-------------------------------------------------------------------------------+Under Australian law copyright is free and automatic.+By contributing to DDC authors grant all rights they have regarding their+contributions to the other members of the Disciplined Disciple Compiler Strike+Force, past, present and future, as well as placing their contributions under+the above license.++Use "darcs show authors" to get a list of Strike Force members.++--------------------------------------------------------------------------------+Redistributions of libraries in ./external are governed by their own licenses:++ - TinyPTC GNU Lesser General Public License+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ddc-build.cabal view
@@ -0,0 +1,60 @@+Name: ddc-build+Version: 0.3.1.1+License: MIT+License-file: LICENSE+Author: The Disciplined Disciple Compiler Strike Force+Maintainer: Ben Lippmeier <benl@ouroborus.net>+Build-Type: Simple+Cabal-Version: >=1.6+Stability: experimental+Category: Compilers/Interpreters+Homepage: http://disciple.ouroborus.net+Bug-reports: disciple@ouroborus.net+Synopsis: Disciplined Disciple Compiler build framework.+Description: Disciplined Disciple Compiler build framework.++Library+ Build-depends:+ base == 4.6.*,+ deepseq == 1.3.*,+ containers == 0.5.*,+ filepath == 1.3.*,+ directory == 1.2.*,+ process == 1.1.*,+ mtl == 2.1.*,+ ddc-base == 0.3.1.*,+ ddc-core == 0.3.1.*,+ ddc-core-eval == 0.3.1.*,+ ddc-core-simpl == 0.3.1.*,+ ddc-core-salt == 0.3.1.*,+ ddc-core-llvm == 0.3.1.*+ + Exposed-modules:+ DDC.Build.Language.Eval+ DDC.Build.Language.Lite+ DDC.Build.Language.Salt+ DDC.Build.Language.Zero+ DDC.Build.Language+ DDC.Build.Builder+ DDC.Build.Pipeline+ DDC.Build.Platform++ Other-modules:+ DDC.Build.Language.Base++ Extensions:+ BangPatterns+ PatternGuards+ ParallelListComp+ StandaloneDeriving+ FlexibleContexts+ FlexibleInstances+ ExistentialQuantification+ KindSignatures+ RankNTypes+ DeriveDataTypeable++ ghc-options:+ -Wall+ -fno-warn-missing-signatures+ -fno-warn-unused-do-bind