ddc-build 0.3.2.1 → 0.4.1.1
raw patch · 10 files changed
+487/−149 lines, 10 filesdep +ddc-source-tetradep ~basedep ~ddc-basedep ~ddc-core
Dependencies added: ddc-source-tetra
Dependency ranges changed: base, ddc-base, ddc-core, ddc-core-eval, ddc-core-flow, ddc-core-llvm, ddc-core-salt, ddc-core-simpl, ddc-core-tetra, process
Files
- DDC/Build/Builder.hs +68/−11
- DDC/Build/Language/Base.hs +1/−0
- DDC/Build/Language/Tetra.hs +13/−25
- DDC/Build/Pipeline.hs +7/−3
- DDC/Build/Pipeline/Core.hs +233/−49
- DDC/Build/Pipeline/Error.hs +32/−14
- DDC/Build/Pipeline/Text.hs +102/−9
- DDC/Build/Platform.hs +5/−0
- LICENSE +1/−15
- ddc-build.cabal +25/−23
DDC/Build/Builder.hs view
@@ -2,6 +2,7 @@ module DDC.Build.Builder ( BuilderConfig (..) , Builder (..)+ , BuilderResult (..) , builders , determineDefaultBuilder)@@ -10,7 +11,7 @@ import DDC.Base.Pretty hiding ((</>)) import System.FilePath import System.Exit-import System.Cmd+import System.Process import qualified DDC.Core.Salt.Platform as Llvm -- | Configuration information for a builder that is not platform specific.@@ -146,18 +147,21 @@ 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_32 OsLinux)+ -> return $ Just (builder_X8632_Linux config) - Just (Platform ArchX86_64 OsLinux)- -> return $ Just (builder_X8664_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 ArchPPC_32 OsLinux)+ -> return $ Just (builder_PPC32_Linux config) - Just (Platform ArchX86_32 OsCygwin)- -> return $ Just (builder_X8632_Cygwin config)+ Just (Platform ArchX86_32 OsCygwin)+ -> return $ Just (builder_X8632_Cygwin config) + Just (Platform ArchX86_32 OsMingw)+ -> return $ Just (builder_X8632_Mingw config)+ _ -> return Nothing @@ -466,12 +470,65 @@ , "-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.+ -- 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+ }+++-- x86_32-mingw ----------------------------------------------------------------+builder_X8632_Mingw config+ = Builder+ { builderName = "x86_32-mingw"+ , buildHost = Platform ArchX86_32 OsMingw+ , buildTarget = Platform ArchX86_32 OsMingw+ , 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 -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 ]++ , buildLdExe + = \oFile binFile+ -> doCmd "linker" [(2, BuilderCanceled)]+ [ "gcc -m32" , "-o", normalise binFile , normalise oFile , normalise $ builderConfigBaseLibDir config </> "libddc-runtime.a" ]
DDC/Build/Language/Base.hs view
@@ -26,6 +26,7 @@ , Show n , Pretty n , Pretty (err (AnTEC BP.SourcePos n))+ , Pretty (err (AnTEC () n)) , NFData n) => Language (Bundle s n err)
DDC/Build/Language/Tetra.hs view
@@ -1,21 +1,17 @@ -- | The `Tetra` fragment has four base kinds: --- `Data`, `Region`, `Effect`, `Witness` and uses the `S`--- computation type to represent effects.+-- `Data`, `Region`, `Effect`, `Witness`,+-- and uses the `S` computation type to represent effects. module DDC.Build.Language.Tetra ( language , bundle- , fragment-- , Error (..))+ , fragment) 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 DDC.Core.Tetra as E import qualified Data.Map as Map @@ -25,35 +21,27 @@ -- | Language bundle for Disciple Core Tetra.-bundle :: Bundle Int Name Error+bundle :: Bundle Int E.Name E.Error bundle = Bundle { bundleFragment = fragment , bundleModules = Map.empty , bundleStateInit = 0 :: Int , bundleSimplifier = Trans Id- , bundleMakeNamifierT = makeNamifier freshT - , bundleMakeNamifierX = makeNamifier freshX + , bundleMakeNamifierT = makeNamifier E.freshT + , bundleMakeNamifierX = makeNamifier E.freshX , bundleRewriteRules = Map.empty } -- | Fragement definition for Disciple Core Tetra.-fragment :: Fragment Name Error+fragment :: Fragment E.Name E.Error fragment = Fragment- { fragmentProfile = profile + { fragmentProfile = E.profile , fragmentExtension = "dct"- , fragmentReadName = readName- , fragmentLexModule = lexModuleString- , fragmentLexExp = lexExpString- , fragmentCheckModule = const Nothing+ , fragmentReadName = E.readName+ , fragmentLexModule = E.lexModuleString+ , fragmentLexExp = E.lexExpString+ , fragmentCheckModule = E.checkModule , fragmentCheckExp = const Nothing }---data Error a- = Error- deriving Show--instance Pretty (Error a) where- ppr Error = text (show Error)
DDC/Build/Pipeline.hs view
@@ -17,13 +17,17 @@ , PipeCore (..) , pipeCore - -- * Core Flow modules- , PipeFlow (..)- , pipeFlow+ -- * Core Tetra modules+ , PipeTetra (..)+ , pipeTetra -- * Core Lite modules , PipeLite (..) , pipeLite++ -- * Core Flow modules+ , PipeFlow (..)+ , pipeFlow -- * Core Salt modules , PipeSalt (..)
DDC/Build/Pipeline/Core.hs view
@@ -4,6 +4,9 @@ , pipeCore , pipeCores + , PipeTetra (..)+ , pipeTetra+ , PipeLite (..) , pipeLite @@ -21,12 +24,14 @@ 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.Melt as Flow import qualified DDC.Core.Flow.Transform.Wind as Flow+import qualified DDC.Core.Flow.Transform.Rates.SeriesOfVector as Flow +import qualified DDC.Core.Tetra as Tetra+import qualified DDC.Core.Tetra.Transform.Boxing as Tetra+ import qualified DDC.Core.Lite as Lite import qualified DDC.Core.Salt.Platform as Salt@@ -34,19 +39,23 @@ 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.Deannotate as C import qualified DDC.Core.Transform.Namify as C+import qualified DDC.Core.Transform.Forward as Forward+import qualified DDC.Core.Transform.Snip as Snip+import qualified DDC.Core.Transform.Flatten as Flatten+import qualified DDC.Core.Transform.Eta as Eta import qualified DDC.Core.Simplifier as C import qualified DDC.Core.Fragment as C import qualified DDC.Core.Check as C+import qualified DDC.Core.Pretty as C import qualified DDC.Core.Module as C import qualified DDC.Core.Exp as C import qualified DDC.Type.Env as Env import qualified Control.Monad.State.Strict as S-import qualified Data.Map as Map import Control.Monad import Control.DeepSeq @@ -60,19 +69,24 @@ -- Output a module to console or file. PipeCoreOutput - :: !Sink + :: !(C.PrettyMode (C.Module a n))+ -> !Sink -> PipeCore a n -- Type check a module. PipeCoreCheck - :: !(Fragment n err)- -> ![PipeCore (C.AnTEC a n) n]+ :: (Pretty a, Pretty (err (C.AnTEC a n)))+ => !(Fragment n err) -- Language fragment to check against.+ -> !(C.Mode n) -- Checker mode.+ -> !Sink -- Sink for checker trace.+ -> ![PipeCore (C.AnTEC a n) n] -- Pipes for result. -> PipeCore a n -- Type check a module, discarding previous per-node type annotations. PipeCoreReCheck- :: (Show a, NFData a)+ :: (NFData a, Show a, Pretty a, Pretty (err (C.AnTEC a n))) => !(Fragment n err)+ -> !(C.Mode n) -> ![PipeCore (C.AnTEC a n) n] -> PipeCore (C.AnTEC a n') n @@ -91,6 +105,11 @@ -> ![PipeCore () n] -> PipeCore a n + -- Treat a module as belonging to the Core Tetra fragment from now on.+ PipeCoreAsTetra+ :: ![PipeTetra (C.AnTEC a Tetra.Name)]+ -> PipeCore (C.AnTEC a Tetra.Name) Tetra.Name+ -- Treat a module as belonging to the Core Lite fragment from now on. PipeCoreAsLite :: ![PipeLite]@@ -133,30 +152,44 @@ -> {-# SCC "PipeCoreId" #-} pipeCores mm pipes - PipeCoreOutput !sink+ PipeCoreOutput !mode !sink -> {-# SCC "PipeCoreOutput" #-}- pipeSink (renderIndent $ ppr mm) sink+ pipeSink (renderIndent $ pprModePrec mode 0 mm) sink - PipeCoreCheck !fragment !pipes+ PipeCoreCheck !fragment !mode !sinkTrace !pipes -> {-# SCC "PipeCoreCheck" #-} let profile = fragmentProfile fragment + -- Check the module is type correct, + -- using the generic core type checker. goCheck mm1- = case C.checkModule (C.configOfProfile profile) mm1 of- Left err -> return [ErrorLint err]- Right mm2 -> goComplies mm2+ = case C.checkModule (C.configOfProfile profile) mm1 mode of+ (Left err, C.CheckTrace doc) + -> do pipeSink (renderIndent doc) sinkTrace+ return [ErrorLint err]+ + (Right mm2, C.CheckTrace doc) + -> do pipeSink (renderIndent doc) sinkTrace+ goComplies mm2 + -- Check the module compiles with the language profile. goComplies mm1 = case C.complies profile mm1 of- Just err -> return [ErrorLint err]- Nothing -> pipeCores mm1 pipes+ Just err -> return [ErrorLint err]+ Nothing -> goFragment mm1 + -- Check the module satisfies fragment specific checks.+ goFragment mm1+ = case fragmentCheckModule fragment mm1 of+ Just err -> return [ErrorLint err]+ Nothing -> pipeCores mm1 pipes+ in goCheck mm - PipeCoreReCheck !fragment !pipes+ PipeCoreReCheck !fragment !mode !pipes -> {-# SCC "PipeCoreReCheck" #-} pipeCore (C.reannotate C.annotTail mm)- $ PipeCoreCheck fragment pipes+ $ PipeCoreCheck fragment mode SinkDiscard pipes PipeCoreReannotate f !pipes -> {-# SCC "PipeCoreStrip" #-}@@ -169,7 +202,7 @@ primKindEnv = C.profilePrimKinds profile primTypeEnv = C.profilePrimTypes profile - !mm' = (flip S.evalState nameZero+ !mm' = (result . flip S.evalState nameZero $ applySimplifier profile primKindEnv primTypeEnv simpl mm) !mm2 = C.reannotate (const ()) mm'@@ -180,6 +213,10 @@ -- release type annotations on the expression tree. in mm2 `deepseq` pipeCores mm2 pipes + PipeCoreAsTetra !pipes+ -> {-# SCC "PipeCoreAsTetra" #-}+ liftM concat $ mapM (pipeTetra mm) pipes+ PipeCoreAsLite !pipes -> {-# SCC "PipeCoreAsLite" #-} liftM concat $ mapM (pipeLite mm) pipes@@ -211,6 +248,57 @@ go (errs ++ err) rest +-- PipeTetra ------------------------------------------------------------------+-- | Process a Core Tetra module.+data PipeTetra a where+ -- Output the module in core language syntax.+ PipeTetraOutput + :: !Sink+ -> PipeTetra a++ -- Manage boxing of numeric values.+ PipeTetraBoxing+ :: (NFData a, Show a)+ => ![PipeCore a Tetra.Name]+ -> PipeTetra a++ -- Convert the module to the Core Salt Fragment.+ PipeTetraToSalt + :: (NFData a, Show a)+ => !Salt.Platform + -> !Salt.Config+ -> ![PipeCore a Salt.Name]+ -> PipeTetra (C.AnTEC a Tetra.Name)+++-- | Process a Core Tetra module.+pipeTetra + :: C.Module a Tetra.Name+ -> PipeTetra a+ -> IO [Error]++pipeTetra !mm !pp+ = case pp of+ PipeTetraOutput !sink+ -> {-# SCC "PipeTetraOutput" #-}+ pipeSink (renderIndent $ ppr mm) sink++ PipeTetraBoxing !pipes+ -> {-# SCC "PipeTetraBoxing" #-}+ pipeCores (Tetra.boxingModule mm) pipes++ PipeTetraToSalt !platform !runConfig !pipes+ -> {-# SCC "PipeTetraToSalt" #-}+ case Tetra.saltOfTetraModule platform runConfig + (C.profilePrimDataDefs Tetra.profile) + (C.profilePrimKinds Tetra.profile)+ (C.profilePrimTypes Tetra.profile)+ mm + of Left err -> return [ErrorTetraConvert err]+ Right mm' -> pipeCores mm' pipes +++ -- PipeLite ------------------------------------------------------------------- -- | Process a Core Lite module. data PipeLite@@ -253,17 +341,35 @@ :: 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] + -- 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.+ PipeFlowHacks+ :: (NFData a, Show b, NFData b)+ => Canned (C.Module a Flow.Name -> IO (C.Module b Flow.Name))+ -> ![PipeFlow b] -> PipeFlow a + -- Run the prep transform to expose flow operators.+ PipeFlowPrep+ :: [PipeCore () Flow.Name] + -> PipeFlow ()++ -- Run rate inference to transform vector operations into loops of series expressions.+ PipeFlowRate+ :: [PipeCore () Flow.Name] + -> PipeFlow ()+ -- Run the lowering transform on a module. -- It needs to be already prepped and have full type annotations. -- Lowering it kills the annotations. PipeFlowLower+ :: Flow.Config+ -> [PipeCore () Flow.Name]+ -> PipeFlow (C.AnTEC () Flow.Name)++ -- Melt compound data into primitive types.+ PipeFlowMelt :: [PipeCore () Flow.Name] -> PipeFlow (C.AnTEC () Flow.Name) @@ -273,7 +379,6 @@ -> PipeFlow (C.AnTEC () Flow.Name) - -- | Process a Core Flow module. pipeFlow :: C.Module a Flow.Name -> PipeFlow a@@ -285,50 +390,129 @@ -> {-# SCC "PipeFlowOutput" #-} pipeSink (renderIndent $ ppr mm) sink + PipeFlowHacks !(Canned f) !pipes+ -> {-# SCC "PipeFlowHacks" #-} + do mm' <- f mm+ pipeFlows mm' pipes+ 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+ let + -- Eta-expand so all workers have explicit parameter names.+ mm_eta = C.result $ Eta.etaModule Flow.profile+ (Eta.configZero { Eta.configExpand = True})+ mm - -- Force all worker functions to be floated forward into their- -- use sites.+ -- Snip program to expose intermediate bindings.+ mm_snip = Flatten.flatten + $ Snip.snip + (Snip.configZero { Snip.configSnipLetBody = True })+ mm_eta++ -- The floater needs bindings to be fully named.+ namifierT = C.makeNamifier Flow.freshT Env.empty+ namifierX = C.makeNamifier Flow.freshX Env.empty+ mm_namified = S.evalState (C.namify namifierT namifierX mm_snip) 0++ -- Float worker functions and initializers into their use sites, + -- leaving only flow operators at the top-level. isFloatable lts = case lts of- C.LLet (C.BName n _) _ - | Just{} <- Map.lookup n nsWorker- -> Forward.FloatForce- _ -> Forward.FloatAllow+ C.LLet (C.BName _ _) x+ | Flow.isSeriesOperator (C.deannotate (const Nothing) x)+ -> Forward.FloatDeny+ _ -> Forward.FloatForce - config = Forward.Config isFloatable False+ mm_float = C.result $ Forward.forwardModule Flow.profile + (Forward.Config isFloatable False)+ mm_namified - mm_float- = C.result $ Forward.forwardModule Flow.profile - config mm_prep+ in pipeCores mm_float pipes - -- Ensure the final code is fully named.+ PipeFlowRate !pipes+ -> {-# SCC "PipeFlowRate" #-}+ let + -- Eta-expand so all workers have explicit parameter names.+ mm_eta = C.result $ Eta.etaModule Flow.profile+ (Eta.configZero { Eta.configExpand = True})+ mm++ -- Snip program to expose intermediate bindings.+ mm_snip = Flatten.flatten + $ Snip.snip + (Snip.configZero { Snip.configSnipLetBody = True })+ mm_eta++ -- The floater needs bindings to be fully named. namifierT = C.makeNamifier Flow.freshT Env.empty namifierX = C.makeNamifier Flow.freshX Env.empty+ mm_namified = S.evalState (C.namify namifierT namifierX mm_snip) 0 - mm_namified- = S.evalState (C.namify namifierT namifierX mm_float) 0+ -- Float worker functions and initializers into their use sites, + -- leaving only flow operators at the top-level.+ isFloatable lts+ = case lts of+ C.LLet (C.BName _ _) x+ | Flow.isVectorOperator (C.deannotate (const Nothing) x)+ -> Forward.FloatDeny+ _ -> Forward.FloatForce - in pipeCores mm_namified pipes+ mm_float = C.result $ Forward.forwardModule Flow.profile + (Forward.Config isFloatable False)+ mm_namified - PipeFlowLower !pipes+ goRate+ = case C.checkModule (C.configOfProfile Flow.profile) mm_float C.Recon of+ (Left err, _) + -> return [ErrorCoreTransform err]++ (Right mm', _) + -> let mm_stripped = C.reannotate (const ()) mm'+ mm_flow = fst $ Flow.seriesOfVectorModule mm_stripped+ + -- Check again to synthesise types+ in case C.checkModule (C.configOfProfile Flow.profile) mm_flow C.Recon of+ (Left err, _ct) + -> return [ErrorCoreTransform err]+ + (Right mm_flow', _ct) + -> let mm_reannot' = C.reannotate (const ()) mm_flow'+ in pipeCores mm_reannot' pipes+ in goRate+++ PipeFlowLower !config !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+ in case Flow.lowerModule config mm_stripped of+ Right mm' -> pipeCores mm' pipes+ Left err -> return [ErrorCoreTransform err] + PipeFlowMelt !pipes+ -> {-# SCC "PipeFlowMelt" #-}+ let mm_stripped = C.reannotate (const ()) mm+ (mm_melted, _info) = Flow.meltModule mm_stripped+ in pipeCores mm_melted pipes+ PipeFlowWind !pipes -> {-# SCC "PipeFlowWind" #-} let mm_stripped = C.reannotate (const ()) mm mm_wound = Flow.windModule mm_stripped in pipeCores mm_wound pipes+++-- | Process a Flow module with several different pipes.+pipeFlows :: (NFData a, Show a)+ => C.Module a Flow.Name -> [PipeFlow a] -> IO [Error]++pipeFlows !mm !pipes + = go [] pipes+ where go !errs [] + = return errs++ go !errs (pipe : rest)+ = do !err <- pipeFlow mm pipe+ go (errs ++ err) rest
DDC/Build/Pipeline/Error.hs view
@@ -3,32 +3,49 @@ (Error (..)) where import DDC.Base.Pretty+import DDC.Data.SourcePos 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+ = forall err. Pretty err => ErrorLoad !err -- | Error when type checking a transformed module. -- Blame it on the compiler. | forall err. Pretty err => ErrorLint !err + | forall err. Pretty (err (CL.AnTEC SourcePos Salt.Name))+ => ErrorSaltLoad (CL.Error Salt.Name err) + -- | Error converting the module to Salt to Sea.+ | forall err. Pretty err => ErrorSaltConvert !err++ -- | Error converting the module from Tetra to Salt.+ | forall err. Pretty err => ErrorTetraConvert !err++ -- | Error converting the module from Lite to Salt.+ | forall err. Pretty err => ErrorLiteConvert !err++ -- | Error when transforming core program.+ | forall err. Pretty err => ErrorCoreTransform !err+++ instance Pretty Error where ppr err = case err of+ ErrorLoad err'+ -> vcat [ text "Error loading module"+ , indent 2 (ppr err') ]++ ErrorLint err'+ -> vcat [ text "Error in transformed module."+ , indent 2 (ppr err') ]+ ErrorSaltLoad err' -> vcat [ text "Type error when loading Salt module." , indent 2 (ppr err') ]@@ -37,17 +54,18 @@ -> vcat [ text "Fragment violation when converting Salt module to C code." , indent 2 (ppr err') ] + ErrorTetraConvert err'+ -> vcat [ text "Fragment violation when converting Tetra module to Salt module."+ , indent 2 (ppr err') ]+ ErrorLiteConvert err' -> vcat [ text "Fragment violation when converting Lite module to Salt module." , indent 2 (ppr err') ] - ErrorLoad err'- -> vcat [ text "Error loading module"+ ErrorCoreTransform err'+ -> vcat [ text "Error transforming core program." , indent 2 (ppr err') ] - ErrorLint err'- -> vcat [ text "Error in transformed module."- , indent 2 (ppr err') ] instance NFData Error
DDC/Build/Pipeline/Text.hs view
@@ -8,9 +8,25 @@ 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 qualified DDC.Source.Tetra.ToCore as SE+import qualified DDC.Source.Tetra.Transform.Defix as SE+import qualified DDC.Source.Tetra.Transform.Expand as SE+import qualified DDC.Source.Tetra.Parser as SE+import qualified DDC.Source.Tetra.Lexer as SE+import qualified DDC.Source.Tetra.Env as SE++import qualified DDC.Build.Language.Tetra as CE+import qualified DDC.Core.Tetra as CE+import qualified DDC.Core.Tetra.Env as CE++import qualified DDC.Core.Parser as C+import qualified DDC.Core.Transform.SpreadX as C+import qualified DDC.Core.Check as C+import qualified DDC.Core.Load as C+import qualified DDC.Core.Lexer as C+import qualified DDC.Base.Parser as BP+import qualified DDC.Data.SourcePos as SP import Control.DeepSeq @@ -21,12 +37,21 @@ -> PipeText n err PipeTextLoadCore - :: (Ord n, Show n, Pretty n)+ :: (Ord n, Show n, Pretty n, Pretty (err (C.AnTEC SP.SourcePos n))) => !(Fragment n err)+ -> !(C.Mode n)+ -> !Sink -> ![PipeCore (C.AnTEC BP.SourcePos n) n] -> PipeText n err + PipeTextLoadSourceTetra+ :: !Sink -- Sink for source tokens.+ -> !Sink -- Sink for core code before final type checking.+ -> !Sink -- Sink for type checker trace.+ -> ![PipeCore (C.AnTEC BP.SourcePos CE.Name) CE.Name]+ -> PipeText n err + -- | Process a text module. -- -- Returns empty list on success.@@ -44,9 +69,77 @@ -> {-# SCC "PipeTextOutput" #-} pipeSink str sink - PipeTextLoadCore !frag !pipes+ PipeTextLoadCore !fragment !mode !sink !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+ let toks = fragmentLexModule fragment srcName srcLine str + in case C.loadModuleFromTokens fragment srcName mode toks of+ (Left err, mct) + -> do sinkCheckTrace mct sink+ return [ErrorLoad err]++ (Right mm, mct) + -> do sinkCheckTrace mct sink+ pipeCores mm pipes++ PipeTextLoadSourceTetra + sinkTokens+ sinkPreCheck + sinkCheckerTrace pipes+ -> {-# SCC "PipeTextLoadSourceTetra" #-}+ let goParse+ = do -- Lex the input text into source tokens.+ let tokens = SE.lexModuleString srcName srcLine str++ pipeSink (unlines $ map show $ tokens) sinkTokens++ -- Parse the source tokens.+ let context = C.Context+ { C.contextTrackedEffects = True+ , C.contextTrackedClosures = True+ , C.contextFunctionalEffects = False+ , C.contextFunctionalClosures = False }++ case BP.runTokenParser C.describeTok srcName+ (SE.pModule context) tokens of+ Left err -> return [ErrorLoad err]+ Right mm -> goDesugar mm++ goDesugar mm+ = case SE.defix SE.defaultFixTable mm of+ Left err -> return [ErrorLoad err]+ Right mm' -> goToCore mm'++ goToCore mm+ = do -- Expand missing quantifiers in signatures.+ let mm_expand = SE.expand SE.configDefault + SE.primKindEnv SE.primTypeEnv mm++ -- Convert Source Tetra to Core Tetra.+ -- This source position is used to annotate the let expression+ -- that holds all the top-level bindings.+ let sp = SP.SourcePos "<top level>" 1 1+ let mm_core = SE.toCoreModule sp mm_expand++ -- Spread types of data constructors into uses.+ let mm_spread = C.spreadX + CE.primKindEnv CE.primTypeEnv mm_core++ -- Dump code before checking for debugging purposes.+ pipeSink (renderIndent $ ppr mm_spread) sinkPreCheck++ -- Use the existing checker pipeline to Synthesise+ -- missing type annotations.+ pipeCore mm_spread+ $ PipeCoreCheck CE.fragment C.Synth sinkCheckerTrace pipes++ in goParse++ where sinkCheckTrace mct sink+ = case mct of+ Nothing -> return []+ Just (C.CheckTrace doc) -> pipeSink (renderIndent doc) sink+++++
DDC/Build/Platform.hs view
@@ -42,6 +42,7 @@ OsDarwin -> "a" OsLinux -> "a" OsCygwin -> "a"+ OsMingw -> "a" -- | Get the file extension to use for a shared library on this platform.@@ -51,6 +52,7 @@ OsDarwin -> "dylib" OsLinux -> "so" OsCygwin -> "so"+ OsMingw -> "dll" -------------------------------------------------------------------------------@@ -87,6 +89,7 @@ = OsDarwin | OsLinux | OsCygwin+ | OsMingw deriving (Eq, Show) instance Pretty Os where@@ -95,6 +98,7 @@ OsDarwin -> text "Darwin" OsLinux -> text "Linux" OsCygwin -> text "Cygwin"+ OsMingw -> text "Mingw" -- Determinators --------------------------------------------------------------@@ -150,6 +154,7 @@ | isPrefixOf "Darwin" strOs = Just OsDarwin | isPrefixOf "Linux" strOs = Just OsLinux | isPrefixOf "CYGWIN" strOs = Just OsCygwin+ | isPrefixOf "MINGW" strOs = Just OsMingw | otherwise = Nothing return result
LICENSE view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2013 The Disciplined Disciple Compiler Strike Force+Copyrite (K) 2007-2014 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy@@ -13,18 +13,4 @@ The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.----------------------------------------------------------------------------------Under Australian law copyright is free and automatic.-By contributing to DDC authors grant all rights they have regarding their-contributions to the other members of the Disciplined Disciple Compiler Strike-Force, past, present and future, as well as placing their contributions under-the above license.--Use "darcs show authors" to get a list of Strike Force members.- ---------------------------------------------------------------------------------Redistributions of libraries in ./external are governed by their own licenses:-- - TinyPTC GNU Lesser General Public License-
ddc-build.cabal view
@@ -1,5 +1,5 @@ Name: ddc-build-Version: 0.3.2.1+Version: 0.4.1.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force@@ -14,42 +14,43 @@ 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.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.*+ base >= 4.6 && < 4.8,+ process >= 1.1 && < 1.3,+ deepseq == 1.3.*,+ containers == 0.5.*,+ filepath == 1.3.*,+ directory == 1.2.*,+ mtl == 2.1.*,+ ddc-base == 0.4.1.*,+ ddc-core == 0.4.1.*,+ ddc-core-eval == 0.4.1.*,+ ddc-core-simpl == 0.4.1.*,+ ddc-core-salt == 0.4.1.*,+ ddc-core-llvm == 0.4.1.*,+ ddc-core-flow == 0.4.1.*,+ ddc-core-tetra == 0.4.1.*,+ ddc-source-tetra == 0.4.1.* Exposed-modules:- DDC.Build.Language.Tetra DDC.Build.Language.Eval+ DDC.Build.Language.Flow DDC.Build.Language.Lite DDC.Build.Language.Salt- DDC.Build.Language.Flow+ DDC.Build.Language.Tetra DDC.Build.Language.Zero- DDC.Build.Language-+ 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.Language+ DDC.Build.Pipeline DDC.Build.Platform-+ Other-modules: DDC.Build.Language.Base @@ -68,4 +69,5 @@ ghc-options: -Wall -fno-warn-missing-signatures+ -fno-warn-missing-methods -fno-warn-unused-do-bind