Merge pull request #210 from argotorg/mbenke/sail-objects

Sail objects

Author: d-xo

src/Language/Core.hs

@@ -2,7 +2,7 @@
 {-# OPTIONS_GHC -Wincomplete-patterns #-}
 {-# LANGUAGE InstanceSigs #-}
 module Language.Core
-  ( Expr(..), Stmt(..), Arg(..), Alt(..), pattern ConAlt, Pat(..), Con(..), Contract(..), Core(..), Body
+  ( Expr(..), Stmt(..), Arg(..), Alt(..), pattern ConAlt, Pat(..), Con(..), Contract(..), Object(..), Body
   , module Language.Core.Types
   ,  pattern SAV
   , Name
@@ -13,6 +13,8 @@ import Language.Core.Types
 import Language.Yul
 
 
+data Object = Object { objName :: Name, objCode :: Body, objInners :: [Object] }
+type Body = [Stmt]
 type Name = String
 
 data Expr
@@ -47,7 +49,6 @@ data Stmt
     | SRevert String
     -- deriving Show
 
-type Body = [Stmt]
 data Arg = TArg Name Type
 instance Show Arg where show = render . ppr
 instance Show Stmt where show :: Stmt -> String
@@ -67,6 +68,19 @@ newtype Core = Core [Stmt]
 instance Show Core where show = render . ppr
 instance Show Contract where show = render . ppr
 
+
+instance Pretty Object where
+  ppr (Object name code inners) = vcat
+    [ text "object" <+> ppr name <+> lbrace
+    , nest 2 $ vcat
+      [ text "code" <+> lbrace
+      , nest 2 $ ppr code
+      , rbrace
+      ]
+    , nvlist inners
+    , rbrace
+    ]
+
 instance Pretty Contract where
     ppr (Contract n stmts) = text "contract" <+> text n <+> lbrace $$ nest 4 (vcat (map ppr stmts)) $$ rbrace
 
@@ -139,6 +153,8 @@ instance Pretty Arg where
 instance Pretty Core where
     ppr (Core stmts) = vcat (map ppr stmts)
 
+pprBody :: Body -> Doc
+pprBody stmts = braces $ nest 2 (vcat (map ppr stmts))
 
 instance Pretty [Stmt] where
     ppr stmts = vcat (map ppr stmts)

src/Language/Core/Parser.hs

@@ -1,6 +1,7 @@
 module Language.Core.Parser where
 import Language.Core
-    ( Core(..), Contract(..), Body,
+    ( Object(..),
+      Body,
       Alt(..),
       Pat(..),
       Arg(..),
@@ -14,11 +15,9 @@ import Text.Megaparsec.Char.Lexer qualified as L
 import Control.Monad.Combinators.Expr
 import Language.Yul.Parser(yulBlock)
 
-parseCore :: String -> Core
-parseCore = runMyParser "core" coreProgram
 
-parseContract :: String -> String -> Contract
-parseContract filename = runMyParser filename coreContract
+parseObject :: String -> String -> Object
+parseObject filename = runMyParser filename coreObject
 
 -- Note: this module repeats some definitions from YulParser.Name
 -- This is intentional as we may want to make different syntax choices
@@ -158,9 +157,9 @@ corePat = choice
     , PWildcard <$ pKeyword "_"
     ]
 
-coreProgram :: Parser Core
-coreProgram = sc *> (Core <$> many coreStmt) <* eof
+coreObject :: Parser Object
+coreObject = sc *> (Object <$> (pKeyword "object" *> identifier  <* symbol "{")
+               <*> coreCode <*> many coreObject) <* symbol "}"
 
-coreContract :: Parser Contract
-coreContract = sc *> (Contract <$> (pKeyword "contract" *> identifier )
-                  <*> braces (many coreStmt)) <* eof
+coreCode :: Parser Body
+coreCode = sc *> (Object <$> pKeyword "code" *> coreBody)

src/Language/Yul.hs

@@ -70,17 +70,22 @@ data YLiteral
   | YulFalse
   deriving (Eq, Ord, Data, Typeable)
 
-yulInt :: Integral i => i -> YulExp
-yulInt = YLit . YulNumber . fromIntegral
+yulIntegral :: Integral i => i -> YulExp
+yulIntegral = YLit . YulNumber . fromIntegral
+
+yulInt :: Integer -> YulExp
+yulInt = YLit . YulNumber
 
 yulBool :: Bool -> YulExp
 yulBool True = YLit YulTrue
 yulBool False = YLit YulFalse
 
+yulString :: String -> YulExp
+yulString = YLit . YulString
 
 -- auxilliary functions
 
-hlist, vlist, nvlist :: Pretty a => [a] -> Doc
+hlist, vlist, nvlist, pprBlock :: Pretty a => [a] -> Doc
 hlist = hsep . map ppr
 vlist = vcat . map ppr
 nvlist = nest 2 . vlist

src/Solcore/Desugarer/EmitCore.hs

@@ -21,7 +21,7 @@ import Solcore.Primitives.Primitives
 import Solcore.Desugarer.Specialise(typeOfTcExp)
 import System.Exit
 
-emitCore :: Bool -> TcEnv ->  CompUnit Id -> IO [Core.Contract]
+emitCore :: Bool -> TcEnv ->  CompUnit Id -> IO [Core.Object]
 emitCore debugp env cu = fmap concat $ runEM debugp env $ mapM emitTopDecl (contracts cu)
 
 type EM a = StateT EcState IO a
@@ -103,7 +103,7 @@ type Translation a = EM (a, [Core.Stmt])
 
 type CoreName = String
 
-emitTopDecl :: TopDecl Id -> EM [Core.Contract]
+emitTopDecl :: TopDecl Id -> EM [Core.Object]
 emitTopDecl (TContr c) = fmap pure (emitContract c)
 emitTopDecl (TDataDef dt) = addData dt >> pure []
 emitTopDecl _ = pure []
@@ -116,14 +116,12 @@ buildTConInfo :: DataTy -> TConInfo
 buildTConInfo (DataTy n tvs dcs) = (tvs, map conInfo dcs) where
   conInfo (Constr n ts) = (n, ts)
 -}
-emitContract :: Contract Id -> EM Core.Contract
+emitContract :: Contract Id -> EM Core.Object
 emitContract c = do
     let cname = show (name c)
     writes ["Emitting core for contract ", cname]
     coreBody <- concatMapM emitCDecl (decls c)
-    let result = Core.Contract cname coreBody
-    -- writeln (show result)
-    pure result
+    pure(Core.Object cname coreBody [])
 
 emitCDecl :: ContractDecl Id -> EM [Core.Stmt]
 emitCDecl cd@(CFunDecl f) = do

src/Solcore/Pipeline/SolcorePipeline.hs

@@ -47,7 +47,7 @@ pipeline = do
         writeFile filename (show c)
 
 -- Version that returns Either for testing
-compile :: Option -> IO (Either String [Core.Contract])
+compile :: Option -> IO (Either String [Core.Object])
 compile opts = runExceptT $ do
   let verbose = optVerbose opts
       noDesugarCalls = optNoDesugarCalls opts

testsol.sh

@@ -5,31 +5,22 @@ function esolc() {
     cabal exec sol-core -- -f $file $*
 }
 
-function testsol() {
+
+function runsol() {
     file=$1
     echo $file
     shift
     rm -f -v output1.core Output.sol
     /usr/bin/time -f "Compilation time: %E" cabal run sol-core -- -f $file $* && \
-	cabal exec yule -- output1.core -w -O > /dev/null && \
+	cabal exec yule -- output1.core -w -O --nodeploy > /dev/null && \
         forge script --via-ir Output.sol | egrep '(Gas|RESULT)'
 }
 
-function testspec() {
-    file=$1
-    echo $file
-    shift
-    rm -f -v output1.core
-    cabal exec sol-core -- -f $file --debug-spec --dump-spec $*
-#    cabal run yule -- output1.core -O && \
-#    forge script Output.sol
-}
-
 
-function testcore() {
+function runcore() {
     echo $1
     rm -f -v Output.sol
-    cabal exec yule -- $1 -w -O && forge script --via-ir Output.sol | egrep '(Gas|RESULT)'
+    cabal exec yule -- $1 -w --nodeploy -O && forge script --via-ir Output.sol | egrep '(Gas|RESULT)'
 }
 
 function hevmcore() {
@@ -38,9 +29,9 @@ function hevmcore() {
      echo $yulfile
      local hexfile=$base.hex
      rm -f -v $yulfile $hexfile
-     cabal exec yule -- $1 -o $yulfile
-     solc --strict-assembly --bin --optimize $yulfile | tail -1 > $hexfile
-     hevm exec --code $(cat $hexfile) | awk -f parse_hevm_output.awk
+     cabal exec yule -- $1 --nodeploy -o $yulfile
+     solc --strict-assembly --bin --optimize --optimize-yul $yulfile | tail -1 > $hexfile
+     hevm exec --code-file $hexfile | awk -f parse_hevm_output.awk
 }
 
 function hevmsol() {
@@ -53,8 +44,46 @@ function hevmsol() {
     echo Hex: $hexfile
     shift
     cabal exec sol-core -- -f $file $* && \
-	cabal exec yule -- $core -O -o $yulfile && \
+	cabal exec yule -- $core --nodeploy -O -o $yulfile && \
         solc --strict-assembly --bin --optimize $yulfile | tail -1 > $hexfile && \
-        hevm exec --code $(cat $hexfile) | awk -f parse_hevm_output.awk
+        hevm exec --code-file $hexfile | awk -f parse_hevm_output.awk
+
+}
+
+function deploysol() {
+    file=$1
+    shift
+    echo "Solc: $file"
+    local base=$(basename $1 .solc)
+    local core=output1.core
+    echo "Sail: $core"
+    local yulfile=$base.yul
+    echo "Yul:  $yulfile"
+    rm -f -v $yulfile
+    cabal exec sol-core -- -f $file $* && \
+    cabal exec yule -- $core -o $yulfile  
+    hex=$(solc --strict-assembly --bin --optimize --optimize-yul $yulfile | tail -1)
+    rawtx=$(cast mktx --private-key=$PRIVATE_KEY --create $hex)
+    addr=$(cast publish $rawtx | jq .contractAddress)
+    echo $addr
+}
+
+function deploycore() {
+     local base=$(basename $1 .core)
+     local yulfile=$base.yul
+     echo $yulfile
+     local hexfile=$base.hex
+     rm -f -v $yulfile $hexfile
+     cabal exec yule -- $1 -o $yulfile
+     hex=$(solc --strict-assembly --bin --optimize --optimize-yul $yulfile | tail -1)
+     rawtx=$(cast mktx --private-key=$PRIVATE_KEY --create $hex)
+     addr=$(cast publish $rawtx | jq .contractAddress)
+     echo $addr
+}
 
+function sail() {
+     local base=$(basename $1 .core)
+     local yulfile=$base.yul
+     rm -f -v $yulfile
+     cabal exec yule -- $1 -o $yulfile
 }

yule/Builtins.hs

@@ -1,14 +1,14 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Builtins(yulBuiltins) where
+module Builtins(yulBuiltins, revertStmt) where
 import Data.String
 import Language.Yul
 
-yulBuiltins :: Yul
-yulBuiltins = Yul []
+yulBuiltins :: [YulStmt]
+yulBuiltins = []
 
 revertStmt :: String -> [YulStmt]
 revertStmt s =  [ YExp $ YCall "mstore" [yulInt 0, YLit (YulString s)]
-                , YExp $ YCall "revert" [yulInt 0, yulInt (length s)]
+                , YExp $ YCall "revert" [yulInt 0, yulIntegral (length s)]
                 ]
 
 {-

yule/Main.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main where
-import Language.Core(Contract(..))
-import Language.Core.Parser(parseContract)
+import Language.Core(Object(..))
+import Language.Core.Parser(parseObject)
 import Solcore.Frontend.Syntax.Name  -- FIXME: move Name to Common
 import Common.Pretty -- (Doc, Pretty(..), nest, render)
 import Builtins(yulBuiltins)
@@ -21,54 +21,62 @@ main = do
     -- print options
     let filename = Options.input options
     src <- readFile filename
-    let coreContract = parseContract filename src
-    let core = ccStmts coreContract
-    when (Options.verbose options) $ do
-        putStrLn "/* Core:"
-        putStrLn (render (nest 2 (ppr coreContract)))
-        putStrLn "*/"
+    let (Object name code inners) = parseObject filename src
     let oCompress = Options.compress options
-    let source = if oCompress then compress core else core
     when oCompress $ do
         putStrLn "Compressing sums"
+    let source = if oCompress then compress code else code
     generatedYul <- runTM options (translateStmts source)
-    let name = fromString (ccName coreContract)
-
+    let withDeployment = not (Options.runOnce options)
     let doc = if Options.wrap options
-        then wrapInSol name generatedYul
-        else wrapInObject name generatedYul
+        then wrapInSol (Name name) generatedYul
+        else wrapInObject (Name name) withDeployment generatedYul
     putStrLn ("writing output to " ++ Options.output options)
     writeFile (Options.output options) (render doc)
 
 -- wrap in a Yul object with the given name
-wrapInObject :: Name -> Yul -> Doc
-wrapInObject name yul = ppr object where
-    object = YulObject (show name) (YulCode stmts) []
-    stmts = yulStmts yul ++ retcode
+wrapInObject :: Name -> Bool -> [YulStmt] -> Doc
+wrapInObject name deploy yul
+  | deploy    = ppr nested
+  | otherwise = ppr runtime
+  where
+    nested = YulObject "Deployable" deploycode [InnerObject runtime]
+    runtime = YulObject (show name) (YulCode stmts) []
+    cname = yulString (show name)
+    stmts = yul ++ retcode
     retcode =
-      [ call "mstore" [yulInt (0::Integer), YIdent "_mainresult"]
-      , call "return" [yulInt (0::Integer), yulInt (32::Integer)]
+      [ calls "mstore" [yulInt 0, YIdent "_mainresult"]
+      , calls "return" [yulInt 0, yulInt 32]
+      ]
+    deploycode = YulCode
+      [ calls "mstore" [yulInt 64, YCall "memoryguard" [yulInt 128]]
+      , ylva "memPtr" (YCall "mload" [yulInt 64])
+      -- call constructor here
+      , calls "datacopy" [yulInt 0, dataoffset, datasize]
+      , calls "return" [yulInt 0, datasize]
       ]
-    call f args = YExp (YCall f args)
+    calls f args = YExp (YCall f args)
+    ylva x e = YLet [Name x] (Just e)
+    datasize = YCall "datasize"[cname]
+    dataoffset = YCall "dataoffset"[cname]
 
 {- | wrap a Yul chunk in a Solidity function with the given name
    assumes result is in a variable named "_result"
 -}
-wrapInSol :: Name -> Yul -> Doc
+wrapInSol :: Name -> [YulStmt] -> Doc
 wrapInSol name yul = wrapInContract name "wrapper()" wrapper
     where
         wrapper = wrapInSolFunction "wrapper" (yulBuiltins <> yul)
 
-wrapInSolFunction :: Name -> Yul -> Doc
+wrapInSolFunction :: Name -> [YulStmt] -> Doc
 wrapInSolFunction name yul =
   text "function" <+> ppr name <+> prettyargs <+> text " public returns (uint256 _wrapresult)" <+> lbrace
   $$ nest 2 assembly
   $$ rbrace
   where
-    yul' = yul <> Yul [YAssign1 "_wrapresult" (YIdent "_mainresult")]
-    assembly = text "assembly" <+> lbrace
-      $$ nest 2 (ppr yul')
-      $$ rbrace
+    yul' = yul <> [YAssign1 "_wrapresult" (YIdent "_mainresult")]
+    assembly = text "assembly" <+> braces (nest 2 prettybody)
+    prettybody = vcat (map ppr yul')
     prettyargs = parens empty
 
 wrapInContract ::  Name -> Name -> Doc -> Doc

yule/Options.hs

@@ -10,6 +10,7 @@ data Options = Options
     , debug :: Bool
     , compress :: Bool
     , wrap :: Bool
+    , runOnce :: Bool
     } deriving Show
 
 optionsParser :: Parser Options
@@ -53,6 +54,10 @@ optionsParser = Options
         <> 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