module Feldspar.Compiler.Compiler where
import System.FilePath
import Data.Typeable as DT
import Control.Arrow
import Control.Applicative
import Feldspar.Transformation
import qualified Feldspar.NameExtractor as NameExtractor
import Feldspar.Compiler.Backend.C.Library
import Feldspar.Compiler.Backend.C.Options
import Feldspar.Compiler.Backend.C.Platforms
import Feldspar.Compiler.Backend.C.Plugin.Rule
import Feldspar.Compiler.Backend.C.Plugin.TypeDefinitionGenerator
import Feldspar.Compiler.Backend.C.Plugin.VariableRoleAssigner
import Feldspar.Compiler.Backend.C.Plugin.BlockProgramHandler
import Feldspar.Compiler.Backend.C.Plugin.TypeCorrector
import Feldspar.Compiler.Backend.C.Plugin.PrettyPrint
import Feldspar.Compiler.Imperative.FromCore
import Feldspar.Compiler.Imperative.Plugin.ConstantFolding
import Feldspar.Compiler.Imperative.Plugin.Free
import Feldspar.Compiler.Imperative.Plugin.IVars
import Feldspar.Compiler.Imperative.Plugin.Naming
import Feldspar.Compiler.Imperative.Plugin.Unroll
data SomeCompilable = forall a internal . Compilable a internal => SomeCompilable a
deriving (DT.Typeable)
type Position = (Int, Int)
data SplitModuleDescriptor = SplitModuleDescriptor {
smdSource :: Module (),
smdHeader :: Module ()
}
data CompToCCoreResult = CompToCCoreResult {
sourceCode :: String,
endPosition :: Position,
debugModule :: Module DebugToCSemanticInfo
}
data SplitCompToCCoreResult = SplitCompToCCoreResult {
sctccrSource :: CompToCCoreResult,
sctccrHeader :: CompToCCoreResult
}
data IncludesNeeded = IncludesNeeded | NoIncludesNeeded { incneedLineNum :: Int }
moduleSplitter :: Module () -> SplitModuleDescriptor
moduleSplitter m = SplitModuleDescriptor {
smdHeader = Module (filter belongsToHeader (entities m) ++ createProcDecls (entities m)) (moduleLabel m),
smdSource = Module (filter (not . belongsToHeader) $ entities m) (moduleLabel m)
} where
belongsToHeader :: Entity () -> Bool
belongsToHeader StructDef{} = True
belongsToHeader ProcDecl{} = True
belongsToHeader _ = False
createProcDecls :: [Entity ()] -> [Entity ()]
createProcDecls = foldr ((++) . convertProcDefToProcDecl) []
convertProcDefToProcDecl :: Entity () -> [Entity ()]
convertProcDefToProcDecl e = case e of
ProcDef n inparams outparams _ label1 label2 -> [ProcDecl n inparams outparams label1 label2]
_ -> []
separateAndCompileToCCore :: (Compilable t internal)
=> (Module ()
-> [Module ()])
-> CompilationMode -> t -> IncludesNeeded
-> NameExtractor.OriginalFunctionSignature -> Options
-> [(CompToCCoreResult, Module ())]
separateAndCompileToCCore
moduleSeparator
compMode prg needed
functionSignature coreOptions =
pack <$> separatedModules
where
pack = compToCWithInfo &&& id
separatedModules =
moduleSeparator $
executePluginChain' compMode prg functionSignature coreOptions
compToCWithInfo = moduleToCCore needed coreOptions
moduleToCCore
:: IncludesNeeded -> Options -> Module ()
-> CompToCCoreResult
moduleToCCore needed opts mdl =
CompToCCoreResult {
sourceCode = incls ++ moduleSrc
, endPosition = endPos
, debugModule = dbgModule
}
where
(incls, lineNum) = genInclude needed
(dbgModule, (moduleSrc, endPos)) =
compToCWithInfos ((opts,Declaration_pl), lineNum) mdl
genInclude IncludesNeeded = genIncludeLines opts Nothing
genInclude (NoIncludesNeeded ln) = ("", ln)
compileToCCore
:: (Compilable t internal) => CompilationMode -> t -> Maybe String -> IncludesNeeded
-> NameExtractor.OriginalFunctionSignature -> Options
-> SplitCompToCCoreResult
compileToCCore compMode prg _ includesNeeded
funSig coreOptions =
createSplit $ fst <$> separateAndCompileToCCore headerAndSource
compMode prg includesNeeded funSig coreOptions
where
headerAndSource modules = [header, source]
where (SplitModuleDescriptor header source) = moduleSplitter modules
createSplit [header, source] = SplitCompToCCoreResult header source
genIncludeLinesCore :: [String] -> (String, Int)
genIncludeLinesCore [] = ("", 1)
genIncludeLinesCore (x:xs) = ("#include " ++ x ++ "\n" ++ str, linenum + 1) where
(str, linenum) = genIncludeLinesCore xs
genIncludeLines :: Options -> Maybe String -> (String, Int)
genIncludeLines coreOptions mainHeader = (str ++ "\n\n", linenum + 2) where
(str, linenum) = genIncludeLinesCore $ includes (platform coreOptions) ++ mainHeaderCore
mainHeaderCore = case mainHeader of
Nothing -> []
Just filename -> ["\"" ++ takeFileName filename ++ ".h\""]
defaultOptions :: Options
defaultOptions
= Options
{ platform = c99
, unroll = NoUnroll
, debug = NoDebug
, memoryInfoVisible = True
, rules = []
}
c99PlatformOptions :: Options
c99PlatformOptions = defaultOptions
tic64xPlatformOptions :: Options
tic64xPlatformOptions = defaultOptions { platform = tic64x }
unrollOptions :: Options
unrollOptions = defaultOptions { unroll = Unroll 8 }
noPrimitiveInstructionHandling :: Options
noPrimitiveInstructionHandling = defaultOptions { debug = NoPrimitiveInstructionHandling }
noMemoryInformation :: Options
noMemoryInformation = defaultOptions { memoryInfoVisible = False }
pluginChain :: ExternalInfoCollection -> Module () -> Module ()
pluginChain externalInfo
= executePlugin RulePlugin (ruleExternalInfo externalInfo)
. executePlugin TypeDefinitionGenerator (typeDefinitionGeneratorExternalInfo externalInfo)
. executePlugin ConstantFolding ()
. executePlugin UnrollPlugin (unrollExternalInfo externalInfo)
. executePlugin Precompilation (precompilationExternalInfo externalInfo)
. executePlugin RulePlugin (primitivesExternalInfo externalInfo)
. executePlugin Free ()
. executePlugin IVarPlugin ()
. executePlugin VariableRoleAssigner (variableRoleAssignerExternalInfo externalInfo)
. executePlugin TypeCorrector (typeCorrectorExternalInfo externalInfo)
. executePlugin BlockProgramHandler ()
data ExternalInfoCollection = ExternalInfoCollection {
precompilationExternalInfo :: ExternalInfo Precompilation
, unrollExternalInfo :: ExternalInfo UnrollPlugin
, primitivesExternalInfo :: ExternalInfo RulePlugin
, ruleExternalInfo :: ExternalInfo RulePlugin
, typeDefinitionGeneratorExternalInfo :: ExternalInfo TypeDefinitionGenerator
, variableRoleAssignerExternalInfo :: ExternalInfo VariableRoleAssigner
, typeCorrectorExternalInfo :: ExternalInfo TypeCorrector
}
executePluginChain' :: (Compilable c internal)
=> CompilationMode -> c -> NameExtractor.OriginalFunctionSignature
-> Options -> Module ()
executePluginChain' compMode prg originalFunctionSignatureParam opt =
pluginChain ExternalInfoCollection {
precompilationExternalInfo = PrecompilationExternalInfo {
originalFunctionSignature = fixedOriginalFunctionSignature
, inputParametersDescriptor = buildInParamDescriptor prg
, numberOfFunctionArguments = numArgs prg
, compilationMode = compMode
}
, unrollExternalInfo = unroll opt
, primitivesExternalInfo = opt{ rules = platformRules $ platform opt }
, ruleExternalInfo = opt
, typeDefinitionGeneratorExternalInfo = opt
, variableRoleAssignerExternalInfo = ()
, typeCorrectorExternalInfo = False
} $ fromCore "PLACEHOLDER" prg
where
ofn = NameExtractor.originalFunctionName
fixedOriginalFunctionSignature = originalFunctionSignatureParam {
NameExtractor.originalFunctionName =
fixFunctionName $ ofn originalFunctionSignatureParam
}
executePluginChain :: (Compilable c internal)
=> CompilationMode
-> c
-> NameExtractor.OriginalFunctionSignature
-> Options
-> SplitModuleDescriptor
executePluginChain cm f sig opts =
moduleSplitter $ executePluginChain' cm f sig opts