app/Gyehoek/ANF/Syntax.hs

@@ -7,7 +7,7 @@
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# OPTIONS_GHC -Wno-orphans -Wno-unused-matches -Wno-missing-signatures #-}
 {- HLINT ignore "Avoid lambda using `infix`" -}
-module Gyehoek.ANF
+module Gyehoek.ANF.Syntax
   (toANF, lower)
   where
 
@@ -21,8 +21,8 @@ import Data.Generics.Labels
 import Data.Vector.Strict (Vector)
 import Data.Function (fix)
 import Effectful.Writer.Static.Local
-import Gyehoek.Syntax qualified as Lam
-import Gyehoek.Syntax (Name, Prim(..), Lit(..))
+import Gyehoek.Scheme.Syntax qualified as Lam
+import Gyehoek.Scheme.Syntax (Name, Prim(..), Lit(..))
 import Gyehoek.GenSym
 import Control.Monad.Cont
 import Data.Foldable
@@ -185,7 +185,12 @@ expr2 =
          (PrimCons
           (Lam.ExpLit (LitInt 2))
           (Lam.ExpLit (LitInt 3)))))
-    , Lam.ExpPrim (PrimWrite (Lam.ExpLit (LitInt 4)))
+    , Lam.ExpPrim
+      (PrimWrite
+       (Lam.ExpPrim
+        (PrimMul
+         (Lam.ExpLit (LitInt 5))
+         (Lam.ExpLit (LitInt 4)))))
     ]
 
 
@@ -364,9 +369,14 @@ lowerPrim r p e k =
   telescope (lowerVal <$> p) \case
     (preview binaryPrim -> Just (bop,a,b)) -> do
       r1 <- gensym
+      r2 <- gensym
       Emit [ QBE.BinaryOp (r1 QBE.:= QBE.Long) bop a b
-           , QBE.BinaryOp (lowerName r QBE.:= QBE.Long) QBE.And
-             (QBE.ValTemporary r1) (QBE.ValConst (QBE.CInt 0b10))
+           , QBE.BinaryOp (r2 QBE.:= QBE.Long) QBE.And
+             (QBE.ValTemporary r1)
+             (QBE.ValConst (QBE.CInt 0xffff_ffff_ffff_fffd))
+           , QBE.BinaryOp (lowerName r QBE.:= QBE.Long) QBE.Or
+             (QBE.ValTemporary r2)
+             (QBE.ValConst (QBE.CInt 0b10))
            ]
         <$> lower' e k
     PrimCons x y -> lowerCons r x y e k

app/Gyehoek/Options.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE NoFieldSelectors #-}
+module Gyehoek.Options
+  ( Options(..)
+  , parser
+  )
+  where
+
+import System.IO (Handle)
+import Data.HashSet (HashSet)
+import Options.Applicative
+import System.FilePath
+import qualified Data.HashSet as HS
+import Control.Lens hiding (argument)
+import GHC.Generics (Generic)
+
+
+data Options = MkOptions
+  { -- dumpANF :: Maybe FilePath
+  -- , dumpQBE :: Maybe FilePath
+  output :: Maybe FilePath
+  , sourceFiles :: HashSet FilePath
+  }
+  deriving (Show, Generic)
+
+-- osPath :: ReadM _
+-- osPath = eitherReader $
+--   (_Left %~ show) . encodeUtf @(Either _)
+
+-- parseDumpQBE =
+--   optional $ strOption
+--     ( long "dump-qbe"
+--     <> metavar "FILE"
+--     )
+
+-- parseDumpANF =
+--   optional $ strOption
+--     ( long "dump-anf"
+--     <> metavar "FILE"
+--     )
+
+parseOutput =
+  optional $ strOption
+    ( long "output"
+    <> short 'o'
+    <> metavar "FILE"
+    )
+
+parser :: Parser Options
+parser = MkOptions
+  <$> parseOutput
+  <*> (HS.fromList <$> some (argument str (metavar "FILES")))

app/Gyehoek/Scheme/Syntax.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE PartialTypeSignatures #-}
-module Gyehoek.Syntax where
+module Gyehoek.Scheme.Syntax where
 
 import Data.Text (Text)
 import Data.List (List)
