Add the comptime keyword (with no effect yet)

src/Solcore/Backend/EmitHull.hs

@@ -230,7 +230,7 @@ translateProduct :: [MastExp] -> Translation Hull.Expr
 translateProduct [] = pure (Hull.EUnit, [])
 translateProduct es = do
   (hullExps, codes) <- unzip <$> mapM emitExp es
-  let product = foldr1 (Hull.EPair) hullExps
+  let product = foldr1 Hull.EPair hullExps
   pure (product, concat codes)
 
 encodeCon :: Name -> [Constr] -> Hull.Type -> Hull.Expr -> Hull.Expr
@@ -289,7 +289,7 @@ emitStmt (MastAssign i e) = do
   (e', stmts) <- emitExp e
   let assign = [Hull.SAssign (Hull.EVar (show (mastIdName i))) e']
   return (stmts ++ assign)
-emitStmt (MastLet (MastId name ty) _mty mexp) = do
+emitStmt (MastLet _ct (MastId name ty) _mty mexp) = do
   let hullName = show name
   hullTy <- translateMastType ty
   let alloc = [Hull.SAlloc hullName hullTy]
@@ -436,7 +436,7 @@ emitSumMatch allCons scrutinee alts = do
         rightBranch t = error ("rightBranch: not a sum type: " ++ show t)
         left = altName False
         right = altName True
-        alt con n stmts = Hull.ConAlt con n stmts
+        alt = Hull.ConAlt
 
     altName :: Bool -> String
     altName False = "$alt"
@@ -539,9 +539,9 @@ renameYulStmts subst stmts = goBlock Set.empty stmts
       post' <- goBlock preScope post
       blk' <- goBlock preScope blk
       pure (YFor pre' cond' post' blk', scope)
-    goStmt scope s@(YBreak) = pure (s, scope)
-    goStmt scope s@(YContinue) = pure (s, scope)
-    goStmt scope s@(YLeave) = pure (s, scope)
+    goStmt scope s@YBreak = pure (s, scope)
+    goStmt scope s@YContinue = pure (s, scope)
+    goStmt scope s@YLeave = pure (s, scope)
     goStmt scope s@(YComment _) = pure (s, scope)
     goStmt scope (YExp e) = do
       e' <- goExp scope e

src/Solcore/Backend/Mast.hs

@@ -16,6 +16,12 @@ import Solcore.Frontend.Syntax.Stmt (Literal (..))
 import Solcore.Frontend.Syntax.Ty (Ty (..), Tyvar (..))
 import Solcore.Primitives.Primitives (word)
 
+-----------------------------------------------------------------------
+-- Comptime flag
+-----------------------------------------------------------------------
+
+type ComptimeFlag = Bool
+
 -----------------------------------------------------------------------
 -- Types: no TyVar, no Meta — only type constructors
 -----------------------------------------------------------------------
@@ -71,6 +77,7 @@ data MastContractDecl
 data MastFunDef = MastFunDef
   { mastFunName :: Name,
     mastFunParams :: [MastParam],
+    mastFunRetComptime :: ComptimeFlag,
     mastFunReturn :: MastTy,
     mastFunBody :: [MastStmt]
   }
@@ -88,7 +95,7 @@ data MastParam = MastParam
 
 data MastStmt
   = MastAssign MastId MastExp
-  | MastLet MastId (Maybe MastTy) (Maybe MastExp)
+  | MastLet ComptimeFlag MastId (Maybe MastTy) (Maybe MastExp)
   | MastStmtExp MastExp
   | MastReturn MastExp
   | MastMatch MastExp [MastAlt]
@@ -195,12 +202,12 @@ instance Pretty MastContractDecl where
   ppr (MastCMutualDecl ds) = vcat (map ppr ds)
 
 instance Pretty MastFunDef where
-  ppr (MastFunDef n ps ret bd) =
+  ppr (MastFunDef n ps ct ret bd) =
     text "function"
       <+> ppr n
       <+> parens (commaSep (map ppr ps))
       <+> text "->"
-      <+> ppr ret
+      <+> (if ct then text "comptime" <+> ppr ret else ppr ret)
       <+> lbrace
       $$ nest 3 (vcat (map ppr bd))
       $$ rbrace
@@ -210,8 +217,8 @@ instance Pretty MastParam where
 
 instance Pretty MastStmt where
   ppr (MastAssign i e) = ppr i <+> equals <+> ppr e <+> semi
-  ppr (MastLet i ty m) =
-    text "let" <+> ppr i <+> pprOptMastTy ty <+> pprMastInit m
+  ppr (MastLet ct i ty m) =
+    (if ct then text "let comptime" else text "let") <+> ppr i <+> pprOptMastTy ty <+> pprMastInit m
   ppr (MastStmtExp e) = ppr e >< semi
   ppr (MastReturn e) = text "return" <+> ppr e >< semi
   ppr (MastMatch e alts) =

src/Solcore/Backend/MastEval.hs

@@ -160,13 +160,13 @@ evalStmts env (s : ss) = do
 
 evalStmt :: VEnv -> MastStmt -> EvalM (VEnv, [MastStmt])
 evalStmt env stmt = case stmt of
-  MastLet i ty mInit -> do
+  MastLet ct i ty mInit -> do
     mInit' <- traverse (evalExp env) mInit
     let env' = case mInit' of
           Just e | isKnownValue e -> Map.insert i e env
           _ -> Map.delete i env -- Shadow/remove any existing binding
           -- Always emit the let: the variable may be referenced by opaque asm blocks
-    pure (env', [MastLet i ty mInit'])
+    pure (env', [MastLet ct i ty mInit'])
   MastAssign i e -> do
     e' <- evalExp env e
     let env' =
