Politically correct strings

sol-core.cabal

@@ -33,11 +33,9 @@ common common-opts
     , split
     , syb
     , template-haskell
+    , text
     , time
     , timeit
-    , directory
-    , split
-    , text
 
   build-tool-depends: happy:happy, alex:alex
 

src/Language/Yul.hs

@@ -98,7 +98,7 @@ hlist, vlist, nvlist, pprBlock :: Pretty a => [a] -> Doc
 hlist = hsep . map ppr
 vlist = vcat . map ppr
 nvlist = nest 2 . vlist
-pprBlock stmts = lbrace $$ nvlist stmts $$ rbrace
+pprBlock stmts = braces(nvlist stmts)
 
 
 instance Pretty YulObject where
@@ -142,9 +142,8 @@ instance Pretty YulStmt where
       $$ maybe empty (\stmts -> text "default" <+> pprBlock stmts) def
     where pprCase (lit, stmts) = text "case" <+> ppr lit <+> pprBlock stmts
   ppr (YFor pre cond post stmts) =
-    text "for" <+> braces (hlist pre)
-               <+> ppr cond
-               <+> hlist post <+> pprBlock stmts
+    text "for" <+> braces (hlist pre) <+> ppr cond <+> braces (hlist post)
+               $$ pprBlock stmts
   ppr YBreak = text "break"
   ppr YContinue = text "continue"
   ppr YLeave = text "leave"

src/Language/Yul/Parser.hs

@@ -71,6 +71,7 @@ yulStmt = sc *> choice
     , yulFun
     , YLet <$> (pKeyword "let" *> commaSep pName) <*> optional (symbol ":=" *> yulExp)
     , YIf <$> (pKeyword "if" *> yulExp) <*> yulBlock
+    , YFor <$> (pKeyword "for" *> yulBlock) <*> yulExp <*> yulBlock <*> yulBlock
     , YSwitch <$>
         (pKeyword "switch" *> yulExp) <*>
         many yulCase <*>

src/Solcore/Desugarer/ContractDispatch.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE QuasiQuotes #-}
 {-|
 Module      : Solcore.Desugarer.ContractDispatch
 Description : Implements method dispatch via function selectors in calldata
@@ -22,15 +23,22 @@ import Solcore.Frontend.Syntax
 import Solcore.Primitives.Primitives (word, unit, tupleExpFromList, tupleTyFromList)
 import Data.Text.Encoding (encodeUtf8)
 import Language.Yul
+import Language.Yul.QuasiQuote
 
 contractDispatchDesugarer :: CompUnit Name -> CompUnit Name
 contractDispatchDesugarer (CompUnit ims topdecls) = CompUnit ims (Set.toList extras <> topdecls')
   where
     (extras, topdecls') = mapAccumL go Set.empty topdecls
-
-    go acc (TContr c) = (Set.union acc (genNameDecls c), TContr (genMainFn c))
+    go acc (TContr c)
+      | "main" `notElem` functionNames c = (Set.union acc (genNameDecls c), TContr (genMainFn True c))
+      |  otherwise = (acc, TContr (genMainFn False c))
     go acc v = (acc, v)
 
+functionNames :: Contract a -> [Name]
+functionNames = foldr go [] . decls where
+  go (CFunDecl fd) = (sigName (funSignature fd) :)
+  go _ = id
+
 genNameDecls :: Contract Name -> Set (TopDecl Name)
 genNameDecls (Contract cname _ cdecls) = foldl go Set.empty cdecls
   where
@@ -40,9 +48,12 @@ genNameDecls (Contract cname _ cdecls) = foldl go Set.empty cdecls
       in Set.union (Set.fromList [TDataDef dataTy, TInstDef instDef]) acc
     go acc _ = acc
 
-genMainFn :: Contract Name -> Contract Name
-genMainFn (Contract cname tys cdecls) = Contract cname tys (CFunDecl mainfn : cdecls)
+genMainFn :: Bool -> Contract Name -> Contract Name
+genMainFn addMain (Contract cname tys cdecls)
+  | addMain = Contract cname tys (CFunDecl mainfn : Set.toList cdecls')
+  | otherwise = Contract cname tys (Set.toList cdecls')
   where
+    cdecls' = Set.unions (map (transformCDecl cname) cdecls)
     mainfn = FunDef (Signature [] [] "main" [] Nothing) body
     body = [ StmtExp (Call Nothing (QualName "RunContract" "exec") [cdata])]
     cdata = Con "Contract" [methods, fallback]
@@ -72,6 +83,88 @@ genMainFn (Contract cname tys cdecls) = Contract cname tys (CFunDecl mainfn : cd
     getTy (Typed _ t) = Just t
     getTy (Untyped {}) = Nothing
 
+transformCDecl :: Name -> ContractDecl Name -> Set (ContractDecl Name)
+transformCDecl contractName (CConstrDecl c) = transformConstructor contractName c
+transformCDecl _ d = Set.singleton d
+
+transformConstructor :: Name -> Constructor Name -> Set (ContractDecl Name)
+transformConstructor contractName cons
+  | all isTyped params = Set.fromList[initFun, copyArgsFun, startFun]
+  | otherwise = error $ "Internal Error: contract constructor must be fully typed"
+  where
+  params = constrParams cons
+  argsTuple = (tupleTyFromList (mapMaybe getTy params))
+  initFun = CFunDecl (FunDef initSig (constrBody cons))
+  initSig = Signature
+    { sigVars = mempty
+    , sigContext = mempty
+    , sigName = initFunName
+    , sigParams = params
+    , sigReturn = Just unit
+    }
+
+  copySig = Signature
+    { sigVars = mempty
+    , sigContext = mempty
+    , sigName = "copy_arguments_for_constructor"
+    , sigParams = mempty
+    , sigReturn = Just argsTuple
+    }
+  contractString = show contractName
+  yulContractName = YLit $ YulString contractString
+  deployer = YLit $ YulString $ contractString <> "Deploy"
+  copyBody =
+    [ Let "res" (Just argsTuple) Nothing
+    , Let "memoryDataOffset" (Just word) Nothing
+    , Asm [yulBlock|{
+             let programSize := datasize(`deployer`)
+             let argSize := sub(codesize(), programSize)
+             memoryDataOffset := mload(64)
+             mstore(64, add(memoryDataOffset, argSize))
+             codecopy(memoryDataOffset, programSize, argSize)
+          }|]
+    , Let "source" (Just (memoryT bytesT)) (Just (memoryE(Var "memoryDataOffset")))
+    , Var "res" := Call Nothing "abi_decode"
+      [ Var "source"
+      , proxyExp argsTuple
+      , proxyExp (TyCon "MemoryWordReader" [])
+      ]
+    , Return (Var "res")
+    ]
+  memoryT t = TyCon "memory" [t]
+  memoryE e = Con "memory" [e]
+  bytesT = TyCon "bytes" []
+  copyArgsFun = CFunDecl (FunDef copySig copyBody)
+
+  startSig = Signature
+    { sigVars = mempty
+    , sigContext = mempty
+    , sigName = "start"
+    , sigParams = mempty
+    , sigReturn = Just unit
+    }
+  startBody =
+    [ Asm [yulBlock|{ mstore(64, memoryguard(128)) }|]
+    , Let "conargs" (Just argsTuple)  (Just (Call Nothing "copy_arguments_for_constructor"[]))
+    -- , Match [Var "conargs"] ...
+    , Let "fun" Nothing (Just (Var initFunName))
+    , StmtExp $ Call Nothing "fun" [Var "conargs"]
+    , Asm [yulBlock|{
+            let size := datasize(`yulContractName`)
+            codecopy(0, dataoffset(`yulContractName`), datasize(`yulContractName`))
+            return(0, size)
+          }|]
+    ]
+  startFun = CFunDecl (FunDef startSig startBody)
+
+  isTyped (Typed {}) = True
+  isTyped (Untyped {}) = False
+
+  getTy (Typed _ t) = Just t
+  getTy (Untyped {}) = Nothing
+
+initFunName :: Name
+initFunName = "init_"
 
 mkNameTy :: Name -> Name -> DataTy
 mkNameTy cname fname = DataTy (nameTypeName cname fname) [] []

src/Solcore/Desugarer/EmitCore.hs

@@ -146,14 +146,13 @@ emitCDecl cd@(CDataDecl dt) = do
     addData dt >> pure []
 emitCDecl cd = debug ["!! emitCDecl ", show cd] >> pure []
 
--- By now, constructor should be converted to a function "constructor"
-
+-- look up the deployer start routine
 findConstructor :: [ContractDecl Id] -> Maybe (FunDef Id)
 findConstructor = go where
   go [] = Nothing
   go (CFunDecl d:_)| isConstructor d = Just d
   go (_:ds) = go ds
-  isConstructor (FunDef sig _) = sigName sig == Name "constructor"
+  isConstructor (FunDef sig _) = sigName sig == "start"
 
 -----------------------------------------------------------------------
 -- Translating function definitions

src/Solcore/Desugarer/Specialise.hs

@@ -219,10 +219,10 @@ specialiseTopDecl (TContr (Contract name args decls)) = withLocalState do
        getSpecialisedDecls
     -- Deployer code
     modify (\st -> st { specTable = emptyTable })
-    deployDecls <- case findConstructor decls of
-      Just c -> withLocalState do
-        cname' <- specConstructor c
-        st <- gets specTable
+    let deployerName = Name (pretty name <> "$Deployer")
+    mStart <- specEntry "start"
+    deployDecls <- case mStart of
+      Just s -> do
         depDecls <- getSpecialisedDecls
         -- use mutual to group constructor with its dependencies
         pure [CMutualDecl depDecls]
@@ -250,18 +250,18 @@ getConstructor :: ContractDecl Id -> Maybe (Constructor Id)
 getConstructor (CConstrDecl c) = Just c
 getConstructor _ = Nothing
 
-
-specEntry :: Name -> SM ()
+specEntry :: Name -> SM (Maybe Name)
 specEntry name = withLocalState do
     let any = TVar (Name "any")
     let anytype = TyVar any
     mres <- lookupResolution name anytype
     case mres of
       Just (fd, ty, subst) -> do
         debug ["< resolution: ", show name, " : ", pretty ty, "@", pretty subst]
-        void(specFunDef fd)
+        Just <$> specFunDef fd
       Nothing -> do
         warns ["!! Warning: no resolution found for ", show name]
+        pure Nothing
 
 specConstructor :: Constructor Id -> SM Name
 specConstructor (Constructor [] body) = do

src/Solcore/Frontend/Syntax/ElabTree.hs

@@ -263,10 +263,13 @@ extraTopDeclsForContract c@(S.Contract cname ts decls) = do
       -- the types of previous fields are needed to construct field offset
       contractFieldStep :: Field Name -> ([Ty], [TopDecl Name]) -> ([Ty], [TopDecl Name])
       contractFieldStep field (tys, decls) = (tys', decls') where
-          tys' = tys ++ [fieldTy field]
+          tys' = tys ++ [translateFieldType(fieldTy field)]
           decls' = decls ++ extraTopDeclsForContractField cname field offset
           offset = foldr pair unit tys
 
+translateFieldType :: Ty -> Ty
+translateFieldType string@(TyCon (Name "string") []) = TyCon "memory" [string]
+translateFieldType t = t
 
 extraTopDeclsForContractField :: ContractName -> Field Name -> Ty -> [TopDecl Name]
 extraTopDeclsForContractField cname field@(Field fname fty _minit) offset = [selDecl, TInstDef sfInstance] where
@@ -281,7 +284,7 @@ extraTopDeclsForContractField cname field@(Field fname fty _minit) offset = [sel
                , instVars = []
                , instContext = []
                , instName = "StructField"
-               , paramsTy = [fty, offset]
+               , paramsTy = [translateFieldType fty, offset]
                , mainTy = TyCon "StructField" [ctxTy, selType]
                , instFunctions = []
                }
@@ -645,7 +648,7 @@ instance Elab S.Exp where
         -- condition for valid constructor use
         if isCon && isNothing me' then
           pure (Con n es')
-        else if isClass then do 
+        else if isClass then do
           pure (Call Nothing (mkClassName me' n) es')
         -- condition for function call
         else pure (Call me' n es')

src/Solcore/Frontend/TypeInference/TcSimplify.hs

@@ -159,7 +159,7 @@ toHnf depth p@(InCls c _ _)
                 info [">>>> No default instance found for:", pretty p]
                 pure [p]
               Just (_, s) -> do
-                info [">>>> Default instance for:", pretty p, "found! (Solved)"]
+                info [">>>> Default instance for:", pretty p, " found! (Solved), \n>>> Subst: ", pretty s]
                 -- default instances should not have any additional contraints.
                 _ <- extSubst s
                 pure []

src/Solcore/Pipeline/Options.hs

@@ -14,6 +14,7 @@ data Option
     , optVerbose   :: !Bool
     , optDumpAST   :: !Bool
     , optDumpEnv   :: !Bool
+    , optDumpDispatch :: !Bool
     , optDumpDS    :: !Bool
     , optDumpDF    :: !Bool
     , optDumpSpec  :: !Bool
@@ -37,6 +38,7 @@ emptyOption path = Option
     , optVerbose        = False
     , optDumpAST        = False
     , optDumpEnv        = False
+    , optDumpDispatch   = False
     , optDumpDS         = False
     , optDumpDF         = False
     , optDumpSpec       = False
@@ -85,6 +87,8 @@ options
                <> help "Dump AST after name resolution")
            <*> switch ( long "dump-env"
                <> help "Dump env after name resolution")
+           <*> switch ( long "dump-dispatch"
+               <> help "Dump dispatched contract")
            <*> switch ( long "dump-ds"
                <> help "Dump desugared contract")
            <*> switch ( long "dump-df"

src/Solcore/Pipeline/SolcorePipeline.hs

@@ -76,12 +76,16 @@ compile opts = runExceptT $ do
 
   liftIO $ when (optDumpEnv opts) $ pPrint env
 
-  -- contrct dispatch generation
+  -- contract dispatch generation
   dispatched <- liftIO $
     if noGenDispatch
     then pure resolved
     else timeItNamed "Contract dispatch generation" $ pure (contractDispatchDesugarer resolved)
 
+  liftIO $ when (optDumpDispatch opts) $ do
+    putStrLn "> Dispatch:"
+    putStrLn $ pretty dispatched
+
   -- SCC analysis
   connected <- ExceptT $ timeItNamed "SCC           " $
     sccAnalysis dispatched

src/Solcore/Primitives/Primitives.hs

@@ -214,7 +214,7 @@ yulPrimOps = [ (Name "stop", monotype unit)
              , (Name "callvalue", monotype word)
              , (Name "calldataload", monotype (word :-> word))
              , (Name "calldatasize", monotype word)
-             , (Name "calldatacopy", monotype (word :-> word :-> word :-> word))
+             , (Name "calldatacopy", monotype (word :-> word :-> word :-> unit))
              , (Name "codesize", monotype word)
              , (Name "codecopy", monotype (word :-> word :-> word :-> unit))
              , (Name "datasize", monotype (string :-> word))

std/dispatch.solc

@@ -32,12 +32,34 @@ instance uint256:ABIString {
     }
 }
 
+instance address:ABIString {
+    function append(head : word, tail : word, prx : Proxy(address)) -> word {
+        let size : word = 7;
+        assembly {
+            mstore(head, add(mload(head), size))
+            mstore(tail, 0x6164647265737300000000000000000000000000000000000000000000000000)
+        }
+        return Add.add(tail, size);
+    }
+}
+
 instance ():ABIString {
     function append(head : word, tail : word, prx : Proxy(())) -> word {
         return(tail);
     }
 }
 
+instance memory(string):ABIString {
+    function append(head : word, tail : word, prx : Proxy(memory(string))) -> word {
+        let size : word = 6;
+        assembly {
+            mstore(head, add(mload(head), size))
+            mstore(tail, 0x737472696e670000000000000000000000000000000000000000000000000000)
+        }
+        return Add.add(tail, size);
+    }
+}
+
 function append_left_bracket(head : word, tail : word) -> word {
     let size = 1;
     assembly {
@@ -183,12 +205,15 @@ forall payability args rets fn
     // abi encode rets to memory
     let ptr = abi_encode(rets);
 
-    // TODO: this is broken for dynamically sized types...
-    let retSz : word = ABIAttribs.headSize(prets);
+    // let retSz : word = ABIAttribs.headSize(prets);
+    // the approach above does not work for dynamically sized types...
+    // ...instead we take the size of memory allocated by the encoding
     let start : word = Typedef.rep(ptr);
-
+    let encStart : word = Typedef.rep(ptr); // cannot be called start - see #252
+    let end : word = get_free_memory();
+    let retSz : word = Sub.sub(end, encStart);
     assembly {
-        return(start,retSz)
+        return(encStart, retSz)
     }
 }