@@ -40,10 +40,17 @@ data Lit
   | LitBool Bool
   deriving (Show, Generic)
 
+data Define
+  = DefineConstant Name Exp
+  | DefineProcedure Name (List Name) (List Exp)
+  deriving (Show, Generic)
+
 data Exp
   = ExpLet (NonEmpty (Name, Exp)) Exp
   | ExpPrim (Prim Exp)
   | ExpBegin (List Exp)
+  | ExpDefine Define
+  | ExpIf Exp Exp Exp
   | ExpLit Lit
   | ExpApply Exp (List Exp)
   | ExpLambda (List Name) Exp
@@ -78,17 +85,30 @@ instance SexpIso Lit where
     $ With (. sexpIso)
     $ End
 
+instance SexpIso Define where
+  sexpIso = match
+    $ With (. defconst)
+    $ With (. defun)
+    $ End
+    where
+      defconst = list $ el (sym "define") >>> el symbol >>> el sexpIso
+      defun = list $ el (sym "define") >>> el args >>> rest sexpIso
+      args = list $ el symbol >>> rest symbol
+  
 instance SexpIso Exp where
   sexpIso = match
     $ With (. Gyehoek.Sexp.let_ symbol sexpIso sexpIso)
     $ With (. sexpIso)
     $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
     $ With (. sexpIso)
+    $ With (. if_)
+    $ With (. sexpIso)
     $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
     $ With (. lam)
     $ With (. symbol)
     $ End
     where
+      if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
       lam = list
         ( el (sym "lambda")
           >>> el (sexpIso @(List Name))

app/Gyehoek/Scratch.hs

@@ -1 +0,0 @@
-module Gyehoek.Scratch where

app/Gyehoek/Sexp.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLabels #-}
 module Gyehoek.Sexp
   ( let_
   , sexp
@@ -8,12 +9,14 @@ module Gyehoek.Sexp
   , nonEmptyGrammar
   , encode
   , decode
+  , parseSexps
   )
 where
 
 import Data.Text (Text)
 import Language.SexpGrammar as Sexp hiding (List, encode, decode, iso)
 import Language.SexpGrammar qualified as Sexp
+import Language.Sexp qualified as S
 import Language.SexpGrammar.Generic
 import Data.InvertibleGrammar.Base qualified as IGB
 import Data.InvertibleGrammar qualified as IG
@@ -24,6 +27,12 @@ import Data.Text.Encoding
 import Data.Either (either)
 import GHC.Generics (Generic)
 import Control.Lens
+import Data.Generics.Labels
+import System.Process
+import GHC.IO.Unsafe (unsafePerformIO)
+import qualified Data.Text.IO as TIO
+import Control.Monad (join)
+import qualified Language.Sexp.Located as SexpLoc
 
 
 sexp :: SexpIso a => Iso' a Text
@@ -37,6 +46,10 @@ encode = (_Right %~ decodeUtf8 . view strict) . Sexp.encode
 decode :: SexpIso a => Text -> Either String a
 decode = Sexp.decode . view lazy . encodeUtf8
 
+parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
+parseSexps f = marshal . SexpLoc.parseSexps f . view lazy . encodeUtf8
+  where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso)
+
 nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
 nonEmptyGrammar = IGB.Iso
   (\((x:|xs) :- t) -> xs :- x :- t)

app/Main.hs

@@ -1,17 +1,54 @@
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedLabels #-}
 module Main
   (main)
   where
 
-import qualified Gyehoek.ANF as ANF
+import qualified Gyehoek.ANF.Syntax as ANF
 import Gyehoek.QBE (render)
+import Gyehoek.Options
 import qualified Data.Text.IO as TIO
-import Prelude hiding ((.),id)
+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 ((-<.>))
+import Effectful.FileSystem
+import Effectful
+import Effectful.FileSystem.IO
+import Gyehoek.GenSym (runGenSym)
+import qualified Gyehoek.Sexp as Sexp
+import Data.Text.Lens
+import Data.List (List)
+import qualified Gyehoek.Scheme.Syntax as Scm
+import Effectful.Exception
 
 
 main :: IO ()
