diff --git a/DDC/Build/Language.hs b/DDC/Build/Language.hs --- a/DDC/Build/Language.hs +++ b/DDC/Build/Language.hs @@ -11,18 +11,22 @@ 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 -- | Supported language profiles. -- --- One of @Lite@, @Salt@, @Eval@, @Zero@. +-- One of @Tetra@, @Lite@, @Salt@, @Eval@, @Flow@, @Zero@. languages :: [(String, Language)] languages - = [ ( "Lite", Lite.language) - , ( "Salt", Salt.language) - , ( "Eval", Eval.language) - , ( "Zero", Zero.language) ] + = [ ( "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 @@ -36,8 +40,11 @@ '.' : rest -> rest _ -> 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 @@ -14,6 +14,7 @@ import Data.Typeable import Data.Map (Map) import DDC.Type.Env (Env) +import qualified DDC.Base.Parser as BP -- | Existential container for a language fragment, and the dictionaries @@ -24,7 +25,7 @@ , Ord n , Show n , Pretty n - , Pretty (err (AnTEC () n)) + , Pretty (err (AnTEC BP.SourcePos n)) , NFData n) => Language (Bundle s n err) diff --git a/DDC/Build/Language/Eval.hs b/DDC/Build/Language/Eval.hs --- a/DDC/Build/Language/Eval.hs +++ b/DDC/Build/Language/Eval.hs @@ -1,4 +1,5 @@ +-- | The `Eval` fragment can be interpreted with our semantic interpreter. module DDC.Build.Language.Eval ( language , bundle @@ -11,11 +12,11 @@ import DDC.Core.Eval.Profile import DDC.Core.Eval.Name import DDC.Core.Fragment -import DDC.Core.Eval.Check as Eval +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 DDC.Type.Env (Env) +import qualified DDC.Type.Env as Env +import qualified Data.Map as Map import Control.Monad.State.Strict diff --git a/DDC/Build/Language/Flow.hs b/DDC/Build/Language/Flow.hs new file mode 100644 --- /dev/null +++ b/DDC/Build/Language/Flow.hs @@ -0,0 +1,58 @@ + +-- | The `Flow` fragment is used for data-flow optimisation as part +-- of the Data Parallel Haskell vectorisation pipeline. +module DDC.Build.Language.Flow + ( language + , bundle + , fragment + + , Error (..)) +where +import DDC.Build.Language.Base +import DDC.Core.Simplifier +import DDC.Core.Transform.Namify +import DDC.Core.Fragment hiding (Error(..)) +import DDC.Core.Flow as Flow +import DDC.Core.Flow.Profile as Flow +import DDC.Base.Pretty +import qualified Data.Map as Map + + +-- | Language definition for Disciple Core Lite. +language :: Language +language = Language bundle + + +-- | Language bundle for Disciple Core Lite. +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 } + + +-- | Fragement definition for Disciple Core Lite. +fragment :: Fragment Name Error +fragment + = Fragment + { fragmentProfile = profile + , fragmentExtension = "dcf" + , fragmentReadName = readName + , fragmentLexModule = lexModuleString + , fragmentLexExp = lexExpString + , fragmentCheckModule = const Nothing + , fragmentCheckExp = const Nothing } + + +data Error a + = Error + deriving Show + +instance Pretty (Error a) where + ppr Error = text (show Error) + diff --git a/DDC/Build/Language/Tetra.hs b/DDC/Build/Language/Tetra.hs new file mode 100644 --- /dev/null +++ b/DDC/Build/Language/Tetra.hs @@ -0,0 +1,59 @@ + +-- | The `Tetra` fragment has four base kinds: +-- `Data`, `Region`, `Effect`, `Witness` and uses the `S` +-- computation type to represent effects. +module DDC.Build.Language.Tetra + ( language + , bundle + , fragment + + , Error (..)) +where +import DDC.Build.Language.Base +import DDC.Core.Simplifier +import DDC.Core.Transform.Namify +import DDC.Core.Fragment hiding (Error(..)) +import DDC.Core.Tetra as Tetra +import DDC.Core.Tetra.Profile as Tetra +import DDC.Base.Pretty +import qualified Data.Map as Map + + +-- | Language definition for Disciple Core Tetra. +language :: Language +language = Language bundle + + +-- | Language bundle for Disciple Core Tetra. +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 } + + +-- | Fragement definition for Disciple Core Tetra. +fragment :: Fragment Name Error +fragment + = Fragment + { fragmentProfile = profile + , fragmentExtension = "dct" + , fragmentReadName = readName + , fragmentLexModule = lexModuleString + , fragmentLexExp = lexExpString + , fragmentCheckModule = const Nothing + , fragmentCheckExp = const Nothing } + + +data Error a + = Error + deriving Show + +instance Pretty (Error a) where + ppr Error = text (show Error) + diff --git a/DDC/Build/Pipeline.hs b/DDC/Build/Pipeline.hs --- a/DDC/Build/Pipeline.hs +++ b/DDC/Build/Pipeline.hs @@ -17,6 +17,10 @@ , PipeCore (..) , pipeCore + -- * Core Flow modules + , PipeFlow (..) + , pipeFlow + -- * Core Lite modules , PipeLite (..) , pipeLite @@ -30,502 +34,13 @@ , pipeLlvm -- * Emitting output - , Sink (..) + , 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 [] +import DDC.Build.Pipeline.Text +import DDC.Build.Pipeline.Core +import DDC.Build.Pipeline.Salt +import DDC.Build.Pipeline.Llvm +import DDC.Build.Pipeline.Sink +import DDC.Build.Pipeline.Error diff --git a/DDC/Build/Pipeline/Core.hs b/DDC/Build/Pipeline/Core.hs new file mode 100644 --- /dev/null +++ b/DDC/Build/Pipeline/Core.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE GADTs #-} +module DDC.Build.Pipeline.Core + ( PipeCore (..) + , pipeCore + , pipeCores + + , PipeLite (..) + , pipeLite + + , PipeFlow (..) + , pipeFlow) +where +import DDC.Build.Pipeline.Error +import DDC.Build.Pipeline.Sink +import DDC.Build.Pipeline.Salt +import DDC.Build.Language +import DDC.Core.Simplifier +import DDC.Base.Pretty +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.Prep as Flow +import qualified DDC.Core.Flow.Transform.Slurp as Flow +import qualified DDC.Core.Flow.Transform.Schedule as Flow +import qualified DDC.Core.Flow.Transform.Extract as Flow +import qualified DDC.Core.Flow.Transform.Wind as Flow + +import qualified DDC.Core.Lite as Lite + +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.Reannotate as C +import qualified DDC.Core.Transform.Forward as Forward +import qualified DDC.Core.Transform.Namify as C +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.Module as C +import qualified DDC.Core.Exp as C + +import qualified DDC.Type.Env as Env + +import qualified Control.Monad.State.Strict as S +import qualified Data.Map as Map +import Control.Monad +import Control.DeepSeq + + +-- | 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 + + -- Reannotate a module module. + PipeCoreReannotate + :: (NFData b, Show b) + => (a -> b) + -> ![PipeCore b 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 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. + 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 + :: (NFData a, Show b, NFData b) + => Canned (C.Module a n -> IO (C.Module b n)) + -> ![PipeCore b 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 + + PipeCoreReannotate f !pipes + -> {-# SCC "PipeCoreStrip" #-} + let mm' = (C.reannotate f 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 + + PipeCoreAsFlow !pipes + -> {-# SCC "PipeCoreAsFlow" #-} + liftM concat $ mapM (pipeFlow 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 + + +-- 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] + +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 + + +-- PipeFlow ------------------------------------------------------------------- +-- | Process a Core Flow module. +data PipeFlow a where + -- Output the module in core language syntax. + PipeFlowOutput + :: Sink + -> PipeFlow a + + -- Run the prep transform to eta-expand worker functions. + -- It needs to be already a-normalized and namified. + PipeFlowPrep + :: (NFData a, Show a) + => [PipeCore a Flow.Name] + -> PipeFlow a + + -- Run the lowering transform on a module. + -- It needs to be already prepped and have full type annotations. + -- Lowering it kills the annotations. + PipeFlowLower + :: [PipeCore () Flow.Name] + -> PipeFlow (C.AnTEC () Flow.Name) + + -- Wind loop# primops into tail recursive loops. + PipeFlowWind + :: [PipeCore () Flow.Name] + -> PipeFlow (C.AnTEC () Flow.Name) + + + +-- | Process a Core Flow module. +pipeFlow :: C.Module a Flow.Name + -> PipeFlow a + -> IO [Error] + +pipeFlow !mm !pp + = case pp of + PipeFlowOutput !sink + -> {-# SCC "PipeFlowOutput" #-} + pipeSink (renderIndent $ ppr mm) sink + + PipeFlowPrep !pipes + -> {-# SCC "PipeFlowPrep" #-} + let -- Run the prep transform itself which finds worker functions, + -- eta-expands them and returns their names. + (mm_prep, nsWorker) + = Flow.prepModule mm + + -- Force all worker functions to be floated forward into their + -- use sites. + isFloatable lts + = case lts of + C.LLet (C.BName n _) _ + | Just{} <- Map.lookup n nsWorker + -> Forward.FloatForce + _ -> Forward.FloatAllow + + config = Forward.Config isFloatable False + + mm_float + = C.result $ Forward.forwardModule Flow.profile + config mm_prep + + -- Ensure the final code is 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_float) 0 + + in pipeCores mm_namified pipes + + PipeFlowLower !pipes + -> {-# SCC "PipeFlowLower" #-} + let mm_stripped = C.reannotate (const ()) mm + processes = Flow.slurpProcesses mm_stripped + procedures = map Flow.scheduleProcess processes + mm_lowered = Flow.extractModule mm_stripped procedures + + in pipeCores mm_lowered pipes + + PipeFlowWind !pipes + -> {-# SCC "PipeFlowWind" #-} + let mm_stripped = C.reannotate (const ()) mm + mm_wound = Flow.windModule mm_stripped + in pipeCores mm_wound pipes + + diff --git a/DDC/Build/Pipeline/Error.hs b/DDC/Build/Pipeline/Error.hs new file mode 100644 --- /dev/null +++ b/DDC/Build/Pipeline/Error.hs @@ -0,0 +1,53 @@ + +module DDC.Build.Pipeline.Error + (Error (..)) +where +import DDC.Base.Pretty +import qualified DDC.Core.Salt as Salt +import qualified DDC.Core.Load as CL +import Control.DeepSeq + + +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 + diff --git a/DDC/Build/Pipeline/Llvm.hs b/DDC/Build/Pipeline/Llvm.hs new file mode 100644 --- /dev/null +++ b/DDC/Build/Pipeline/Llvm.hs @@ -0,0 +1,77 @@ + +module DDC.Build.Pipeline.Llvm + ( PipeLlvm(..) + , pipeLlvm) +where +import DDC.Build.Pipeline.Error +import DDC.Build.Pipeline.Sink +import DDC.Build.Builder +import DDC.Llvm.Pretty () +import DDC.Base.Pretty +import Control.Monad +import qualified DDC.Llvm.Syntax as Llvm +import System.Directory + + +-- | 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 [] + diff --git a/DDC/Build/Pipeline/Salt.hs b/DDC/Build/Pipeline/Salt.hs new file mode 100644 --- /dev/null +++ b/DDC/Build/Pipeline/Salt.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE GADTs #-} +module DDC.Build.Pipeline.Salt + ( PipeSalt (..) + , pipeSalt) +where +import DDC.Build.Pipeline.Error +import DDC.Build.Pipeline.Sink +import DDC.Build.Pipeline.Llvm +import DDC.Build.Builder +import DDC.Base.Pretty +import DDC.Llvm.Pretty () +import DDC.Core.Check (AnTEC) +import qualified DDC.Core.Transform.Reannotate as C +import qualified DDC.Core.Module as C +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 as Salt +import Control.Monad +import Control.DeepSeq +import System.Directory + + +-- | 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 [] diff --git a/DDC/Build/Pipeline/Sink.hs b/DDC/Build/Pipeline/Sink.hs new file mode 100644 --- /dev/null +++ b/DDC/Build/Pipeline/Sink.hs @@ -0,0 +1,34 @@ + +module DDC.Build.Pipeline.Sink + ( Sink(..) + , pipeSink) +where +import DDC.Build.Pipeline.Error + +-- | 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 [] diff --git a/DDC/Build/Pipeline/Text.hs b/DDC/Build/Pipeline/Text.hs new file mode 100644 --- /dev/null +++ b/DDC/Build/Pipeline/Text.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE GADTs #-} +module DDC.Build.Pipeline.Text + ( PipeText (..) + , pipeText) +where +import DDC.Build.Pipeline.Error +import DDC.Build.Pipeline.Sink +import DDC.Build.Pipeline.Core +import DDC.Build.Language +import DDC.Base.Pretty +import qualified DDC.Base.Parser as BP +import qualified DDC.Core.Check as C +import qualified DDC.Core.Load as CL +import Control.DeepSeq + + +-- | 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 BP.SourcePos 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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2012 The Disciplined Disciple Compiler Strike Force +Copyrite (K) 2007-2013 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy 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.3.1.3 +Version: 0.3.2.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -21,21 +21,33 @@ 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.* + ddc-base == 0.3.2.*, + ddc-core == 0.3.2.*, + ddc-core-eval == 0.3.2.*, + ddc-core-simpl == 0.3.2.*, + ddc-core-salt == 0.3.2.*, + ddc-core-llvm == 0.3.2.*, + ddc-core-flow == 0.3.2.*, + ddc-core-tetra == 0.3.2.* Exposed-modules: + DDC.Build.Language.Tetra DDC.Build.Language.Eval DDC.Build.Language.Lite DDC.Build.Language.Salt + DDC.Build.Language.Flow DDC.Build.Language.Zero DDC.Build.Language - DDC.Build.Builder + + DDC.Build.Pipeline.Core + DDC.Build.Pipeline.Error + DDC.Build.Pipeline.Llvm + DDC.Build.Pipeline.Salt + DDC.Build.Pipeline.Sink + DDC.Build.Pipeline.Text DDC.Build.Pipeline + + DDC.Build.Builder DDC.Build.Platform Other-modules: