ddc-build 0.3.1.3 → 0.3.2.1

raw patch · 14 files changed

+852/−515 lines, 14 filesdep +ddc-core-flowdep +ddc-core-tetradep ~ddc-basedep ~ddc-coredep ~ddc-core-evalPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: ddc-core-flow, ddc-core-tetra

Dependency ranges changed: ddc-base, ddc-core, ddc-core-eval, ddc-core-llvm, ddc-core-salt, ddc-core-simpl

API changes (from Hackage documentation)

Files

• DDC/Build/Language.hs +12/−5
• DDC/Build/Language/Base.hs +2/−1
• DDC/Build/Language/Eval.hs +5/−4
• DDC/Build/Language/Flow.hs +58/−0
• DDC/Build/Language/Tetra.hs +59/−0
• DDC/Build/Pipeline.hs +11/−496
• DDC/Build/Pipeline/Core.hs +334/−0
• DDC/Build/Pipeline/Error.hs +53/−0
• DDC/Build/Pipeline/Llvm.hs +77/−0
• DDC/Build/Pipeline/Salt.hs +134/−0
• DDC/Build/Pipeline/Sink.hs +34/−0
• DDC/Build/Pipeline/Text.hs +52/−0
• LICENSE +1/−1
• ddc-build.cabal +20/−8

@@ -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+

@@ -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) 

@@ -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  

@@ -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)+

@@ -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)+

@@ -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 

@@ -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++

@@ -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+

@@ -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 []+

@@ -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 []

@@ -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 []

@@ -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

@@ -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

@@ -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: