diff --git a/DDC/Build/Builder.hs b/DDC/Build/Builder.hs --- a/DDC/Build/Builder.hs +++ b/DDC/Build/Builder.hs @@ -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" ] 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 @@ -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) diff --git a/DDC/Build/Language/Tetra.hs b/DDC/Build/Language/Tetra.hs --- a/DDC/Build/Language/Tetra.hs +++ b/DDC/Build/Language/Tetra.hs @@ -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) diff --git a/DDC/Build/Pipeline.hs b/DDC/Build/Pipeline.hs --- a/DDC/Build/Pipeline.hs +++ b/DDC/Build/Pipeline.hs @@ -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 (..) diff --git a/DDC/Build/Pipeline/Core.hs b/DDC/Build/Pipeline/Core.hs --- a/DDC/Build/Pipeline/Core.hs +++ b/DDC/Build/Pipeline/Core.hs @@ -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 diff --git a/DDC/Build/Pipeline/Error.hs b/DDC/Build/Pipeline/Error.hs --- a/DDC/Build/Pipeline/Error.hs +++ b/DDC/Build/Pipeline/Error.hs @@ -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 diff --git a/DDC/Build/Pipeline/Text.hs b/DDC/Build/Pipeline/Text.hs --- a/DDC/Build/Pipeline/Text.hs +++ b/DDC/Build/Pipeline/Text.hs @@ -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 "" 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 + + + + + diff --git a/DDC/Build/Platform.hs b/DDC/Build/Platform.hs --- a/DDC/Build/Platform.hs +++ b/DDC/Build/Platform.hs @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 - 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.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