materialize string literals into memory(string)

run_contests.sh

@@ -15,6 +15,7 @@ bash ./contest.sh test/examples/dispatch/payable.json
 bash ./contest.sh test/examples/dispatch/payable_ctor.json
 bash ./contest.sh test/examples/dispatch/nonpayable_ctor.json
 bash ./contest.sh test/examples/dispatch/concat.json
+bash ./contest.sh test/examples/dispatch/stringlit.json
 bash ./contest.sh test/examples/dispatch/slices.json
 bash ./contest.sh test/examples/dispatch/fallback.json
 bash ./contest.sh test/examples/dispatch/ecrecover.json

sol-core.cabal

@@ -69,6 +69,7 @@ library
       Solcore.Desugarer.IfDesugarer
       Solcore.Desugarer.IndirectCall
       Solcore.Desugarer.IntLiteralDesugar
+      Solcore.Desugarer.StrLiteralDesugar
       Solcore.Desugarer.ReplaceWildcard
       Solcore.Desugarer.ContractDispatch
       Solcore.Desugarer.ReplaceFunTypeArgs

src/Solcore/Backend/EmitHull.hs

@@ -3,11 +3,14 @@ module Solcore.Backend.EmitHull (emitHull) where
 import Common.Monad
 import Control.Monad (when)
 import Control.Monad.State
+import Data.ByteString qualified as BS
 import Data.List (partition)
 import Data.Map qualified as Map
 import Data.Maybe (fromMaybe)
 import Data.Set qualified as Set
 import Data.String (fromString)
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as TE
 import GHC.Stack (HasCallStack)
 import Language.Hull qualified as Hull
 import Language.Yul
@@ -18,6 +21,7 @@ import Solcore.Frontend.Syntax.Name
 import Solcore.Frontend.Syntax.Stmt (Literal (..))
 import Solcore.Frontend.Syntax.Ty (Ty (..), Tyvar (..))
 import Solcore.Frontend.TypeInference.TcMonad (insts)
+import Solcore.Primitives.Primitives (memStringFromLitName)
 import Prelude hiding (product)
 
 emitHull :: Bool -> MastCompUnit -> IO [Hull.Object]
@@ -43,7 +47,10 @@ data EcState = EcState
     ecDebug :: Bool,
     ecContext :: [String],
     ecDeployer :: Maybe Hull.Body,
-    ecFresh :: Int
+    ecFresh :: Int,
+    -- String literals materialized into memory(string), keyed by content for
+    -- dedup; value is the generated allocator's name (__strlit_<n>).
+    ecStrLits :: Map.Map String String
   }
 
 initEcState :: Bool -> EcState
@@ -55,7 +62,8 @@ initEcState debugp =
       ecDebug = debugp,
       ecContext = [],
       ecDeployer = Nothing,
-      ecFresh = 0
+      ecFresh = 0,
+      ecStrLits = Map.empty
     }
 
 -- isolate local changes to nesting level and variable substitution
@@ -94,6 +102,20 @@ builtinDataInfo = [("sum", sumDataTy)]
 mastIntegerTy :: MastTy
 mastIntegerTy = MastTyCon (Name "integer") []
 
+-- | The comptime-only string type.  A `string` has no runtime representation
+-- (it is an empty `data string;`); it must be folded away or materialized into
+-- memory(string) via Str.fromString before hull emission.  Reaching here is a
+-- bug, and without this guard it would surface as a cryptic "empty sum string".
+mastStringTy :: MastTy
+mastStringTy = MastTyCon (Name "string") []
+
+-- | Name of a comptime-only type if the given type is one, for guard messages.
+comptimeOnlyMastName :: MastTy -> Maybe String
+comptimeOnlyMastName t
+  | t == mastIntegerTy = Just "integer"
+  | t == mastStringTy = Just "string"
+  | otherwise = Nothing
+
 type VSubst = Map.Map Name Hull.Expr
 
 emptyVSubst :: VSubst
