callQBE

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]

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 ->
+runGenSym = reinterpret (evalStateLocal (0 :: Natural)) \cases
-  state \n -> (gen n, succ n)
+  _ GenSym -> state \n -> (gen n, succ n)
-  -- state \n -> (Ident . fromString $ '.' : show 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

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 ()

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

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

play/t.ssa

@@ -0,0 +1,6 @@
+export
+function w $main () {
+@start
+    %x0 =l call $scm_write (l 18)
+    ret %x0
+}