Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Set up for adding new compiler back ends more easily

  • Loading branch information...
commit 16a6c951da8b1822fa82c3a79c8da21509c86e11 1 parent 2533b8d
Edwin Brady authored
View
19 src/IRTS/BCImp.hs
@@ -0,0 +1,19 @@
+module IRTS.BCImp where
+
+-- Bytecode for a register/variable based VM (e.g. for generating code in an
+-- imperative language where we let the language deal with GC)
+
+import IRTS.Lang
+import IRTS.Simplified
+import Core.TT
+
+data Reg = RVal | L Int
+
+data BC = NOP
+
+toBC :: (Name, SDecl) -> (Name, [BC])
+toBC (n, SFun n' args locs exp)
+ = (n, bc RVal exp)
+
+bc :: Reg -> SExp -> [BC]
+bc = undefined
View
3  src/IRTS/Bytecode.hs
@@ -1,5 +1,8 @@
module IRTS.Bytecode where
+-- Bytecode for a stack based VM (e.g. for generating C code with an accurate
+-- hand written GC)
+
import IRTS.Lang
import IRTS.Simplified
import Core.TT
View
21 src/IRTS/CodegenJava.hs
@@ -0,0 +1,21 @@
+module IRTS.CodegenJava where
+
+import IRTS.BCImp
+import IRTS.Lang
+import IRTS.Simplified
+import Core.TT
+import Paths_idris
+import Util.System
+
+import Data.Char
+import System.Process
+import System.Exit
+import System.IO
+import System.Directory
+import Control.Monad
+
+codegenJava :: [(Name, SDecl)] ->
+ String -> -- output file name
+ IO ()
+codegenJava defs out = putStrLn "Not implemented yet"
+
View
47 src/IRTS/Compiler.hs
@@ -6,6 +6,7 @@ import IRTS.Lang
import IRTS.Defunctionalise
import IRTS.Simplified
import IRTS.CodegenC
+import IRTS.CodegenJava
import Idris.AbsSyntax
import Core.TT
@@ -21,28 +22,30 @@ import System.Environment
import Paths_idris
-compileC :: FilePath -> Term -> Idris ()
-compileC f tm = do checkMVs
- let tmnames = namesUsed (STerm tm)
- used <- mapM (allNames []) tmnames
- defsIn <- mkDecls tm (concat used)
- maindef <- irMain tm
- objs <- getObjectFiles
- libs <- getLibs
- hdrs <- getHdrs
- let defs = defsIn ++ [(MN 0 "runMain", maindef)]
- -- iputStrLn $ showSep "\n" (map show defs)
- let (nexttag, tagged) = addTags 0 (liftAll defs)
- let ctxtIn = addAlist tagged emptyContext
- let defuns = defunctionalise nexttag ctxtIn
- -- iputStrLn $ showSep "\n" (map show (toAlist defuns))
- let checked = checkDefs defuns (toAlist defuns)
- case checked of
- OK c -> do -- iputStrLn $ showSep "\n" (map show c)
- liftIO $ codegenC c f True hdrs
- (concatMap mkObj objs)
- (concatMap mkLib libs) NONE
- Error e -> fail $ show e
+compile :: Target -> FilePath -> Term -> Idris ()
+compile target f tm
+ = do checkMVs
+ let tmnames = namesUsed (STerm tm)
+ used <- mapM (allNames []) tmnames
+ defsIn <- mkDecls tm (concat used)
+ maindef <- irMain tm
+ objs <- getObjectFiles
+ libs <- getLibs
+ hdrs <- getHdrs
+ let defs = defsIn ++ [(MN 0 "runMain", maindef)]
+ -- iputStrLn $ showSep "\n" (map show defs)
+ let (nexttag, tagged) = addTags 0 (liftAll defs)
+ let ctxtIn = addAlist tagged emptyContext
+ let defuns = defunctionalise nexttag ctxtIn
+ -- iputStrLn $ showSep "\n" (map show (toAlist defuns))
+ let checked = checkDefs defuns (toAlist defuns)
+ case checked of
+ OK c -> case target of
+ ViaC -> liftIO $ codegenC c f True hdrs
+ (concatMap mkObj objs)
+ (concatMap mkLib libs) NONE
+ ViaJava -> liftIO $ codegenJava c f
+ Error e -> fail $ show e
where checkMVs = do i <- get
case idris_metavars i \\ primDefs of
[] -> return ()
View
4 src/Idris/AbsSyntaxTree.hs
@@ -114,6 +114,8 @@ type Idris = StateT IState (InputT IO)
-- Commands in the REPL
+data Target = ViaC | ViaJava
+
data Command = Quit
| Help
| Eval PTerm
@@ -121,7 +123,7 @@ data Command = Quit
| TotCheck Name
| Reload
| Edit
- | Compile String
+ | Compile Target String
| Execute
| ExecVal PTerm
| NewCompile String
View
4 src/Idris/Compiler.hs
@@ -24,8 +24,8 @@ import Epic.Epic hiding (Term, Type, Name, fn, compile)
import qualified Epic.Epic as E
-}
-compile :: FilePath -> Term -> Idris ()
-compile f t = fail "Epic backend disabled"
+compileEpic :: FilePath -> Term -> Idris ()
+compileEpic f t = fail "Epic backend disabled"
{-
compile f tm
View
10 src/Idris/REPL.hs
@@ -160,7 +160,7 @@ process fn (ExecVal t)
-- [pexp t])
(tmpn, tmph) <- liftIO tempfile
liftIO $ hClose tmph
- compileC tmpn tm
+ compile ViaC tmpn tm
liftIO $ system tmpn
return ()
where fc = FC "(input)" 0
@@ -294,7 +294,7 @@ process fn Execute = do (m, _) <- elabVal toplevel False
-- (PRef (FC "main" 0) (NS (UN "main") ["main"]))
(tmpn, tmph) <- liftIO tempfile
liftIO $ hClose tmph
- compileC tmpn m
+ compile ViaC tmpn m
liftIO $ system tmpn
return ()
where fc = FC "main" 0
@@ -302,13 +302,13 @@ process fn (NewCompile f)
= do (m, _) <- elabVal toplevel False
(PApp fc (PRef fc (UN "run__IO"))
[pexp $ PRef fc (NS (UN "main") ["main"])])
- compile f m
+ compileEpic f m
where fc = FC "main" 0
-process fn (Compile f)
+process fn (Compile target f)
= do (m, _) <- elabVal toplevel False
(PApp fc (PRef fc (UN "run__IO"))
[pexp $ PRef fc (NS (UN "main") ["main"])])
- compileC f m
+ compile target f m
where fc = FC "main" 0
process fn (LogLvl i) = setLogLevel i
process fn Metavars
View
3  src/Idris/REPLParser.hs
@@ -26,7 +26,8 @@ pCmd = try (do cmd ["q", "quit"]; eof; return Quit)
<|> try (do cmd ["e", "edit"]; eof; return Edit)
<|> try (do cmd ["exec", "execute"]; eof; return Execute)
<|> try (do cmd ["ttshell"]; eof; return TTShell)
- <|> try (do cmd ["c", "compile"]; f <- identifier; eof; return (Compile f))
+ <|> try (do cmd ["c", "compile"]; f <- identifier; eof; return (Compile ViaC f))
+ <|> try (do cmd ["jc", "newcompile"]; f <- identifier; eof; return (Compile ViaJava f))
<|> try (do cmd ["nc", "newcompile"]; f <- identifier; eof; return (NewCompile f))
<|> try (do cmd ["m", "metavars"]; eof; return Metavars)
<|> try (do cmd ["proofs"]; eof; return Proofs)
View
2  src/Main.hs
@@ -77,7 +77,7 @@ runIdris opts =
ok <- noErrors
when ok $ case output of
[] -> return ()
- (o:_) -> process "" (Compile o)
+ (o:_) -> process "" (Compile ViaC o)
when ok $ case newoutput of
[] -> return ()
(o:_) -> process "" (NewCompile o)
Please sign in to comment.
Something went wrong with that request. Please try again.