diff --git a/app/Gyehoek/ANF/Syntax.hs b/app/Gyehoek/ANF/Syntax.hs index 9b939d9..ca95842 100644 --- a/app/Gyehoek/ANF/Syntax.hs +++ b/app/Gyehoek/ANF/Syntax.hs @@ -11,6 +11,8 @@ module Gyehoek.ANF.Syntax ( Exp(..) , toANF , lower + , wrapFunction + , lowerProgram ) where @@ -29,13 +31,13 @@ import Gyehoek.Scheme.Syntax (Name, Prim(..), Lit(..)) import Gyehoek.GenSym import Control.Monad.Cont import Data.Foldable -import Data.List.NonEmpty (NonEmpty((:|)), toList) +import Data.List.NonEmpty (NonEmpty((:|))) import Data.List.NonEmpty qualified as NE import Gyehoek.QBE (FuncDef(FuncDef)) import Data.Foldable1 import qualified Data.Text as T import Data.String (fromString) -import Language.SexpGrammar as Sexp hiding (List, iso, encode, decode) +import Language.SexpGrammar as Sexp hiding (List, iso, encode, decode, traversed) import Language.SexpGrammar.Generic import GHC.Generics (Generic) import Gyehoek.Sexp @@ -414,6 +416,34 @@ lower' _ k = _ lower :: GenSym :> es => QBE.Ident QBE.Label -> Exp -> Eff es QBE.Block lower n e = buildBlock n <$> lower' e (pure . Exit . QBE.Ret . Just) +lowerProgram + :: (GenSym :> es, Traversable t) + => t Exp -> Eff es QBE.Program +lowerProgram anfs = + case toList anfs of + -- hack for dev convenience: if there's only one expression, let + -- it be the entry point. + [e] -> do + b <- lower "start" e + let f = wrapFunction @NonEmpty "main" [b] + pure $ QBE.Program [] [] [f] + _ -> do + let low e = do + bl <- gensym' "b" + fl <- gensym' "f" + b <- lower bl e + pure $ wrapFunction @NonEmpty fl [b] + fs <- traverse low anfs + pure $ QBE.Program [] [] (fs ^.. traversed) + +wrapFunction + :: Foldable1 t + => QBE.Ident 'QBE.Global -> t QBE.Block -> QBE.FuncDef +wrapFunction l bs = + QBE.FuncDef [QBE.Export] + (Just (QBE.AbiBaseTy QBE.Word)) + l Nothing [] QBE.NoVariadic (toNonEmpty bs) + wrapProgram :: Foldable1 t => t QBE.Block -> QBE.Program wrapProgram bs = prims <> QBE.Program [] [] [main] where main = QBE.FuncDef [QBE.Export] diff --git a/app/Gyehoek/GenSym.hs b/app/Gyehoek/GenSym.hs index 95add42..05ae094 100644 --- a/app/Gyehoek/GenSym.hs +++ b/app/Gyehoek/GenSym.hs @@ -9,26 +9,34 @@ import Effectful import Language.QBE as QBE import Data.String (IsString(fromString)) import Data.Text (Text) +import qualified Data.Text.Short as ST class Gen a where gen :: Natural -> a + gen' :: Text -> Natural -> a data GenSym :: Effect where GenSym :: Gen a => GenSym m a + GenSym' :: Gen a => Text -> GenSym m a type instance DispatchOf GenSym = Dynamic gensym :: forall a es. (Gen a, GenSym :> es) => Eff es a gensym = send GenSym +gensym' :: forall a es. (Gen a, GenSym :> es) => Text -> Eff es a +gensym' = send . GenSym' + runGenSym :: Eff (GenSym : es) a -> Eff es a -runGenSym = reinterpret (evalStateLocal (0 :: Natural)) \_ GenSym -> - state \n -> (gen n, succ n) - -- state \n -> (Ident . fromString $ '.' : show n, succ n) +runGenSym = reinterpret (evalStateLocal (0 :: Natural)) \cases + _ GenSym -> state \n -> (gen n, succ n) + _ (GenSym' s) -> state \n -> (gen' s n, succ n) instance Gen (QBE.Ident s) where gen = Ident . fromString . ('.':) . show + gen' s = Ident . (ST.fromText s <>) . fromString . show instance Gen Text where gen = fromString . ('x':) . show + gen' s = (s <>) . fromString . show diff --git a/app/Main.hs b/app/Main.hs index ab70208..25acb9c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} module Main (main) where @@ -19,7 +20,7 @@ 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) +import Gyehoek.GenSym (runGenSym, GenSym, gensym, gensym') import qualified Gyehoek.Sexp as Sexp import Data.Text.Lens import Data.List (List) @@ -29,6 +30,8 @@ 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 () @@ -41,6 +44,9 @@ main = do 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 @@ -62,11 +68,39 @@ toANF f exps = do 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 - hPutStr FS.stderr $ "wrote " <> T.pack anf_file + hPutStrLn FS.stderr $ "wrote " <> T.pack anf_file pure anfs -driver :: (GenSym :> es, FileSystem :> es) => Options -> Eff es () +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.StdoutTrimmed 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 + +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 pure () diff --git a/gyehoek.cabal b/gyehoek.cabal index b5c66f4..fbc5270 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -21,6 +21,7 @@ common ghcstuffs ghc-options: -Wall -fdefer-type-errors -fno-show-valid-hole-fits -fdefer-out-of-scope-variables -fplugin=Effectful.Plugin + -threaded default-extensions: BlockArguments @@ -65,6 +66,8 @@ executable gyehoek , text , unordered-containers , vector + , text-short + , cradle hs-source-dirs: app default-language: GHC2024 diff --git a/play/t.s b/play/t.s new file mode 100644 index 0000000..83a7477 --- /dev/null +++ b/play/t.s @@ -0,0 +1,14 @@ +.text +.globl main +main: + pushq %rbp + movq %rsp, %rbp + movl $18, %edi + callq scm_write + leave + ret +.type main, @function +.size main, .-main +/* end function main */ + +.section .note.GNU-stack,"",@progbits \ No newline at end of file diff --git a/play/t.ssa b/play/t.ssa new file mode 100644 index 0000000..8e05fd5 --- /dev/null +++ b/play/t.ssa @@ -0,0 +1,6 @@ +export +function w $main () { +@start + %x0 =l call $scm_write (l 18) + ret %x0 +} \ No newline at end of file