@@ -130,14 +152,78 @@ emitContract :: MastContract -> EM Hull.Object
 emitContract c = do
   let cname = show (mastContrName c)
   writes ["Emitting hull for contract ", cname]
-  runtimeBody <- concatMapM emitCDecl (mastContrDecls c)
+  modify (\s -> s {ecStrLits = Map.empty})
+  runtimeBody0 <- concatMapM emitCDecl (mastContrDecls c)
+  -- Prepend the per-literal string allocators referenced by the runtime code.
+  strLits <- gets ecStrLits
+  let strLitFuns = [genStrLitFun fn s | (s, fn) <- Map.toList strLits]
+  let runtimeBody = strLitFuns ++ runtimeBody0
   deployer <- gets ecDeployer
   case deployer of
     Nothing -> pure (Hull.Object cname runtimeBody [])
     Just code ->
       let runtimeObject = Hull.Object cname runtimeBody []
        in pure (Hull.Object (cname ++ "Deploy") code [runtimeObject])
 
+-- | Register a string literal for materialization, deduplicated by content.
+-- Returns the name of the generated allocator function.
+registerStrLit :: String -> EM String
+registerStrLit s = do
+  lits <- gets ecStrLits
+  case Map.lookup s lits of
+    Just fn -> pure fn
+    Nothing -> do
+      let fn = "__strlit_" ++ show (Map.size lits)
+      modify (\st -> st {ecStrLits = Map.insert s fn (ecStrLits st)})
+      pure fn
+
+-- | Generate the allocator for one string literal.  It allocates length +
+-- character slots from the free-memory pointer (0x40), writes the byte length
+-- and the (right-padded) character words, bumps the free pointer, and returns
+-- the pointer (the memory(string) representation).  The block is self-contained
+-- and depends on no other emitted function.
+genStrLitFun :: String -> String -> Hull.Stmt
+genStrLitFun fn s =
+  Hull.SFunction fn [] Hull.TWord $
+    [ Hull.SAlloc "p" Hull.TWord,
+      Hull.SAssembly asm,
+      Hull.SReturn (Hull.EVar "p")
+    ]
+  where
+    (len, charWords, total) = strLitLayout s
+    asm =
+      [YAssign ["p"] (YCall "mload" [YLit (YulNumber 0x40)])]
+        ++ [YExp (YCall "mstore" [YIdent "p", YLit (YulNumber len)])]
+        ++ [ YExp
+               ( YCall
+                   "mstore"
+                   [YCall "add" [YIdent "p", YLit (YulNumber (32 * i))], YLit (YulNumber w)]
+               )
+             | (i, w) <- zip [1 ..] charWords
+           ]
+        ++ [ YExp
+               ( YCall
+                   "mstore"
+                   [YLit (YulNumber 0x40), YCall "add" [YIdent "p", YLit (YulNumber total)]]
+               )
+           ]
+
+-- | Compute the in-memory layout of a string literal:
+-- (byte length, character words right-padded to 32 bytes, total bytes allocated).
+strLitLayout :: String -> (Integer, [Integer], Integer)
+strLitLayout s =
+  (toInteger len, map chunkToWord chunks, toInteger total)
+  where
+    bytes = BS.unpack (TE.encodeUtf8 (T.pack s))
+    len = length bytes
+    chunks = chunk32 bytes
+    total = 32 * (1 + length chunks)
+    chunk32 [] = []
+    chunk32 xs = let (h, t) = splitAt 32 xs in h : chunk32 t
+    -- big-endian word of the 32-byte slot (bytes left-aligned, zero-padded right)
+    chunkToWord chunk =
+      foldl (\acc b -> acc * 256 + toInteger b) 0 (take 32 (chunk ++ replicate 32 0))
+
 emitCDecl :: MastContractDecl -> EM [Hull.Stmt]
 emitCDecl (MastCFunDecl f) = emitFunDef f
 emitCDecl (MastCMutualDecl ds) = case findConstructor ds of
@@ -164,8 +250,10 @@ findConstructor = go
 -----------------------------------------------------------------------
 emitFunDef :: (HasCallStack) => MastFunDef -> EM [Hull.Stmt]
 emitFunDef fd = withContext (show (mastFunName fd)) do
-  when (mastFunReturn fd == mastIntegerTy) $
-    errorsEM ["integer-typed return in '", show (mastFunName fd), "': comptime value not eliminated before hull emission"]
+  case comptimeOnlyMastName (mastFunReturn fd) of
+    Just tn ->
+      errorsEM [tn, "-typed return in '", show (mastFunName fd), "': comptime value not eliminated before hull emission"]
+    Nothing -> pure ()
   let name = show (mastFunName fd)
   hullArgs <- mapM translateParam (mastFunParams fd)
   hullTyp <- translateMastType (mastFunReturn fd)
@@ -177,8 +265,8 @@ emitFunDef fd = withContext (show (mastFunName fd)) do
 
 translateParam :: MastParam -> EM Hull.Arg
 translateParam (MastParam n _ct t)
-  | t == mastIntegerTy =
-      errorsEM ["integer-typed parameter '", show n, "': comptime value not eliminated before hull emission"]
+  | Just tn <- comptimeOnlyMastName t =
+      errorsEM [tn, "-typed parameter '", show n, "': comptime value not eliminated before hull emission"]
   | otherwise = Hull.TArg (show n) <$> translateMastType t
 
 -----------------------------------------------------------------------
@@ -283,6 +371,11 @@ emitExp (MastVar x) = do
     Nothing -> pure (Hull.EVar (show (mastIdName x)), [])
 -- special handling of revertLit
 emitExp (MastCall (MastId "revertLit" _) [MastLit (StrLit s)]) = pure (Hull.EUnit, [Hull.SRevert s])
+-- materialize a string literal into memory(string): call its per-literal allocator
+emitExp (MastCall (MastId name _) [MastLit (StrLit s)])
+  | name == memStringFromLitName = do
+      fn <- registerStrLit s
+      pure (Hull.ECall fn [], [])
 emitExp (MastCall f as) = do
   (hullArgs, codes) <- unzip <$> mapM emitExp as
   let call = Hull.ECall (show (mastIdName f)) hullArgs
@@ -309,8 +402,8 @@ emitStmt (MastAssign i e) = do
   let assign = [Hull.SAssign (Hull.EVar (show (mastIdName i))) e']
   return (stmts ++ assign)
 emitStmt (MastLet _ct (MastId name ty) _ mexp)
-  | ty == mastIntegerTy =
-      errorsEM ["integer-typed let '", show name, "': comptime value not eliminated before hull emission"]
+  | Just tn <- comptimeOnlyMastName ty =
+      errorsEM [tn, "-typed let '", show name, "': comptime value not eliminated before hull emission"]
   | otherwise = do
       let hullName = show name
       hullTy <- translateMastType ty

src/Solcore/Backend/MastEval.hs

@@ -51,7 +51,7 @@ import Language.Yul (YLiteral (..), YulExp (..), YulStmt (..))
 import Solcore.Backend.Mast
 import Solcore.Frontend.Syntax.Name
 import Solcore.Frontend.Syntax.Stmt (Literal (..))
-import Solcore.Primitives.Primitives (integerPrimNames)
+import Solcore.Primitives.Primitives (integerPrimNames, memStringFromLitName, stringPrimNames)
 
 -----------------------------------------------------------------------
 -- Data structures
@@ -460,6 +460,7 @@ evalPrimitive (Name "integerLt") [MastLit (IntLit a), MastLit (IntLit b)] =
 evalPrimitive (Name "integerEq") [MastLit (IntLit a), MastLit (IntLit b)] =
   Just (mkBool (a == b))
 evalPrimitive (QualName (Name "Int") "fromInteger") [x] = Just x -- identity for integer -> integer
+evalPrimitive (QualName (Name "Str") "fromString") [x] = Just x -- identity for string -> string
 evalPrimitive _ _ = Nothing
 
 bsToIntegerBE :: BS.ByteString -> Integer
@@ -829,10 +830,11 @@ builtinPureFuns =
       Name "keccakLit"
     ]
       ++ integerPrimNames