@@ -314,7 +314,7 @@ tryInline fname args = do
 evalFunBody :: VEnv -> [MastStmt] -> EvalM (Maybe MastExp)
 evalFunBody _ [] = pure Nothing -- No return statement found
 evalFunBody env (stmt : rest) = case stmt of
-  MastLet i _ mInit -> do
+  MastLet _ i _ mInit -> do
     mInit' <- traverse (evalExp env) mInit
     let env' = case mInit' of
           Just e | isKnownValue e -> Map.insert i e env
@@ -463,7 +463,7 @@ bodyIsPure pureFuns = all (stmtIsPure pureFuns)
 
 stmtIsPure :: Set.Set Name -> MastStmt -> Bool
 stmtIsPure _ (MastAsm _) = False
-stmtIsPure pureFuns (MastLet _ _ mInit) = maybe True (expIsPure pureFuns) mInit
+stmtIsPure pureFuns (MastLet _ _ _ mInit) = maybe True (expIsPure pureFuns) mInit
 stmtIsPure pureFuns (MastAssign _ e) = expIsPure pureFuns e
 stmtIsPure pureFuns (MastStmtExp e) = expIsPure pureFuns e
 stmtIsPure pureFuns (MastReturn e) = expIsPure pureFuns e
@@ -549,7 +549,7 @@ callsInFun :: MastFunDef -> Set.Set Name
 callsInFun fd = Set.unions (map callsInStmt (mastFunBody fd))
 
 callsInStmt :: MastStmt -> Set.Set Name
-callsInStmt (MastLet _ _ mInit) = maybe Set.empty callsInExp mInit
+callsInStmt (MastLet _ _ _ mInit) = maybe Set.empty callsInExp mInit
 callsInStmt (MastAssign _ e) = callsInExp e
 callsInStmt (MastStmtExp e) = callsInExp e
 callsInStmt (MastReturn e) = callsInExp e

src/Solcore/Backend/Specialise.hs

