runsol executable

flake.nix

@@ -48,6 +48,8 @@
              hspkgs.hevm
              texlive
              (pkgs.callPackage ./nix/goevmlab.nix { src = inputs.goevmlab; })
+             pkgs.cmake
+             pkgs.boost
            ];
          };
       }

sol-core.cabal

@@ -104,6 +104,12 @@ library
       Language.Yul
       Language.Yul.Parser
       Language.Yul.QuasiQuote
+      Yule.Translate
+      Yule.TM
+      Yule.Compress
+      Yule.Builtins
+      Yule.Locus
+      Yule.Options
       Common.LightYear
       Common.Monad
       Common.Pretty
@@ -132,7 +138,6 @@ executable yule
       PatternSynonyms
       BlockArguments
       ImportQualifiedPost
-    other-modules: Locus, Options, TM, Translate, Builtins, Compress
     build-depends:    base ^>=4.19.1.0,
                       pretty >=  1.1,
                       containers >= 0.6,
@@ -142,6 +147,22 @@ executable yule
                       optparse-applicative >= 0.18,
                       sol-core
 
+executable runsol
+  import: common-opts
+  main-is: RunSol.hs
+  hs-source-dirs: app
+  build-depends:
+    sol-core,
+    process,
+    aeson,
+    temporary,
+    bytestring,
+    text
+  build-tool-depends: alex:alex, happy:happy
+  ghc-options: -O1
+  default-extensions:
+    LambdaCase
+
 test-suite sol-core-tests
   import: common-opts
   type: exitcode-stdio-1.0

src/Yule/Builtins.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Yule.Builtins(yulBuiltins, revertStmt) where
+import Data.String
+import Language.Yul
+
+yulBuiltins :: [YulStmt]
+yulBuiltins = []
+
+revertStmt :: String -> [YulStmt]
+revertStmt s =  [ YExp $ YCall "mstore" [yulInt 0, YLit (YulString s)]
+                , YExp $ YCall "revert" [yulInt 0, yulIntegral (length s)]
+                ]
+
+{-
+poisonBuiltin :: [YulStmt]
+poisonBuiltin =
+    [ YFun "$poison" [] (YReturns ["_dummy"]) (revertStmt "Dying from poison!") ]
+-}

src/Yule/Compress.hs

@@ -0,0 +1,98 @@
+module Yule.Compress where
+import Language.Core
+
+class Compress a where
+    compress :: a -> a
+
+instance Compress Type where
+    compress (TNamed n t@(TSum _ _)) = foldSum t
+    compress t = t
+
+foldSum :: Type -> Type
+foldSum t = TSumN (go t) where
+    go :: Type -> [Type]
+    go (TSum t1 t2) = go t1 ++ go t2
+    go t = [t]
+
+-- foldIns :: Type -> Expr -> Expr
+-- treat expressions of the form:
+--  - inl(inr*(e))  e.g. inl<T0+T1+T2>(inr(e)) becomes in(1)<T0+T1+T2>(e)
+--                       inl<T0+T1+T2>(e) becomes in(0)<T0+T1+T2>(e)
+--  - inr+(e)       e.g. inr<T0+T1+T2>(inr(e)) becomes in(2)<T0+T1+T2>(e)
+-- Note: for complex types, such as Option{(unit + Option{(unit + word)})}
+--       inr(inr(x)) becomes in1(in1(x)) rather than in2(x)
+compressInjections ty@(TSumN ts) e = go 0 e where
+    arity = length ts
+    go k e | k == arity-1 = EInK k ty (compress e)
+    go k (EInr _ e) = go (k+1) e
+    go k (EInl _ e) = EInK k ty e
+    -- go k e = EInK k ty (compress e)
+
+{- Compress match statements
+    match e<sum(t1, t2)> with {
+        inl(x) => s1
+        inr(y) => s2 }
+    becomes
+    match e with {
+        in1(x) => s1
+        in2(x) => s2 }
+    even if s2 is a match statement
+
+    match e<sum(t1, t2, t3)> with {
+        inl(x) => s1
+        inr(y) => match y with {
+        }
+    }
+
+    To do this we need to know the scrutinee type
+-}
+compressMatch :: Type -> Stmt -> Stmt
+compressMatch (TSumN ts) top@(SMatch ty e0 _alts) = SMatch ty' e' (go 0 top) where
+    ty' = compress ty
+    e' = compress e0
+    arity = length ts
+    alt = ConAlt
+    go k (SMatch (TNamed _n nty) e alts) = go k (SMatch nty e alts)
+    go k (SMatch TSum{} _e [ConAlt CInl ln left, ConAlt CInr rn right])
+       -- last two alternatives in the chain
+       | k == arity-2 = [alt (CInK k )ln left', alt (CInK (k+1)) rn right']
+       -- not reached the end of the chain yet
+       | otherwise = firstAlt:rest
+       where
+        left' = compress left
+        right' = compress right
+        firstAlt = alt (CInK k) ln left'
+        rest = go (k+1) (SBlock right)
+    go k (SBlock [s]) = go k s
+    go k s = error $ concat["compressMatch unimplemented for k=",show k," stmt: ", show s]
+compressMatch TWord top = top
+compressMatch cty top = error $ concat["compressMatch unimplemented for cty=",show cty," stmt: ", show top]
+
+instance Compress Contract where
+    compress c = c { ccStmts = map compress (ccStmts c) }
+
+instance Compress a => Compress [a] where
+    compress = map compress
+
+instance Compress Stmt where
+    compress (SFunction n args t stmts) = SFunction n
+                                            (compress args)
+                                            (compress t)
+                                            (map compress stmts)
+    compress (SReturn e) = SReturn (compress e)
+    compress (SMatch t e alts) = compressMatch (compress t) (SMatch t e alts)
+    compress s = s
+
+instance Compress Arg where
+    compress (TArg n t) = TArg n (compress t)
+
+instance Compress Expr where
+    compress e@(EInl ty _) = compressInjections (compress ty) e
+    compress e@(EInr ty _) = compressInjections (compress ty) e
+    compress (ECall n es) = ECall n (compress es)
+    compress e = e
+
+instance Compress Object where
+    compress (Object name code inners) = Object name code' inners' where
+      code' = compress code
+      inners' = compress inners