-main = TIO.putStrLn . render $ ANF.expr
+main = do
+  opts <- info (helper <*> parser) (fullDesc)
+  runEff . runFileSystem . driver $ opts
+
+
+
+hPutStr :: IOE :> es => Handle -> Text -> Eff es ()
+hPutStr h = liftIO . TIO.hPutStr h
+
+readFile :: IOE :> es => FilePath -> Eff es Text
+readFile = liftIO . TIO.readFile
+
+readScm :: FileSystem :> es => FilePath -> Eff es (List Scm.Exp)
+readScm f = (Sexp.parseSexps f <$> readFile f) >>= either error pure
+
+driver :: FileSystem :> es => Options -> Eff es ()
+driver = runGenSym . traverseOf_ (#sourceFiles . folded) \f ->
+  withFile f ReadMode \h_scm ->
+    (Sexp.encode <$> ANF.toANF _) >>= \case
+      Left e -> hPutStr stderr (view packed e)
+      Right s ->
+        withFile (f -<.> "anf") WriteMode \h_anf -> do
+          hPutStr h_anf ";;; -*- mode:scheme -*-\n\n"
+          hPutStr h_anf s
+

gyehoek.cabal

@@ -13,48 +13,58 @@ build-type:    Simple
 -- extra-doc-files:    CHANGELOG.md
 -- extra-source-files:
 
+common ghcstuffs-dev
+  ghc-options:
+    -Wno-unused-matches -Wno-missing-signatures -Wno-typed-holes
+
 common ghcstuffs
   ghc-options:
     -Wall -fdefer-type-errors -fno-show-valid-hole-fits
-    -fdefer-out-of-scope-variables -Wno-typed-holes
-    -fplugin=Effectful.Plugin
+    -fdefer-out-of-scope-variables -fplugin=Effectful.Plugin
 
-  other-extensions:
+  default-extensions:
     BlockArguments
+    DeriveGeneric
+    OverloadedStrings
     PartialTypeSignatures
+    PatternSynonyms
 
 executable gyehoek
-  import:           ghcstuffs
+  import:           ghcstuffs, ghcstuffs-dev
   main-is:          Main.hs
 
   -- cabal-fmt: expand app -Main
   other-modules:
-    Gyehoek.ANF
-    Gyehoek.Sexp
+    Gyehoek.ANF.Syntax
     Gyehoek.GenSym
+    Gyehoek.Options
     Gyehoek.QBE
     Gyehoek.QBE.Parse
-    Gyehoek.Scratch
-    Gyehoek.Syntax
+    Gyehoek.Scheme.Syntax
+    Gyehoek.Sexp
 
-  -- other-extensions:
   build-depends:
-    , base               ^>=4.21.2.0
+    , base                  ^>=4.21.2.0
+    , containers
     , effectful
     , effectful-core
     , effectful-plugin
+    , filepath
+    , generic-lens
+    , invertible-grammar
     , lens
     , megaparsec
     , mtl
+    , optparse-applicative
     , prettyprinter
+    , process
     , qbe
     , recursion-schemes
+    , sexp-grammar
     , template-haskell
     , text
+    , unordered-containers
     , vector
-    , generic-lens
-    , sexp-grammar
-    , invertible-grammar
 
   hs-source-dirs:   app
   default-language: GHC2024

play/t.ssa

@@ -1,12 +0,0 @@
-type :scm = {l 2}
-export
-function w $main () {
-@start
-    %x0 =l call $GC_malloc (l 16)
-    %.3 =l add %x0, 8
-    storel 10, %x0
-    storel 14, %.3
-    %x1 =l call $scm_write (l %x0)
-    %x2 =l call $scm_write (l 18)
-    ret %x2
-}

runtime/gyehoek.c

@@ -3,9 +3,9 @@
 
 SCM scm_write (SCM x) {
   if (SCM_IMP (x)) {
-    printf ("#<immediate %ld>\n", SCM_UNPACK (x));
+    printf ("#<immediate %ld>\n", SCM_UNPACK (x) >> 2);
   } else {
-    printf ("#<heap object %ld>\n", SCM_UNPACK(x));
+    printf ("#<heap object %lx>\n", SCM_UNPACK(x));
   }
   return SCM_PACK(NULL);
 }