+      ++ stringPrimNames
 
 -- Functions with dummy pure bodies that are intercepted by EmitHull
 builtinImpureFuns :: Set.Set Name
-builtinImpureFuns = Set.fromList [Name "revertLit"]
+builtinImpureFuns = Set.fromList [Name "revertLit", memStringFromLitName]
 
 -- | Compute the set of pure functions via fixed-point iteration.
 -- Start from builtinPureFuns; each iteration adds functions whose bodies

src/Solcore/Backend/Specialise.hs

@@ -399,6 +399,16 @@ specCall (Id (QualName (Name "Int") "fromInteger") ty) args _ = do
   if resultTy == word
     then pure (Id (Name "wordFromInteger") (Prim.integer :-> word), args')
     else pure (Id (QualName (Name "Int") "fromInteger") (Prim.integer :-> resultTy), args')
+-- Str.fromString coercion: resolve based on result type.
+-- string -> memory(string) becomes memStringFromLit (lowered per-literal by EmitHull)
+-- string -> string         is identity (folded by MastEval)
+specCall (Id (QualName (Name "Str") "fromString") ty) args _ = do
+  args' <- mapM (\a -> specExp a (typeOfTcExp a)) args
+  s <- getSpSubst
+  let resultTy = snd (splitTy (applytv s ty))
+  if resultTy == Prim.memString
+    then pure (Id Prim.memStringFromLitName (Prim.string :-> Prim.memString), args')
+    else pure (Id (QualName (Name "Str") "fromString") (Prim.string :-> resultTy), args')
 specCall i args _ty
   | idName i `elem` comptimeBuiltins = do
       args' <- mapM (\a -> specExp a (typeOfTcExp a)) args

src/Solcore/Desugarer/StrLiteralDesugar.hs

@@ -0,0 +1,32 @@
+module Solcore.Desugarer.StrLiteralDesugar (desugarStrLiterals) where
+
+import Data.Generics
+import Solcore.Frontend.Syntax
+import Solcore.Primitives.Primitives (strClassName)
+
+-- Wrap comptime string values in expression position with a call to
+-- Str.fromString, making them polymorphic over their target representation:
+--   * every string literal, and
+--   * every comptime concatenation (`concatLit(...)`).
+-- At a `string` site the wrapper resolves to the identity instance (and folds);
+-- at a `memory(string)` site it materializes.  Because `concatLit`'s parameters
+-- are `string`, a wrapped `concatLit` used as an argument to another `concatLit`
+-- resolves to identity, so nested concatenations collapse to a single literal
+-- and materialize once.  Pattern literals (PLit) are not expressions and are
+-- left untouched.
+desugarStrLiterals :: [TopDecl Name] -> [TopDecl Name]
+desugarStrLiterals = everywhere (mkT desugarExp)
+
+fromStringName :: Name
+fromStringName = QualName strClassName "fromString"
+
+-- | Recognise concatLit regardless of qualification (e.g. @std.concatLit@).
+isConcatLit :: Name -> Bool
+isConcatLit (Name "concatLit") = True
+isConcatLit (QualName _ "concatLit") = True
+isConcatLit _ = False
+
+desugarExp :: Exp Name -> Exp Name
+desugarExp (Lit l@(StrLit _)) = Call Nothing fromStringName [Lit l]
+desugarExp e@(Call _ n _) | isConcatLit n = Call Nothing fromStringName [e]
+desugarExp e = e

src/Solcore/Frontend/ComptimeCheck.hs

@@ -26,6 +26,7 @@ import Solcore.Frontend.Syntax.Name (Name)
 import Solcore.Frontend.Syntax.Stmt
 import Solcore.Frontend.Syntax.Ty (Ty (..))
 import Solcore.Frontend.TypeInference.Id (Id (..))
+import Solcore.Primitives.Primitives qualified as Prim
 
 -----------------------------------------------------------------------
 -- Comptime-ness classification
@@ -87,15 +88,16 @@ checkContrDecl _ _ = Right ()
 -----------------------------------------------------------------------
 
 checkFunDef :: SigTable -> String -> FunDef Id -> Either String ()
-checkFunDef st ctx fd = checkBody st (sigRetComptime sig) ctx initEnv (funDefBody fd)
+checkFunDef st ctx fd = checkBody st (effRetComptime sig) ctx initEnv (funDefBody fd)
   where
     sig = funSignature fd
     -- For '-> comptime' functions, treat ALL params as CTComptime when checking
     -- the body: this verifies "given comptime args, does the body produce comptime?"
-    -- For other functions, non-comptime params are CTRuntime.
+    -- A param of comptime-only type (string/integer) is also implicitly comptime,
+    -- since such values exist only at compile time.  Other params are CTRuntime.
     initEnv =
       Map.fromList
-        [ (idName (paramName p), if paramComptime p || sigRetComptime sig then CTComptime else CTRuntime)
+        [ (idName (paramName p), if paramComptime p || effRetComptime sig || isComptimeOnlyTy (paramTy p) then CTComptime else CTRuntime)
           | p <- sigParams sig
         ]
 
@@ -211,8 +213,20 @@ checkCallSite st env f args =
           ++ "' of '"
           ++ show (idName f)
           ++ "'"
-    paramTy (Typed _ _ ty) = ty
-    paramTy (Untyped _ _) = TyCon (error "paramTy: Untyped") []
+
+-- | A value of comptime-only type (string / integer) exists only at compile
+-- time, so it is always comptime regardless of annotation.
+isComptimeOnlyTy :: Ty -> Bool
+isComptimeOnlyTy t = t == Prim.string || t == Prim.integer
+
+-- | A function is effectively '-> comptime' if it is annotated so, or if its
+-- return type is comptime-only.
+effRetComptime :: Signature Id -> Bool
+effRetComptime sig = sigRetComptime sig || maybe False isComptimeOnlyTy (sigReturn sig)
+
+paramTy :: Param Id -> Ty
+paramTy (Typed _ _ ty) = ty
+paramTy (Untyped _ _) = TyCon (error "paramTy: Untyped") []
 
 -- | True if the type contains any type variable or meta variable.
 hasTypeVar :: Ty -> Bool
@@ -252,7 +266,7 @@ classifyCall st env f args =
   case Map.lookup (idName f) st of
     Nothing -> CTDeferred
     Just sig
-      | sigRetComptime sig && allArgsComptime ->
+      | effRetComptime sig && allArgsComptime ->
           CTComptime
       | otherwise ->
           CTDeferred

src/Solcore/Frontend/Syntax/NameResolution.hs

@@ -921,7 +921,7 @@ emptyEnv =
           (Name "sum", TTyCon)
         ]
     )
-    (Map.fromList [(Name "invokable", TClass), (Name "Int", TClass)])
+    (Map.fromList [(Name "invokable", TClass), (Name "Int", TClass), (Name "Str", TClass)])
     Map.empty
     ( Map.fromList
         [ (Name "true", TDataCon),
@@ -940,7 +940,8 @@ emptyEnv =
           (Name "integerMul", TFunction),
           (Name "integerLt", TFunction),
           (Name "integerEq", TFunction),
-          (QualName (Name "Int") "fromInteger", TFunction)
+          (QualName (Name "Int") "fromInteger", TFunction),
+          (QualName (Name "Str") "fromString", TFunction)
         ]
     )