src/Yule/Locus.hs

@@ -0,0 +1,24 @@
+module Yule.Locus where
+import Data.String
+{-
+Location tree with addresses a:
+- location for Int is a single cell
+- location for pair is a pair of locations for components
+- location for sum is a location for tag and locations for payload
+-}
+data LocTree a
+    = LocWord Integer -- int literal
+    | LocBool Bool    -- bool literal
+    | LocStack a      -- stack location
+    | LocNamed String -- named location (e.g. argument/result)
+    | LocSeq [LocTree a] -- sequence of locations
+    | LocEmpty Int    -- empty location of given size
+    deriving (Eq, Show)
+
+pattern LocPair a b = LocSeq [a, b]
+pattern LocUnit = LocSeq []
+
+type Location = LocTree Int
+
+stkLoc :: IsString name => Int -> name
+stkLoc i = fromString("_v" ++ show i)

src/Yule/Options.hs

@@ -0,0 +1,68 @@
+module Yule.Options where
+
+import Options.Applicative
+
+data Options = Options
+    { input :: FilePath
+    , contract :: String
+    , output :: FilePath
+    , verbose :: Bool
+    , debug :: Bool
+    , compress :: Bool
+    , wrap :: Bool
+    , runOnce :: Bool
+    } deriving Show
+
+optionsParser :: Parser Options
+optionsParser = Options
+    <$> argument str
+        ( metavar "FILE"
+        <> help "Input file" )
+    <*> strOption
+        ( long "contract"
+        <> short 'c'
+        <> metavar "NAME"
+        <> help "Contract name"
+        <> value "Output"
+        <> showDefault
+        )
+    <*> strOption
+        ( long "output"
+        <> short 'o'
+        <> metavar "FILE"
+        <> help "Output file"
+        <> value "Output.sol"
+        <> showDefault
+        )
+    <*> switch
+        ( long "verbose"
+        <> short 'v'
+        <> help "Verbosity level"
+        )
+    <*> switch
+        ( long "debug"
+        <> short 'd'
+        <> help "Diagnostic output"
+        )
+    <*> switch
+        ( long "compress"
+        <> short 'O'
+        <> help "Compress sums (experimental)"
+        )
+    <*> switch
+        ( long "wrap"
+        <> short 'w'
+        <> help "Wrap Yul in a Solidity contract"
+        )
+    <*> switch
+        ( long "nodeploy"
+        <> help "Output code to be run once, without the deployment code"
+        )
+
+parseOptions :: IO Options
+parseOptions = execParser opts
+  where
+    opts = info (optionsParser <**> helper)
+      ( fullDesc
+     <> progDesc "Compile a Core program to Yul"
+     <> header "yule - experiments with Yul codegen" )