module Feldspar.Compiler.Imperative.FromCore where
import Control.Monad.RWS
import Language.Syntactic
import Language.Syntactic.Constructs.Binding
import Language.Syntactic.Constructs.Binding.HigherOrder
import Feldspar.Core.Types
import Feldspar.Core.Interpretation
import Feldspar.Core.Constructs
import Feldspar.Core.Constructs.Binding
import Feldspar.Core.Frontend
import Feldspar.Compiler.Imperative.Representation (Module)
import Feldspar.Compiler.Imperative.Frontend hiding (Type)
import Feldspar.Compiler.Imperative.FromCore.Interpretation
import Feldspar.Compiler.Imperative.FromCore.Array ()
import Feldspar.Compiler.Imperative.FromCore.Binding ()
import Feldspar.Compiler.Imperative.FromCore.Condition ()
import Feldspar.Compiler.Imperative.FromCore.ConditionM ()
import Feldspar.Compiler.Imperative.FromCore.Error ()
import Feldspar.Compiler.Imperative.FromCore.FFI ()
import Feldspar.Compiler.Imperative.FromCore.Future ()
import Feldspar.Compiler.Imperative.FromCore.Literal ()
import Feldspar.Compiler.Imperative.FromCore.Loop ()
import Feldspar.Compiler.Imperative.FromCore.Mutable ()
import Feldspar.Compiler.Imperative.FromCore.MutableToPure ()
import Feldspar.Compiler.Imperative.FromCore.NoInline ()
import Feldspar.Compiler.Imperative.FromCore.Par ()
import Feldspar.Compiler.Imperative.FromCore.Primitive ()
import Feldspar.Compiler.Imperative.FromCore.Save ()
import Feldspar.Compiler.Imperative.FromCore.SizeProp ()
import Feldspar.Compiler.Imperative.FromCore.SourceInfo ()
import Feldspar.Compiler.Imperative.FromCore.Tuple ()
instance Compile FeldDomain FeldDomain
where
compileProgSym (C' a) = compileProgSym a
compileExprSym (C' a) = compileExprSym a
instance Compile Empty FeldDomain
where
compileProgSym _ = error "Can't compile Empty"
compileExprSym _ = error "Can't compile Empty"
compileProgTop :: (Compile dom dom, Project (CLambda Type) dom) =>
String -> [Var] -> ASTF (Decor Info dom) a -> Mod
compileProgTop funname args (lam :$ body)
| Just (SubConstr2 (Lambda v)) <- prjLambda lam
= let ta = argType $ infoType $ getInfo lam
sa = defaultSize ta
var = mkVariable (compileTypeRep ta sa) v
in compileProgTop funname (var:args) body
compileProgTop funname args a = Mod defs
where
ins = reverse args
info = getInfo a
outType = compileTypeRep (infoType info) (infoSize info)
outParam = Pointer outType "out"
outLoc = Ptr outType "out"
results = snd $ evalRWS (compileProg outLoc a) initReader initState
Bl ds p = block results
defs = def results ++ [ProcDf funname ins [outParam] (Block ds p)]
class SyntacticFeld a => Compilable a internal | a -> internal
instance SyntacticFeld a => Compilable a ()
fromCore :: SyntacticFeld a => String -> a -> Module ()
fromCore funname
= fromInterface
. compileProgTop funname []
. reifyFeld N32
buildInParamDescriptor :: SyntacticFeld a => a -> [Int]
buildInParamDescriptor = go . reifyFeld N32
where
go :: (Project (CLambda Type) dom) => ASTF (Decor info dom) a -> [Int]
go (lam :$ body)
| Just (SubConstr2 (Lambda _)) <- prjLambda lam
= 1 : go body
go _ = []
numArgs :: SyntacticFeld a => a -> Int
numArgs = length . buildInParamDescriptor