125 lines
3.7 KiB
Haskell
125 lines
3.7 KiB
Haskell
{-# LANGUAGE OverloadedLabels #-}
|
||
{-# LANGUAGE OverloadedLists #-}
|
||
{-# LANGUAGE ViewPatterns #-}
|
||
module Main
|
||
(main)
|
||
where
|
||
|
||
import qualified Gyehoek.ANF.Syntax as ANF
|
||
import Gyehoek.QBE (render)
|
||
import Gyehoek.Options
|
||
import qualified Data.Text.IO as TIO
|
||
import Data.Text (Text)
|
||
import Prelude hiding (readFile, (.),id)
|
||
import Control.Category
|
||
import Options.Applicative
|
||
import Control.Lens
|
||
import Data.Generics.Labels
|
||
import System.OsPath (OsPath)
|
||
import System.FilePath ((-<.>), dropExtension)
|
||
import Effectful.FileSystem
|
||
import Effectful
|
||
import Effectful.FileSystem.IO qualified as FS
|
||
import Effectful.FileSystem.IO.ByteString qualified as FB
|
||
import Gyehoek.GenSym (runGenSym, GenSym, gensym, gensym')
|
||
import qualified Gyehoek.Sexp as Sexp
|
||
import Data.Text.Lens
|
||
import Data.List (List)
|
||
import qualified Gyehoek.Scheme.Syntax as Scm
|
||
import Effectful.Exception
|
||
import qualified Gyehoek.QBE as QBE
|
||
import qualified Data.Text as T
|
||
import qualified Data.Text.Encoding as T
|
||
import System.IO (Handle)
|
||
import Data.List.NonEmpty (NonEmpty)
|
||
import qualified Cradle as C
|
||
|
||
|
||
main :: IO ()
|
||
main = do
|
||
opts <- execParser $ info (helper <*> parser) fullDesc
|
||
runEff . runFileSystem . runGenSym . driver $ opts
|
||
|
||
|
||
|
||
hPutStr :: FileSystem :> es => Handle -> Text -> Eff es ()
|
||
hPutStr h = FB.hPutStr h . T.encodeUtf8
|
||
|
||
hPutStrLn :: FileSystem :> es => Handle -> Text -> Eff es ()
|
||
hPutStrLn h = FB.hPutStrLn h . T.encodeUtf8
|
||
|
||
hGetContents :: FileSystem :> es => Handle -> Eff es Text
|
||
hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
|
||
|
||
readFile :: FileSystem :> es => FilePath -> Eff es Text
|
||
readFile f = FS.withFile f FS.ReadMode hGetContents
|
||
|
||
readScm :: FileSystem :> es => FilePath -> Eff es (List Scm.Exp)
|
||
readScm f = (Sexp.parseSexps f <$> readFile f) >>= either error pure
|
||
|
||
toANF
|
||
:: (GenSym :> es, FileSystem :> es)
|
||
=> FilePath -> List Scm.Exp -> Eff es (List ANF.Exp)
|
||
toANF f exps = do
|
||
anfs <- traverse ANF.toANF exps
|
||
case traverse Sexp.encode anfs of
|
||
Left e -> hPutStr FS.stderr (view packed e)
|
||
Right ss -> do
|
||
let anf_file = f -<.> "anf"
|
||
FS.withFile anf_file FS.WriteMode \h_anf -> do
|
||
hPutStr h_anf ";;; -*- mode:scheme -*-\n\n"
|
||
hPutStr h_anf $ foldr (\x y -> x <> "\n\n" <> y) "" ss
|
||
hPutStrLn FS.stderr $ "wrote " <> T.pack anf_file
|
||
pure anfs
|
||
|
||
toQBE
|
||
:: (GenSym :> es, FileSystem :> es, Traversable t)
|
||
=> FilePath -> t ANF.Exp -> Eff es QBE.Program
|
||
toQBE f anfs = do
|
||
p <- ANF.lowerProgram anfs
|
||
let qbe_file = f -<.> "ssa"
|
||
FS.withFile qbe_file FS.WriteMode \h -> do
|
||
hPutStr h . render $ p
|
||
hPutStrLn FS.stderr $ "wrote " <> T.pack qbe_file
|
||
pure p
|
||
|
||
callQBE
|
||
:: (GenSym :> es, FileSystem :> es, IOE :> es)
|
||
=> FilePath -> Eff es FilePath
|
||
callQBE f = do
|
||
let asm_file = f -<.> "s"
|
||
qbe_file = f -<.> "ssa"
|
||
C.StdoutUntrimmed stdout <-
|
||
C.run $ C.cmd "qbe" & C.addArgs [qbe_file]
|
||
FS.withFile asm_file FS.WriteMode \h -> do
|
||
hPutStr h stdout
|
||
hPutStrLn FS.stderr $ "wrote " <> T.pack asm_file
|
||
pure asm_file
|
||
|
||
callGCC
|
||
:: (GenSym :> es, FileSystem :> es, IOE :> es)
|
||
=> FilePath -> List String -> Eff es FilePath
|
||
callGCC f args = do
|
||
let asm_file = f -<.> "s"
|
||
exe = f -<.> "out"
|
||
C.StdoutTrimmed (T.words -> flags) <-
|
||
C.run $ C.cmd "pkg-config"
|
||
& C.addArgs @String ["--cflags", "--libs", "bdw-gc"]
|
||
C.run_ $ C.cmd "cc"
|
||
& C.addArgs flags
|
||
& C.addArgs ["-o", exe, asm_file]
|
||
& C.addArgs args
|
||
hPutStrLn FS.stderr $ "wrote " <> T.pack exe
|
||
pure exe
|
||
|
||
driver
|
||
:: (GenSym :> es, FileSystem :> es, IOE :> es)
|
||
=> Options -> Eff es ()
|
||
driver = runGenSym . traverseOf_ (#sourceFiles . folded) \f -> do
|
||
exps <- readScm f
|
||
anfs <- toANF f exps
|
||
qbe <- toQBE f anfs
|
||
callQBE f
|
||
callGCC f ["../runtime/target/debug/libgyehoek.a"]
|
||
pure ()
|