@@ -469,16 +469,16 @@ specStmt stmt@(Var i := e) = do
   e' <- specExp e ty'
   debug ["< specExp (:=): ", pretty e']
   return $ Var i' := e'
-specStmt stmt@(Let i mty mexp) = do
+specStmt stmt@(Let ct i mty mexp) = do
   subst <- getSpSubst
   debug ["> specStmt (Let): ", pretty i, " : ", pretty (idType i), " @ ", pretty subst]
   i' <- atCurrentSubst i
   let ty' = idType i'
   ensureClosed ty' stmt subst
   mty' <- atCurrentSubst mty
   case mexp of
-    Nothing -> return $ Let i' mty' Nothing
-    Just e -> Let i' mty' . Just <$> specExp e ty'
+    Nothing -> return $ Let ct i' mty' Nothing
+    Just e -> Let ct i' mty' . Just <$> specExp e ty'
 specStmt (StmtExp e) = do
   ty <- atCurrentSubst (typeOfTcExp e)
   e' <- specExp e ty
@@ -573,8 +573,8 @@ typeOfTcExp (TyExp _ ty) = ty
 typeOfTcExp e = error $ "typeOfTcExp: " ++ show e
 
 typeOfTcParam :: Param Id -> Ty
-typeOfTcParam (Typed i _t) = idType i -- seems better than t - see issue #6
-typeOfTcParam (Untyped i) = idType i
+typeOfTcParam (Typed _ i _t) = idType i -- seems better than t - see issue #6
+typeOfTcParam (Untyped _ i) = idType i
 
 typeOfTcSignature :: Signature Id -> Ty
 typeOfTcSignature sig = funtype (map typeOfTcParam $ sigParams sig) returnType
@@ -584,12 +584,12 @@ typeOfTcSignature sig = funtype (map typeOfTcParam $ sigParams sig) returnType
       Nothing -> error ("no return type in signature of: " ++ show (sigName sig))
 
 schemeOfTcSignature :: Signature Id -> Scheme
-schemeOfTcSignature sig@(Signature vs ps _n args (Just rt)) =
+schemeOfTcSignature sig@(Signature vs ps _n args _ (Just rt)) =
   case mapM getType args of
     Just ts -> Forall vs (ps :=> (funtype ts rt))
     Nothing -> error $ unwords ["Invalid instance member signature:", pretty sig]
   where
-    getType (Typed _ t) = Just t
+    getType (Typed _ _ t) = Just t
     getType _ = Nothing
 schemeOfTcSignature sig = error ("no return type in signature of: " ++ show (sigName sig))
 
@@ -803,6 +803,7 @@ toMastFunDef (FunDef sig body) =
   MastFunDef
     { mastFunName = sigName sig,
       mastFunParams = map toMastParam (sigParams sig),
+      mastFunRetComptime = sigRetComptime sig,
       mastFunReturn = case sigReturn sig of
         Just t -> toMastTy t
         Nothing -> error $ "toMastFunDef: no return type for " ++ show (sigName sig),
@@ -815,8 +816,8 @@ toMastParam p = MastParam (idName i) (toMastTy (idType i))
     i = getParamId p
 
 getParamId :: Param Id -> Id
-getParamId (Typed i _) = i
-getParamId (Untyped i) = i
+getParamId (Typed _ i _) = i
+getParamId (Untyped _ i) = i
 
 toMastTy :: Ty -> MastTy
 toMastTy = tyToMast
@@ -826,7 +827,7 @@ toMastId (Id n t) = MastId n (toMastTy t)
 
 toMastStmt :: Stmt Id -> MastStmt
 toMastStmt (Var i := e) = MastAssign (toMastId i) (toMastExp e)
-toMastStmt (Let i mty me) = MastLet (toMastId i) (fmap toMastTy mty) (fmap toMastExp me)
+toMastStmt (Let ct i mty me) = MastLet ct (toMastId i) (fmap toMastTy mty) (fmap toMastExp me)
 toMastStmt (StmtExp e) = MastStmtExp (toMastExp e)
 toMastStmt (Return e) = MastReturn (toMastExp e)
 toMastStmt (Match [scrutinee] alts) = MastMatch (toMastExp scrutinee) (map toMastAlt alts)

src/Solcore/Desugarer/ContractDispatch.hs

@@ -49,7 +49,7 @@ genMainFn addMain (Contract cname tys cdecls)
   | otherwise = Contract cname tys (Set.toList cdecls')
   where
     cdecls' = Set.unions (map (transformCDecl cname) cdecls)
-    mainfn = FunDef (Signature [] [] "main" [] Nothing) body
+    mainfn = FunDef (Signature [] [] "main" [] False Nothing) body
     body = [StmtExp (Call Nothing (QualName "RunContract" "exec") [cdata])]
     cdata = Con "Contract" [methods, fallback]
     methods = tupleExpFromList (fmap mkMethod (mapMaybe unwrapSigs cdecls))
@@ -62,7 +62,7 @@ genMainFn addMain (Contract cname tys cdecls)
           Var "revert_handler"
         ]
 
-    mkMethod (Signature _ _ fname fargs (Just ret))
+    mkMethod (Signature _ _ fname fargs _ (Just ret))
       | all isTyped fargs =
           Con
             "Method"
@@ -80,7 +80,7 @@ genMainFn addMain (Contract cname tys cdecls)
     isTyped (Typed {}) = True
     isTyped (Untyped {}) = False
 
-    getTy (Typed _ t) = Just t
+    getTy (Typed _ _ t) = Just t
     getTy (Untyped {}) = Nothing
 
 transformCDecl :: Name -> ContractDecl Name -> Set (ContractDecl Name)
@@ -101,6 +101,7 @@ transformConstructor contractName cons
           sigContext = mempty,
           sigName = initFunName,
           sigParams = params,
+          sigRetComptime = False,
           sigReturn = Just unit
         }
 
@@ -110,14 +111,15 @@ transformConstructor contractName cons
           sigContext = mempty,
           sigName = "copy_arguments_for_constructor",
           sigParams = mempty,
+          sigRetComptime = False,
           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,
+      [ Let False "res" (Just argsTuple) Nothing,
+        Let False "memoryDataOffset" (Just word) Nothing,
         Asm
           [yulBlock|{
              let programSize := datasize(`deployer`)
@@ -126,7 +128,7 @@ transformConstructor contractName cons
              mstore(64, add(memoryDataOffset, argSize))
              codecopy(memoryDataOffset, programSize, argSize)
           }|],
-        Let "source" (Just (memoryT bytesT)) (Just (memoryE (Var "memoryDataOffset"))),
+        Let False "source" (Just (memoryT bytesT)) (Just (memoryE (Var "memoryDataOffset"))),
         Var "res"
           := Call
             Nothing
@@ -148,13 +150,14 @@ transformConstructor contractName cons
           sigContext = mempty,
           sigName = "start",
           sigParams = mempty,
+          sigRetComptime = False,
           sigReturn = Just unit
         }
     startBody =
       [ Asm [yulBlock|{ mstore(64, memoryguard(128)) }|],
-        Let "conargs" (Just argsTuple) (Just (Call Nothing "copy_arguments_for_constructor" [])),
+        Let False "conargs" (Just argsTuple) (Just (Call Nothing "copy_arguments_for_constructor" [])),
         -- , Match [Var "conargs"] ...
-        Let "fun" Nothing (Just (Var initFunName)),
+        Let False "fun" Nothing (Just (Var initFunName)),
         StmtExp $ Call Nothing "fun" [Var "conargs"],
         Asm
           [yulBlock|{
@@ -168,7 +171,7 @@ transformConstructor contractName cons
     isTyped (Typed {}) = True
     isTyped (Untyped {}) = False
 
-    getTy (Typed _ t) = Just t
+    getTy (Typed _ _ t) = Just t
     getTy (Untyped {}) = Nothing
 
 initFunName :: Name
@@ -180,7 +183,7 @@ mkNameTy cname fname = DataTy (nameTypeName cname fname) [] []
 mkNameInst :: DataTy -> Name -> Instance Name
 mkNameInst (DataTy dname [] []) fname =
   let nameTy = TyCon dname []
-      sig = Signature [] [] "sigStr" [Typed "p" (proxyTy nameTy)] (Just string)
+      sig = Signature [] [] "sigStr" [Typed False "p" (proxyTy nameTy)] False (Just string)
       body = [Return (Lit (StrLit (show fname)))]
    in Instance
         { instDefault = False,

src/Solcore/Desugarer/DecisionTreeCompiler.hs

@@ -88,8 +88,8 @@ instance Compile (FunDef Id) where
 instance Compile (Stmt Id) where
   compile (e1 := e2) =
     (:=) <$> compile e1 <*> compile e2
-  compile (Let v mt me) =
-    Let v mt <$> compile me
+  compile (Let c v mt me) =
+    Let c v mt <$> compile me
   compile (StmtExp e) =
     StmtExp <$> compile e
   compile (Return e) =
@@ -651,8 +651,8 @@ scrutineeType (Indexed earr _) =
           "scrutineeType: index expression scrutinee has no type annotation"
 
 typeOfParam :: Param Id -> Ty
-typeOfParam (Typed i _t) = idType i
-typeOfParam (Untyped i) = idType i
+typeOfParam (Typed _ i _t) = idType i
+typeOfParam (Untyped _ i) = idType i
 
 isVarPat :: Pattern -> Bool
 isVarPat (PVar _) = True

src/Solcore/Desugarer/FieldAccess.hs

@@ -125,7 +125,7 @@ transBody :: NmBody -> ContractEnv -> NmBody
 transBody body cenv = snd $ mapAccumL transStmt cenv body
 
 transStmt :: ContractEnv -> NmStmt -> (ContractEnv, NmStmt)
-transStmt cenv (Let x mty me) = (cenv {ceLocals = Set.insert x cenv.ceLocals}, Let x mty me')
+transStmt cenv (Let c x mty me) = (cenv {ceLocals = Set.insert x cenv.ceLocals}, Let c x mty me')
   where
     me' = flip transRhs cenv <$> me
 transStmt cenv stmt = (cenv, go stmt cenv)

src/Solcore/Desugarer/IndirectCall.hs

@@ -72,8 +72,8 @@ instance Desugar (Constructor Name) where
 instance Desugar (Stmt Name) where
   desugar (lhs := rhs) =
     (:=) <$> desugar lhs <*> desugar rhs
-  desugar (Let n mt me) =
-    Let n mt <$> desugar me
+  desugar (Let c n mt me) =
+    Let c n mt <$> desugar me
   desugar (StmtExp e) =
     StmtExp <$> desugar e
   desugar (Return e) =

src/Solcore/Desugarer/ReplaceFunTypeArgs.hs

@@ -31,12 +31,12 @@ freshTy = do
   pure (n, v)
 
 replace :: Param Name -> ReplaceM (Param Name, [Pred], [Tyvar])
-replace (Untyped n) = pure (Untyped n, [], [])
-replace (Typed n t@(_ :-> _)) =
+replace (Untyped c n) = pure (Untyped c n, [], [])
+replace (Typed c n t@(_ :-> _)) =
   do
     (t1, v) <- freshTy
     let (args, ret) = splitTy t
         invokeArgTy = tupleTyFromList args
         p = InCls invokableName t1 [invokeArgTy, ret]
-    pure (Typed n t1, [p], [v])
-replace (Typed n t) = pure (Typed n t, [], [])
+    pure (Typed c n t1, [p], [v])
+replace (Typed c n t) = pure (Typed c n t, [], [])

src/Solcore/Frontend/Lexer/SolcoreLexer.x

@@ -63,6 +63,7 @@ tokens :-
         <0>    "leave"                           {simpleToken TLeave}
         <0>    "continue"                        {simpleToken TContinue}
         <0>    "break"                           {simpleToken TBreak}
+        <0>    "comptime"                        {simpleToken TComptime}
         <0>    "lam"                             {simpleToken TLam}
         <0>    "assembly"                        {simpleToken TAssembly}
         <0>    "pragma"                          {simpleToken TPragma}
@@ -226,6 +227,7 @@ data Lexeme
   | TNoBoundVariableCondition
   | TBar
   | TThen
+  | TComptime
   | TAt
   | TEOF
   deriving (Eq, Ord, Show)