From b4501b9560b0766aa7b73c4b3397120d325eb1a2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jonathan=20Brachtha=CC=88user?= Date: Tue, 6 Feb 2024 11:46:00 +0100 Subject: [PATCH 01/48] Add vm backend --- koka.cabal | 1 + src/Backend/VM/FromCore.hs | 1306 ++++++++++++++++++++++++++++++++++++ src/Common/Syntax.hs | 9 +- src/Compile/CodeGen.hs | 23 + src/Compile/Options.hs | 3 +- stack.yaml | 1 + 6 files changed, 1338 insertions(+), 5 deletions(-) create mode 100644 src/Backend/VM/FromCore.hs diff --git a/koka.cabal b/koka.cabal index 82c7bd3b4..ef8b0036e 100644 --- a/koka.cabal +++ b/koka.cabal @@ -30,6 +30,7 @@ library Backend.C.ParcReuseSpec Backend.CSharp.FromCore Backend.JavaScript.FromCore + Backend.VM.FromCore Common.ColorScheme Common.Error Common.Failure diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs new file mode 100644 index 000000000..021c7a435 --- /dev/null +++ b/src/Backend/VM/FromCore.hs @@ -0,0 +1,1306 @@ +----------------------------------------------------------------------------- +-- Copyright 2012-2021, Microsoft Research, Daan Leijen, Edsko de Vries. +-- +-- This is free software; you can redistribute it and/or modify it under the +-- terms of the Apache License, Version 2.0. A copy of the License can be +-- found in the LICENSE file at the root of this distribution. +----------------------------------------------------------------------------- + +module Backend.VM.FromCore + ( vmFromCore ) + where + +import Platform.Config(version) +import Lib.Trace +import Control.Applicative hiding (empty) +import Control.Monad +import qualified Control.Monad.Fail as F +import Data.List ( intersperse, partition ) +import Data.Char + +import qualified Data.Set as S + +import Type.Type +import qualified Type.Pretty as Pretty + +import Lib.PPrint +import Common.Name +import Common.NamePrim +import Common.Failure +import Common.Unique +import Common.Syntax + +import Core.Core +import Core.Pretty +import Core.CoreVar + +type CommentDoc = Doc +type ConditionDoc = Doc + + +debug :: Bool +debug = False + +externalNames :: [(TName, Doc)] +externalNames + = [ (conName exprTrue, text "true") + , (conName exprFalse, text "false") + , (TName nameOptionalNone typeOptional, text "undefined") -- ugly but has real performance benefit + ] + +-------------------------------------------------------------------------- +-- Generate JavaScript code from System-F core language +-------------------------------------------------------------------------- + +vmFromCore :: BuildType -> Maybe (Name,Bool) -> [Import] -> Core -> Doc +vmFromCore buildType mbMain imports core + = runAsm (Env moduleName penv externalNames False) (genModule buildType mbMain imports core) + where + moduleName = coreProgName core + penv = Pretty.defaultEnv{ Pretty.context = moduleName, Pretty.fullNames = False } + +genModule :: BuildType -> Maybe (Name,Bool) -> [Import] -> Core -> Asm Doc +genModule buildType mbMain imports core + = do let externs = vcat (concatMap (includeExternal buildType) (coreProgExternals core)) + (tagDefs,defs) = partition isTagDef (coreProgDefs core) + decls0 <- genGroups True tagDefs + decls1 <- genTypeDefs (coreProgTypeDefs core) + decls2 <- genGroups True defs + let -- `imports = coreProgImports core` is not enough due to inlined definitions + (mainEntry) = case mbMain of + Nothing -> (empty) + Just (name,isAsync) + -> ( + (text " " <-> text "// main entry:" <-> + ppName (unqualify name) <.> text "($std_core.id);" -- pass id for possible cps translated main + )) + return $ + vcat ( + [ text "// Koka generated module:" <+> string (show (coreProgName core)) <.> text ", koka version:" <+> string version + , text "\"use strict\";" + , text " " + , text "// imports" + ] + ++ + importDecls + ++ + [ text " " + , text "// externals" + , externs + , text " " + , text "// type declarations" + , decls0 + , decls1 + , text " " + , text "// declarations" + , decls2 + , mainEntry + ]) + where + importDecls :: [Doc] + importDecls + = [text "import * as" <+> dname <+> text "from" <+> squotes (dpath <.> text ".mjs") <.> semi + | (dpath,dname) <- externalImports ++ normalImports] + + normalImports :: [(Doc,Doc)] + normalImports + = [(moduleImport imp, ppModName (importName imp)) | imp <- imports] + + modName = ppModName (coreProgName core) + exportedValues = let f (DefRec xs) = map defName xs + f (DefNonRec x) = [defName x] + in map unqualify $ concatMap f (coreProgDefs core) + exportedConstrs = let f (Synonym _ ) = [] + f (Data info _) = map conInfoName $ -- filter (isPublic . conInfoVis) -- export all for inlined defs + (dataInfoConstrs info) + u (TypeDefGroup xs) = xs + in map unqualify $ concatMap f $ concatMap u (coreProgTypeDefs core) + + isTagDef (DefNonRec def) = isOpenTagName (defName def) + isTagDef _ = False + + externalImports :: [(Doc,Doc)] + externalImports + = concatMap (importExternal buildType) (coreProgExternals core) + +moduleImport :: Import -> Doc +moduleImport imp + = (text (if null (importPackage imp) then "." else importPackage imp) <.> text "/" <.> text (moduleNameToPath (importName imp))) + +includeExternal :: BuildType -> External -> [Doc] +includeExternal buildType ext + = case externalImportLookup (JS JsDefault) buildType "include-inline" ext of + Just content -> [align $ vcat $! map text (lines content)] + _ -> [] + + + +importExternal :: BuildType -> External -> [(Doc,Doc)] +importExternal buildType ext + = case externalImportLookup (JS JsDefault) buildType "library" ext of + Just path -> [(text path, case externalImportLookup (JS JsDefault) buildType "library-id" ext of + Just name -> text name + Nothing -> text path)] + _ -> [] + +--------------------------------------------------------------------------------- +-- Generate javascript statements for value definitions +--------------------------------------------------------------------------------- + +genGroups :: Bool -> [DefGroup] -> Asm Doc +genGroups topLevel groups + = localUnique $ + do docs <- mapM (genGroup topLevel) groups + return (vcat docs) + +genGroup :: Bool -> DefGroup -> Asm Doc +genGroup topLevel group + = case group of + DefRec defs -> do docs <- mapM (genDef topLevel) defs + return (vcat docs) + DefNonRec def -> genDef topLevel def + +genDef :: Bool -> Def -> Asm Doc +genDef topLevel def@(Def name tp expr vis sort inl rng comm) + = do penv <- getPrettyEnv + let resDoc = typeComment (Pretty.ppType penv tp) + defDoc <- do mdoc <- tryFunDef name resDoc expr + case mdoc of + Just doc -> return (if (topLevel) then ppVis vis doc else doc) + Nothing -> do doc <- genStat (ResultAssign name Nothing) expr + return (if (topLevel) + then ppVis vis (text "var" <+> ppName (unqualify name) <.> semi <--> doc) + else doc) + + return $ vcat [ text " " + , if null comm + then empty + else align (vcat (space : map text (lines (trim comm)))) {- already a valid javascript comment -} + , defDoc + ] + where + -- remove final newlines and whitespace + trim s = reverse (dropWhile (`elem` " \n\r\t") (reverse s)) + + +ppVis _ doc = text "export" <+> doc -- always export due to inlined definitions +-- ppVis _ doc = doc + +tryFunDef :: Name -> CommentDoc -> Expr -> Asm (Maybe Doc) +tryFunDef name comment expr + = case expr of + TypeApp e _ -> tryFunDef name comment e + TypeLam _ e -> tryFunDef name comment e + Lam args eff body -> do inStat <- getInStatement + if (inStat) + then return Nothing + else do fun <- genFunDef' name args comment body + return (Just fun) + _ -> return Nothing + where + genFunDef' :: Name -> [TName] -> CommentDoc -> Expr -> Asm Doc + genFunDef' name params comm body + = do let args = map ( ppName . getName ) params + isTailCall = body `isTailCalling` name + bodyDoc <- (if isTailCall then withStatement else id) + (genStat (ResultReturn (Just name) params) body) + return $ text "function" <+> ppName (unqualify name) + <.> tupled args + <+> comm + <+> ( if isTailCall + then tcoBlock bodyDoc + else debugComment ("genFunDef: no tail calls to " ++ show name ++ " found") + <.> block bodyDoc + ) + +--------------------------------------------------------------------------------- +-- Generate value constructors for each defined type +--------------------------------------------------------------------------------- + +genTypeDefs :: TypeDefGroups -> Asm Doc +genTypeDefs groups + = do docs <- mapM (genTypeDefGroup) groups + return (vcat docs) + +genTypeDefGroup :: TypeDefGroup -> Asm Doc +genTypeDefGroup (TypeDefGroup tds) + = do docs <- mapM (genTypeDef) tds + return (vcat docs) + +genTypeDef ::TypeDef -> Asm Doc +genTypeDef (Synonym {}) + = return empty +genTypeDef (Data info isExtend) + = do modName <- getModule + let (dataRepr, conReprs) = getDataRepr info + docs <- mapM ( \(c,repr) -> + do let args = map ppName (map fst (conInfoParams c)) + name <- genName (conInfoName c) + penv <- getPrettyEnv + let singletonValue val + = constdecl <+> name <+> text "=" <+> + text val <.> semi <+> linecomment (Pretty.ppType penv (conInfoType c)) + decl <- if (conInfoName c == nameTrue) + then return (constdecl <+> name <+> text "=" <+> text "true" <.> semi) + else if (conInfoName c == nameFalse) + then return (constdecl <+> name <+> text "=" <+> text "false" <.> semi) + else return $ case repr of + -- special + ConEnum{} + -> constdecl <+> name <+> text "=" <+> int (conTag repr) <.> semi <+> linecomment (Pretty.ppType penv (conInfoType c)) + ConSingleton{} | conInfoName c == nameOptionalNone + -> singletonValue "undefined" + ConSingleton _ DataStructAsMaybe _ _ + -> singletonValue "null" + ConSingleton _ DataAsMaybe _ _ + -> singletonValue "null" + ConSingleton _ DataAsList _ _ + -> singletonValue "null" + -- tagless + ConIso{} -> genConstr penv c repr name args [] + ConSingle{} -> genConstr penv c repr name args [] + ConAsCons{} -> genConstr penv c repr name args [] + ConAsJust{} -> genConstr penv c repr name args [] -- [(tagField, getConTag modName c repr)] + ConStruct{conDataRepr=DataStructAsMaybe} + -> genConstr penv c repr name args [] + -- normal with tag + _ -> genConstr penv c repr name args [(tagField, getConTag modName c repr)] + return (ppVis (conInfoVis c) decl) + ) $ zip (dataInfoConstrs $ info) conReprs + return $ linecomment (text "type" <+> pretty (unqualify (dataInfoName info))) + <-> vcat docs + <-> text "" + where + genConstr penv c repr name args tagFields + = if null args + then debugWrap "genConstr: null fields" + $ constdecl <+> name <+> text "=" <+> object tagFields <.> semi <+> linecomment (Pretty.ppType penv (conInfoType c)) + else debugWrap "genConstr: with fields" + $ text "function" <+> name <.> tupled args <+> comment (Pretty.ppType penv (conInfoType c)) + <+> block ( text "return" <+> + (if (conInfoName c == nameOptional || isConIso repr) then head args + else object (tagFields ++ map (\arg -> (arg, arg)) args)) <.> semi ) + +getConTag modName coninfo repr + = case repr of + ConOpen{} -> -- ppLit (LitString (show (openConTag (conInfoName coninfo)))) + let name = toOpenTagName (conInfoName coninfo) + in ppName (if (qualifier name == modName) then unqualify name else name) + _ -> int (conTag repr) + +openConTag name + = name + +--------------------------------------------------------------------------------- +-- Statements +--------------------------------------------------------------------------------- + +-- | Applies a return context +getResult :: Result -> Doc -> Doc +getResult result doc + = if isEmptyDoc doc + then text "" + else getResultX result (doc,doc) + +getResultX result (puredoc,retdoc) + = case result of + ResultReturn _ _ -> text "return" <+> retdoc <.> semi + ResultAssign n ml -> ( if isWildcard n + then (if (isEmptyDoc puredoc) then puredoc else puredoc <.> semi) + else text "var" <+> ppName (unqualify n) <+> text "=" <+> retdoc <.> semi + ) <-> case ml of + Nothing -> empty + Just l -> text "break" <+> ppName l <.> semi + +tryTailCall :: Result -> Expr -> Asm (Maybe Doc) +tryTailCall result expr + = case expr of + -- Tailcall case 1 + App (Var n info) args | ( case result of + ResultReturn (Just m) _ -> m == getName n && infoArity info == (length args) + _ -> False + ) + -> do let (ResultReturn _ params) = result + stmts <- genOverride params args + return $ Just $ block $ stmts <-> tailcall + + -- Tailcall case 2 + App (TypeApp (Var n info) _) args | ( case result of + ResultReturn (Just m) _ -> m == getName n && infoArity info == (length args) + _ -> False + ) + -> do let (ResultReturn _ params) = result + stmts <- genOverride params args + return $ Just $ block $ stmts <-> tailcall + + _ -> return Nothing + where + -- overriding function arguments carefully + genOverride :: [TName] -> [Expr] -> Asm Doc + genOverride params args + = fmap (debugWrap "genOverride") $ + do (stmts, varNames) <- do args' <- mapM tailCallArg args + bs <- mapM genVarBinding args' + return (unzip bs) + docs1 <- mapM genTName params + docs2 <- mapM genTName varNames + let assigns = map (\(p,a)-> if p == a + then debugComment ("genOverride: skipped overriding `" ++ (show p) ++ "` with itself") + else debugComment ("genOverride: preparing tailcall") <.> p <+> text "=" <+> a <.> semi + ) (zip docs1 docs2) + return $ + linecomment (text "tail call") <-> vcat stmts <-> vcat assigns + + -- if local variables are captured inside a tailcalling function argument, + -- we need to capture it by value (instead of reference since we will overwrite the local variables on a tailcall) + -- we do this by wrapping the argument inside another function application. + tailCallArg :: Expr -> Asm Expr + tailCallArg expr + = let captured = filter (not . isQualified . getName) $ tnamesList $ capturedVar expr + in if (null captured) + then return expr + else -- trace ("Backend.JavaScript.FromCore.tailCall: capture: " ++ show captured ++ ":\n" ++ show expr) $ + do ns <- mapM (newVarName . show) captured + let cnames = [TName cn tp | (cn,TName _ tp) <- zip ns captured] + sub = [(n,Var cn InfoNone) | (n,cn) <- zip captured cnames] + return $ App (Lam cnames typeTotal (sub |~> expr)) [Var arg InfoNone | arg <- captured] + + capturedVar :: Expr -> TNames + capturedVar expr + = case expr of + Lam _ _ _ -> fv expr -- we only care about captures inside a lambda + Let bgs body -> S.unions (capturedVar body : map capturedDefGroup bgs) + Case es bs -> S.unions (map capturedVar es ++ map capturedBranch bs) + App f args -> S.unions (capturedVar f : map capturedVar args) + TypeLam _ e -> capturedVar e + TypeApp e _ -> capturedVar e + _ -> S.empty + + capturedDefGroup bg + = case bg of + DefRec defs -> S.difference (S.unions (map capturedDef defs)) (bv defs) + DefNonRec def-> capturedDef def + + capturedDef def + = capturedVar (defExpr def) + + capturedBranch (Branch pat grds) + = S.difference (S.unions (map capturedGuard grds)) (bv pat) + + capturedGuard (Guard test expr) + = S.union (capturedVar test) (capturedVar expr) + +-- | Generates a statement from an expression by applying a return context (deeply) inside +genStat :: Result -> Expr -> Asm Doc +genStat result expr + = fmap (debugWrap "genStat") $ + {- + case extractExternal expr of + Just (tn,fs,es) + -> do (statDoc, exprDoc) <- genExternalExpr tn fs es + return (statDoc <-> getResult result exprDoc) + Nothing + -> -} + do mdoc <- tryTailCall result expr + case mdoc of + Just doc + -> return doc + Nothing + -> genExprStat result expr + + +genExprStat result expr + = case expr of + -- If expression is inlineable, inline it + _ | isInlineableExpr expr + -> do exprDoc <- genInline expr + return (getResult result exprDoc) + + Case exprs branches + -> do (docs, scrutinees) <- fmap unzip $ mapM (\e-> if isInlineableExpr e && isTypeBool (typeOf e) + then do d <- genInline e + return (text "", d) + else do (sd,vn) <- genVarBinding e + vd <- genTName vn + return (sd, vd) + ) exprs + doc <- genMatch result scrutinees branches + return (vcat docs <-> doc) + + Let groups body + -> do doc1 <- genGroups False groups + doc2 <- genStat result body + return (doc1 <-> doc2) + + -- Handling all other cases + _ -> do (statDoc,exprDoc) <- genExpr expr + return (statDoc <-> getResult result exprDoc) + +-- | Generates a statement for a match expression regarding a given return context +genMatch :: Result -> [Doc] -> [Branch] -> Asm Doc +genMatch result scrutinees branches + = fmap (debugWrap "genMatch") $ do + case branches of + [] -> fail ("Backend.JavaScript.FromCore.genMatch: no branch in match statement: " ++ show(scrutinees)) + [b] -> fmap snd $ genBranch True result scrutinees b + + -- Special handling of return related cases - would be nice to get rid of it + [ Branch [p1] [Guard t1 (App (Var tn _) [r1])], Branch [p2] [Guard t2 e2] ] + | getName tn == nameReturn && + isPat True p1 && isPat False p2 && + isExprTrue t1 && isExprTrue t2 + -> case e2 of + App (Var tn _) [r2] + | getName tn == nameReturn + -> do (stmts1, expr1) <- genExpr r1 + (stmts2, expr2) <- genExpr r2 + return $ text "if" <.> parens (head scrutinees) <+> block (stmts1 <-> text "return" <+> expr1 <.> semi) + <-> text "else" <+> block (stmts2 <-> text "return" <+> expr2 <.> semi) + _ -> do (stmts1,expr1) <- genExpr r1 + (stmts2,expr2) <- genExpr e2 + return $ + (text "if" <.> parens (head scrutinees) <+> block (stmts1 <-> text "return" <+> expr1 <.> semi)) + <--> + (stmts2 <-> getResultX result (if (isExprUnit e2) then text "" else expr2,expr2)) + + [Branch [p1] [Guard t1 e1], Branch [p2] [Guard t2 e2]] + | isExprTrue t1 + && isExprTrue t2 + && isInlineableExpr e1 + && isInlineableExpr e2 + -> do modName <- getModule + let nameDoc = head scrutinees + let test = genTest modName (nameDoc, p1) + if (isExprTrue e1 && isExprFalse e2) + then return $ getResult result $ parens (conjunction test) + else do doc1 <- withNameSubstitutions (getSubstitutions nameDoc p1) (genInline e1) + doc2 <- withNameSubstitutions (getSubstitutions nameDoc p2) (genInline e2) + return $ debugWrap "genMatch: conditional expression" + $ getResult result + $ parens (conjunction test) <+> text "?" <+> doc1 <+> text ":" <+> doc2 + + bs + | all (\b-> length (branchGuards b) == 1) bs + && all (\b->isExprTrue $ guardTest $ head $ branchGuards b) bs + -> do xs <- mapM (withStatement . genBranch True result scrutinees) bs + return $ debugWrap "genMatch: guard-free case" + $ hcat ( map (\(conds,d)-> text "if" <+> parens (conjunction conds) + <+> block d <-> text "else " + ) (init xs) + ) + <.> block (snd (last xs)) + + _ -> do (labelF, result') <- case result of + ResultReturn _ _ -> return (id, result) + ResultAssign n (Just _) -> return (id, result) -- wohoo, we can jump out from deep in! + ResultAssign n Nothing -> return ( \d-> text "match: " <.> block d + , ResultAssign n (Just $ newName "match") + ) + bs <- mapM (withStatement . genBranch False result' scrutinees) (init branches) + b <- (withStatement . genBranch True result' scrutinees) (last branches) + let ds = map (\(cds,stmts)-> if null cds + then stmts + else text "if" <+> parens (conjunction cds) + <+> block stmts + ) bs + let d = snd b + return $ debugWrap "genMatch: regular case" + $ labelF (vcat ds <-> d) + where + -- | Generates a statement for a branch with given return context + genBranch :: Bool -> Result -> [Doc] -> Branch -> Asm ([ConditionDoc], Doc) + -- Regular catch-all branch generation + genBranch lastBranch result tnDocs branch@(Branch patterns guards) + = do modName <- getModule + let substs = concatMap (uncurry getSubstitutions) (zip tnDocs patterns) + let conditions = concatMap (genTest modName) (zip tnDocs patterns) + let se = withNameSubstitutions substs + + gs <- mapM (se . genGuard False result) (init guards) + g <- (se . genGuard lastBranch result) (last guards) + return (conditions, debugWrap ("genBranch: " ++ show substs) $ vcat gs <-> g) + + getSubstitutions :: Doc -> Pattern -> [(TName, Doc)] + getSubstitutions nameDoc pat + = case pat of + PatCon tn args repr _ _ _ info skip + -> -- trace ("pattern: " ++ show tn ++ ": " ++ show args ++ ", " ++ show info) $ + concatMap (\(pat',fn)-> getSubstitutions + (nameDoc <.> (if (getName tn == nameOptional || isConIso repr) then empty else (text "." <.> fn))) + pat' + ) + (zip args (map (ppName . fst) (conInfoParams info)) ) + PatVar tn pat' -> (tn, nameDoc):(getSubstitutions nameDoc pat') + PatWild -> [] + PatLit lit -> [] + + genGuard :: Bool -> Result -> Guard -> Asm Doc + genGuard lastBranchLastGuard result (Guard t expr) + = do (testSt, testE) <- genExpr t + let result' = case result of + ResultAssign n _ | lastBranchLastGuard -> ResultAssign n Nothing + _ -> result + exprSt <- genStat result' expr + return $ if isExprTrue t + then exprSt + else testSt <-> text "if" <+> parens testE <.> block exprSt + + -- | Generates a list of boolish expression for matching the pattern + genTest :: Name -> (Doc, Pattern) -> [Doc] + genTest modName (scrutinee,pattern) + = case pattern of + PatWild -> [] + PatVar _ pat + -> genTest modName (scrutinee,pat) + PatLit lit + -> [scrutinee <+> text "===" <+> ppLit lit] + PatCon tn fields repr _ _ _ info skip --TODO: skip test ? + | getName tn == nameTrue + -> [scrutinee] + | getName tn == nameFalse + -> [text "!" <.> scrutinee] + | otherwise + -> case repr of + -- special + ConEnum _ _ _ tag + -> [debugWrap "genTest: enum" $ scrutinee <+> text "===" <+> int tag] + ConSingleton{} + | getName tn == nameOptionalNone + -> [debugWrap "genTest: optional none" $ scrutinee <+> text "=== undefined"] + ConSingleton _ DataStructAsMaybe _ _ + -> [debugWrap "genTest: maybe like nothing" $ scrutinee <+> text "=== null"] -- <+> ppName (getName tn)] + ConSingleton _ DataAsMaybe _ _ + -> [debugWrap "genTest: maybe like nothing" $ scrutinee <+> text "=== null"] -- <+> ppName (getName tn)] + ConSingleton _ DataAsList _ _ + -> [debugWrap "genTest: list like nil" $ scrutinee <+> text "=== null"] -- <+> ppName (getName tn)] + ConSingleton{conTag=tag} + -> [debugWrap "genTest: singleton" $ scrutinee <.> dot <.> tagField <+> text "===" <+> int tag] + ConSingle{} -- always succeeds, but need to test the fields + -> concatMap + (\(field,fieldName) -> genTest modName ( + debugWrap ("genTest: single: " ++ show field ++ " -> " ++ show fieldName) $ + scrutinee <.> dot <.> fieldName, field) ) + (zip fields (map (ppName . fst) (conInfoParams info)) ) + + ConIso{} -- always success + -> [] + ConStruct{conDataRepr=DataStructAsMaybe} + | getName tn == nameOptional + -> [scrutinee <+> text "!== undefined"] ++ concatMap (\field -> genTest modName (scrutinee,field) ) fields + | otherwise + -> let conTest = debugWrap "genTest: asJust" $ scrutinee <+> text "!== null" + fieldTests = concatMap + (\(field,fieldName) -> genTest modName (scrutinee <.> dot <.> fieldName, field) ) + (zip fields (map (ppName . fst) (conInfoParams info)) ) + in (conTest:fieldTests) + ConAsJust{} + | getName tn == nameOptional + -> [scrutinee <+> text "!== undefined"] ++ concatMap (\field -> genTest modName (scrutinee,field) ) fields + | otherwise + -> let conTest = debugWrap "genTest: asJust" $ scrutinee <+> text "!== null" + fieldTests = concatMap + (\(field,fieldName) -> genTest modName (scrutinee <.> dot <.> fieldName, field) ) + (zip fields (map (ppName . fst) (conInfoParams info)) ) + in (conTest:fieldTests) + ConAsCons{} + -> let conTest = debugWrap "genTest: asCons" $ scrutinee <+> text "!== null" + fieldTests = concatMap + (\(field,fieldName) -> genTest modName (scrutinee <.> dot <.> fieldName, field) ) + (zip fields (map (ppName . fst) (conInfoParams info)) ) + in (conTest:fieldTests) + _ -> let conTest = debugWrap "genTest: normal" $ scrutinee <.> dot <.> tagField <+> text "===" <+> getConTag modName info repr + fieldTests = concatMap + (\(field,fieldName) -> genTest modName (debugWrap ("genTest: normal: " ++ show field ++ " -> " ++ show fieldName) $ scrutinee <.> dot <.> fieldName, field) ) + ( zip fields (map (ppName . fst) (conInfoParams info)) ) + in (conTest:fieldTests) + + -- | Takes a list of docs and concatenates them with logical and + conjunction :: [Doc] -> Doc + conjunction [] + = text "true" + conjunction docs + = hcat (intersperse (text " && ") docs) + +--------------------------------------------------------------------------------- +-- Expressions that produce statements on their way +--------------------------------------------------------------------------------- + +-- | Generates javascript statements and a javascript expression from core expression +genExpr :: Expr -> Asm (Doc,Doc) +genExpr expr + = -- trace ("genExpr: " ++ show expr) $ + case expr of + -- check whether the expression is pure an can be inlined + _ | isInlineableExpr expr + -> do doc <- genInline expr + return (empty,doc) + + TypeApp e _ -> genExpr e + TypeLam _ e -> genExpr e + + -- handle not inlineable cases + App (TypeApp (Con name repr) _) [arg] | getName name == nameOptional || isConIso repr + -> genExpr arg + App (Con _ repr) [arg] | isConIso repr + -> genExpr arg + App (Var tname _) [Lit (LitInt i)] | getName tname == nameByte && (i >= 0 && i < 256) + -> return (empty, pretty i) + App (Var tname _) [Lit (LitInt i)] | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT] && isSmallInt i + -> return (empty, pretty i) + App (Var tname _) [Lit (LitInt i)] | getName tname `elem` [nameInt64,nameIntPtrT] && isSmallInt i + -> return (empty, pretty i <.> text "n") + + -- special: .cctx-field-addr-of: create a tuple with the object and the field name as a string + App (TypeApp (Var cfieldOf _) [_]) [Var con _, Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameFieldAddrOf + -> do conDoc <- genTName con + return (empty,text "{obj:" <+> conDoc <.> text ", field_name: \"" <.> ppName (unqualify (readQualified fieldName)) <.> text "\"}") + + App f args + -> case extractList expr of + Just (xs,tl) -> genList xs tl + Nothing -> case extractExtern f of + Just (tname,formats) + -> case args of + [Lit (LitInt i)] | getName tname == nameByte && i >= 0 && i < 256 + -> return (empty,pretty i) + [Lit (LitInt i)] | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT] && isSmallInt i + -> return (empty,pretty i) + [Lit (LitInt i)] | getName tname `elem` [nameInt64,nameIntPtrT] && isSmallInt i + -> return (empty,pretty i <.> text "n") + _ -> -- genInlineExternal tname formats argDocs + do (decls,argDocs) <- genExprs args + (edecls,doc) <- genExprExternal tname formats argDocs + if (getName tname == nameReturn) + then return (vcat (decls ++ edecls ++ [doc <.> semi]), text "") + else return (vcat (decls ++ edecls), doc) + Nothing + -> do lsDecls <- genExprs (f:trimOptionalArgs args) + let (decls,fdoc:docs) = lsDecls + return (vcat decls, fdoc <.> tupled docs) + + Let groups body + -> do decls1 <- genGroups False groups + (decls2,doc) <- genExpr body + return (decls1 <-> decls2, doc) + + Case _ _ + -> do (doc, tname) <- genVarBinding expr + nameDoc <- genTName tname + return (doc, nameDoc) + + _ -> failure ("JavaScript.FromCore.genExpr: invalid expression:\n" ++ show expr) + +extractList :: Expr -> Maybe ([Expr],Expr) +extractList e + = let (elems,tl) = extract [] e + in if (length elems > 10) -- only use inlined array for larger lists + then Just (elems,tl) + else Nothing + where + extract acc expr + = case expr of + App (TypeApp (Con name info) _) [hd,tl] | getName name == nameCons + -> extract (hd:acc) tl + _ -> (reverse acc, expr) + +genList :: [Expr] -> Expr -> Asm (Doc,Doc) +genList elems tl + = do (decls,docs) <- genExprs elems + (tdecl,tdoc) <- genExpr tl + return (vcat (decls ++ [tdecl]), text "$std_core_vector.vlist" <.> tupled [list docs, tdoc]) + +{- +genExternalExpr :: TName -> String -> [Expr] -> Asm (Doc,Doc) +genExternalExpr tname format args + | getName tname == nameReturn + = do (statDoc,exprDoc) <- genExpr (head args) + return (statDoc <-> text "return" <+> exprDoc <.> semi <.> debugComment "premature return statement (2)" + , text "") -- emptyness of doc is important! no other way to tell to not generate assignment/return/whatever! + | otherwise + = do (statDocs,argDocs) <- genExprs args + doc <- genExternal tname format argDocs + return ( debugComment "" <.> vcat statDocs <.> debugComment "" + , debugComment "" <.> doc <.> debugComment "" + ) +-} + +genExprs :: [Expr] -> Asm ([Doc],[Doc]) +genExprs exprs + = do xs <- mapM genExpr exprs + return (unzip xs) + +-- | Introduces an additional let binding in core if necessary +-- The expression in the result is guaranteed to be a Var afterwards +genVarBinding :: Expr -> Asm (Doc, TName) +genVarBinding expr + = case expr of + Var tn _ -> return $ (empty, tn) + _ -> do name <- newVarName "x" + doc <- genStat (ResultAssign name Nothing) expr + return ( doc, TName name (typeOf expr) ) + +--------------------------------------------------------------------------------- +-- Pure expressions +--------------------------------------------------------------------------------- + +genPure :: Expr -> Asm Doc +genPure expr + = case expr of + TypeApp e _ -> genPure e + TypeLam _ e -> genPure e + Var name (InfoExternal formats) + -> genWrapExternal name formats -- unapplied inlined external: wrap as function + Var name info + -> genTName name + Con name repr + -> genTName name + Lit l + -> return $ ppLit l + Lam params eff body + -> do args <- mapM genCommentTName params + bodyDoc <- genStat (ResultReturn Nothing params) body + return (text "function" <.> tupled args <+> block bodyDoc) + _ -> failure ("JavaScript.FromCore.genPure: invalid expression:\n" ++ show expr) + +isPat :: Bool -> Pattern -> Bool +isPat b q + = case q of + PatWild -> False + PatLit _ -> False + PatVar _ q' -> isPat b q' + PatCon {} -> getName (patConName q) == if b then nameTrue else nameFalse + +-- | Generates an effect-free javasript expression +-- NOTE: Throws an error if expression is not guaranteed to be effectfree +genInline :: Expr -> Asm Doc +genInline expr + = case expr of + _ | isPureExpr expr -> genPure expr + TypeLam _ e -> genInline e + TypeApp e _ -> genInline e + App (TypeApp (Con name repr) _) [arg] | getName name == nameOptional || isConIso repr + -> genInline arg + App (Con _ repr) [arg] | isConIso repr + -> genInline arg + App f args + -> do argDocs <- mapM genInline (trimOptionalArgs args) + case extractExtern f of + Just (tname,formats) + -> case args of + [Lit (LitInt i)] | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT] && isSmallInt i + -> return (pretty i) + [Lit (LitInt i)] | getName tname `elem` [nameInt64,nameIntPtrT] && isSmallInt i + -> return (pretty i <.> text "n") + _ -> genInlineExternal tname formats argDocs + Nothing + -> case (f,args) of + ((Var tname _),[Lit (LitInt i)]) | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT] && isSmallInt i + -> return (pretty i) + ((Var tname _),[Lit (LitInt i)]) | getName tname `elem` [nameInt64,nameIntPtrT] && isSmallInt i + -> return (pretty i <.> text "n") + _ -> do fdoc <- genInline f + return (fdoc <.> tupled argDocs) + + _ -> failure ("JavaScript.FromCore.genInline: invalid expression:\n" ++ show expr) + +extractExtern :: Expr -> Maybe (TName,[(Target,String)]) +extractExtern expr + = case expr of + TypeApp (Var tname (InfoExternal formats)) targs -> Just (tname,formats) + Var tname (InfoExternal formats) -> Just (tname,formats) + _ -> Nothing + +-- not fully applied external gets wrapped in a function +genWrapExternal :: TName -> [(Target,String)] -> Asm Doc +genWrapExternal tname formats + = do let n = snd (getTypeArities (typeOf tname)) + vs <- genVarNames n + (decls,doc) <- genExprExternal tname formats vs + return $ parens (text "function" <.> tupled vs <+> block (vcat (decls ++ [text "return" <+> doc <.> semi]))) + +-- inlined external sometimes needs wrapping in a applied function block +genInlineExternal :: TName -> [(Target,String)] -> [Doc] -> Asm Doc +genInlineExternal tname formats argDocs + = do (decls,doc) <- genExprExternal tname formats argDocs + if (null decls) + then return doc + else return $ parens $ parens (text "function()" <+> block (vcat (decls ++ [text "return" <+> doc <.> semi]))) <.> text "()" + +-- generate external: needs to add try blocks for primitives that can throw exceptions +genExprExternal :: TName -> [(Target,String)] -> [Doc] -> Asm ([Doc],Doc) +genExprExternal tname formats argDocs0 + = do (decls,doc) <- genExprExternalPrim tname formats argDocs0 + case splitFunType (typeOf tname) of + Nothing -> return (decls,doc) + Just (pars,eff,res) + -> let (ls,tl) = extractOrderedEffect eff + in case filter (\l -> labelName l == nameTpPartial) ls of + [] -> return (decls,doc) + _ -> -- has an exception type, wrap it in a try handler + let try = parens $ + parens (text "function()" <+> block (vcat ( + [text "try" <+> block (vcat (decls ++ [text "return" <+> doc <.> semi])) + ,text "catch(_err){ return $std_core._throw_exception(_err); }"] + ))) + <.> text "()" + in return ([],try) + +-- special case: .cctx-hole-create +genExprExternalPrim :: TName -> [(Target,String)] -> [Doc] -> Asm ([Doc],Doc) +genExprExternalPrim tname formats [] | getName tname == nameCCtxHoleCreate + = return ([],text "undefined") + +{- +-- special case: cfield-set (field is implemented as {value:, field:}) +genExprExternalPrim tname formats [accDoc,resDoc] | getName tname == nameCFieldSet + = return ([], tupled [accDoc <.> text ".value[" <.> accDoc <.> text ".field] =" <+> resDoc, text "$std_core_types._Unit_"]) +-} + +-- normal external +genExprExternalPrim tname formats argDocs0 + = let name = getName tname + format = getFormat tname formats + argDocs = map (\argDoc -> if (all (\c -> isAlphaNum c || c == '_') (asString argDoc)) then argDoc else parens argDoc) argDocs0 + in return $ case map (\fmt -> ppExternalF name fmt argDocs) $ lines format of + [] -> ([],empty) + ds -> (init ds, last ds) + where + ppExternalF :: Name -> String -> [Doc] -> Doc + ppExternalF name [] args + = empty + ppExternalF name k@('\\':'#':xs) args + = char '#' <.> ppExternalF name xs args + ppExternalF name k@('#':'#':xs) args + = failure ("Backend.JavaScript.FromCore: type arguments in javascript external in: " ++ show tname) + ppExternalF name k@('#':y:xs) args + = if y `elem` ['1'..'9'] + then (let n = length args + i = fromEnum y - fromEnum '1' + in assertion ("illegal index in external: " ++ show tname ++ "("++k++"): index: " ++ show i) (i < n) $ + (args!!i) <.> ppExternalF name xs args) + else char y <.> ppExternalF name xs args + ppExternalF name (x:xs) args + = char x <.> ppExternalF name xs args + +getFormat :: TName -> [(Target,String)] -> String +getFormat tname formats + = case lookupTarget (JS JsDefault) formats of -- TODO: pass specific target from the flags + Nothing -> -- failure ("backend does not support external in " ++ show tname ++ ": " ++ show formats) + trace( "warning: backend does not support external in " ++ show tname ) $ + ("$std_core._unsupported_external(\"" ++ (show tname) ++ "\")") + Just s -> s + +genDefName :: TName -> Asm Doc +genDefName tname + = return (ppName (unqualify (getName tname))) + +genTName :: TName -> Asm Doc +genTName tname + = do env <- getEnv + case lookup tname (substEnv env) of + Nothing -> genName (getName tname) + Just d -> return d + +genName :: Name -> Asm Doc +genName name + = if (isQualified name) + then do modname <- getModule + if (qualifier name == modname) + then return (ppName (unqualify name)) + else return (ppName name) + else return (ppName name) + +genVarName :: String -> Asm Doc +genVarName s = do n <- newVarName s + return $ ppName n + +-- | Generates `i` fresh variables and delivers them as `Doc` right away +genVarNames :: Int -> Asm [Doc] +genVarNames i = do ns <- newVarNames i + return $ map ppName ns + +-- | Generate a name with its type in comments +genCommentTName :: TName -> Asm Doc +genCommentTName (TName n t) + = do env <- getPrettyEnv + return $ ppName n <+> comment (Pretty.ppType env t ) + +trimOptionalArgs args + = reverse (dropWhile isOptionalNone (reverse args)) + where + isOptionalNone arg + = case arg of + TypeApp (Con tname _) _ -> getName tname == nameOptionalNone + _ -> False + +--------------------------------------------------------------------------------- +-- Classification +--------------------------------------------------------------------------------- + +extractExternal :: Expr -> Maybe (TName, String, [Expr]) +extractExternal expr + = case expr of + App (TypeApp (Var tname (InfoExternal formats)) targs) args + -> Just (tname, format tname formats, args) + App var@(Var tname (InfoExternal formats)) args + -> Just (tname, format tname formats, args) + _ -> Nothing + where + format tn fs + = case lookupTarget (JS JsDefault) fs of -- TODO: pass real target from flags + Nothing -> failure ("backend does not support external in " ++ show tn ++ show fs) + Just s -> s + +isFunExpr :: Expr -> Bool +isFunExpr expr + = case expr of + TypeApp e _ -> isFunExpr e + TypeLam _ e -> isFunExpr e + Lam args eff body -> True + _ -> False + +isInlineableExpr :: Expr -> Bool +isInlineableExpr expr + = case expr of + TypeApp expr _ -> isInlineableExpr expr + TypeLam _ expr -> isInlineableExpr expr + App (Var _ (InfoExternal _)) args -> all isPureExpr args + {- + -- TODO: comment out for now as it may prevent a tailcall if inlined + App f args -> -- trace ("isInlineable f: " ++ show f) $ + isPureExpr f && all isPureExpr args + -- all isInlineableExpr (f:args) + && not (isFunExpr f) -- avoid `fun() {}(a,b,c)` ! + -- && getParamArityExpr f == length args + -} + _ -> isPureExpr expr + +isPureExpr :: Expr -> Bool +isPureExpr expr + = case expr of + TypeApp expr _ -> isPureExpr expr + TypeLam _ expr -> isPureExpr expr + Var n (InfoConField{}) -> False + Var n _ | getName n == nameReturn -> False -- make sure return will never be inlined + | otherwise -> True + Con _ _ -> True + Lit _ -> True + Lam _ _ _ -> True + _ -> False + + +isTailCalling :: Expr -> Name -> Bool +isTailCalling expr n + = case expr of + TypeApp expr _ -> expr `isTailCalling` n -- trivial + TypeLam _ expr -> expr `isTailCalling` n -- trivial + Lam _ _ _ -> False -- lambda body is a new context, can't tailcall + Var _ _ -> False -- a variable is not a call + Con _ _ -> False -- a constructor is not a call + Lit _ -> False -- a literal is not a call + App (Var tn info) args | getName tn == n -- direct application can be a tail call + -> infoArity info == length args + App (TypeApp (Var tn info) _) args | getName tn == n -- tailcalled function might be polymorphic and is applied to types before + -> infoArity info == length args + App (Var tn _) [e] | getName tn == nameReturn -- a return statement is transparent in terms of tail calling + -> e `isTailCalling` n + App _ _ -> False -- other applications don't apply + Let _ e -> e `isTailCalling` n -- tail calls can only happen in the actual body + Case _ bs -> any f1 bs -- match statement get analyzed in depth + where + f1 (Branch _ gs) = any f2 gs -- does any of the guards tailcall? + f2 (Guard _ e) = e `isTailCalling` n -- does the guarded expression tailcall? + +--------------------------------------------------------------------------------- +-- The assembly monad +--------------------------------------------------------------------------------- + +newtype Asm a = Asm { unAsm :: Env -> St -> (a, St)} + +instance Functor Asm where + fmap f (Asm a) = Asm (\env st -> case a env st of + (x,st') -> (f x, st')) + +instance Applicative Asm where + pure x = Asm (\env st -> (x,st)) + (<*>) = ap + +instance Monad Asm where + -- return = pure + (Asm a) >>= f = Asm (\env st -> case a env st of + (x,st1) -> case f x of + Asm b -> b env st1) +instance F.MonadFail Asm where + fail = failure + +runAsm :: Env -> Asm Doc -> Doc +runAsm initEnv (Asm asm) + = case asm initEnv initSt of + (doc,st) -> doc + +data St = St { uniq :: Int + } + +data Env = Env { moduleName :: Name -- | current module + , prettyEnv :: Pretty.Env -- | for printing nice types + , substEnv :: [(TName, Doc)] -- | substituting names + , inStatement :: Bool -- | for generating correct function declarations in strict mode + } + +data Result = ResultReturn (Maybe Name) [TName] -- first field carries function name if not anonymous and second the arguments which are always known + | ResultAssign Name (Maybe Name) -- variable name and optional label to break + +initSt = St 0 + +instance HasUnique Asm where + updateUnique f + = Asm (\env st -> (uniq st, st{ uniq = f (uniq st)})) + +updateSt f + = Asm (\env st -> (st,f st)) + +getSt + = updateSt id + +setSt st + = updateSt (const st) + +getEnv + = Asm (\env st -> (env, st)) + +withEnv f (Asm asm) + = Asm (\env st -> asm (f env) st) + +localUnique asm + = do u <- updateUnique id + x <- asm + setUnique u + return x + +newVarName :: String -> Asm Name +newVarName s + = do u <- unique + return (newName ("@" ++ s ++ show u)) + +newVarNames :: Int -> Asm [Name] +newVarNames 0 = return [] +newVarNames i + = do n <- newVarName "x" + ns <- newVarNames (i - 1) + return (n:ns) + +getModule :: Asm Name +getModule + = do env <- getEnv + return (moduleName env) + +getPrettyEnv :: Asm Pretty.Env +getPrettyEnv + = do env <- getEnv + return (prettyEnv env) + +withTypeVars :: [TypeVar] -> Asm a -> Asm a +withTypeVars vars asm + = withEnv (\env -> env{ prettyEnv = Pretty.niceEnv (prettyEnv env) vars }) asm + +withNameSubstitutions :: [(TName, Doc)] -> Asm a -> Asm a +withNameSubstitutions subs asm + = withEnv (\env -> env{ substEnv = subs ++ substEnv env }) asm + +withStatement :: Asm a -> Asm a +withStatement asm + = withEnv (\env -> env{ inStatement = True }) asm + +getInStatement :: Asm Bool +getInStatement + = do env <- getEnv + return (inStatement env) + +--------------------------------------------------------------------------------- +-- Pretty printing +--------------------------------------------------------------------------------- + + +ppLit :: Lit -> Doc +ppLit lit + = case lit of + LitInt i -> if (isSmallInt(i)) + then pretty i + else ppName nameIntConst <.> parens (pretty i <.> text "n") + LitChar c -> text ("0x" ++ showHex 4 (fromEnum c)) + LitFloat d -> text (showsPrec 20 d "") + LitString s -> dquotes (hcat (map escape s)) + where + escape c + = if (c < ' ') + then (if (c=='\n') then text "\\n" + else if (c == '\r') then text "\\r" + else if (c == '\t') then text "\\t" + else text "\\u" <.> text (showHex 4 (fromEnum c))) + else if (c <= '~') + then (if (c == '\"') then text "\\\"" + else if (c=='\'') then text "\\'" + else if (c=='\\') then text "\\\\" + else char c) + else if (fromEnum c <= 0xFFFF) + then text "\\u" <.> text (showHex 4 (fromEnum c)) + else if (fromEnum c > 0x10FFFF) + then text "\\uFFFD" -- error instead? + else let code = fromEnum c - 0x10000 + hi = (code `div` 0x0400) + 0xD800 + lo = (code `mod` 0x0400) + 0xDC00 + in text ("\\u" ++ showHex 4 hi ++ "\\u" ++ showHex 4 lo) + +isSmallLitInt expr + = case expr of + Lit (LitInt i) -> isSmallInt i + _ -> False + +isSmallInt i = (i > minSmallInt && i < maxSmallInt) + +maxSmallInt, minSmallInt :: Integer +maxSmallInt = 9007199254740991 -- 2^53 - 1 +minSmallInt = -maxSmallInt + +ppName :: Name -> Doc +ppName name + = if isQualified name + then ppModName (qualifier name) <.> dot <.> encode False (unqualify name) + else encode False name + +ppQName :: Name -> Name -> Doc +ppQName modName name + = if (modName == qualifier name) -- We need to qualify always since otherwise we may clash with local variables. i.e. fun f( x : int ) { Main.x( x ) } + then ppName (unqualify name) + else ppName name + +ppModName :: Name -> Doc +ppModName name + = text "$" <.> encode True (name) + +encode :: Bool -> Name -> Doc +encode isModule name + = let s = show name + in if (isReserved s) + then text ('$' : s) + else text ( (asciiEncode isModule s)) + +isReserved :: String -> Bool +isReserved s + = if (not $ null s) && (head s == 'T') && all isDigit (tail s) + then True + else s `S.member` reserved + +reserved :: S.Set String +reserved + = S.fromList $ -- JavaScript pseudo-keywords + [ "prototype" + , "toString" + , "arguments" + , "eval" + ] + ++ -- word literals + [ "null" + , "Infinity" + , "NaN" + ] + ++ -- JavaScript keywords + [ "async" + , "await" + , "break" + , "case" + , "catch" + , "continue" + , "const" + , "debugger" + , "default" + , "delete" + , "do" + , "else" + , "finally" + , "for" + , "function" + , "if" + , "in" + , "instanceof" + , "new" + , "return" + , "switch" + , "this" + , "throw" + , "try" + , "typeof" + , "var" + , "void" + , "while" + , "with" + , "yield" + ] + ++ -- reserved for future use + [ "class" + , "enum" + , "export" + , "extends" + , "import" + , "super" + ] + ++ -- special globals + [ "window" + , "document" + , "process" + , "exports" + , "module" + , "Date" + , "Error" + ] + +block :: Doc -> Doc +block doc + = text "{" <--> tab doc <--> text "}" + + +tcoBlock :: Doc -> Doc +tcoBlock doc + = text "{ tailcall: while(1)" <-> + text "{" <--> tab ( doc ) <--> text "}}" + +tailcall :: Doc +tailcall = text "continue tailcall;" + +object :: [(Doc, Doc)] -> Doc +object xs + = text "{" <+> hcat ( punctuate (comma <.> space) (map f xs) ) <+> text "}" + where + f (d1, d2) = d1 <.> colon <+> d2 + +tab :: Doc -> Doc +tab doc + = indent 2 doc + +typeComment = comment + +comment :: Doc -> Doc +comment d + = text "/*" <+> d <+> text "*/ " + +linecomment :: Doc -> Doc +linecomment d + = text "//" <+> d + +debugComment :: String -> Doc +debugComment s + = if debug + then comment (text s) + else empty + +debugWrap :: String -> Doc -> Doc +debugWrap s d + = if debug + then debugComment ("<" ++ s ++ ">") <-> tab d <-> debugComment ("") + else d + +tagField :: Doc +tagField = text "_tag" + +constdecl :: Doc +constdecl = text "const" diff --git a/src/Common/Syntax.hs b/src/Common/Syntax.hs index 69192e31d..b6de2b918 100644 --- a/src/Common/Syntax.hs +++ b/src/Common/Syntax.hs @@ -42,7 +42,7 @@ import Data.List(intersperse) data JsTarget = JsDefault | JsNode | JsWeb deriving (Eq,Ord) data CTarget = CDefault | LibC | Wasm | WasmJs | WasmWeb deriving (Eq,Ord) -data Target = CS | JS !JsTarget| C !CTarget | Default deriving (Eq,Ord) +data Target = CS | JS !JsTarget| C !CTarget | VM | Default deriving (Eq,Ord) isTargetC (C _) = True isTargetC _ = False @@ -50,6 +50,9 @@ isTargetC _ = False isTargetJS (JS _) = True isTargetJS _ = False +isTargetVM VM = True +isTargetVM _ = False + isTargetWasm :: Target -> Bool isTargetWasm target = case target of @@ -70,6 +73,7 @@ instance Show Target where C WasmWeb-> "wasmweb" C LibC -> "libc" C _ -> "c" + VM -> "vm" Default -> "" data Platform = Platform{ sizePtr :: !Int -- sizeof(intptr_t) @@ -423,6 +427,3 @@ instance Show Fip where showTail True = "tail " showTail _ = " " - - - diff --git a/src/Compile/CodeGen.hs b/src/Compile/CodeGen.hs index 833051f05..e7dee69d6 100644 --- a/src/Compile/CodeGen.hs +++ b/src/Compile/CodeGen.hs @@ -42,6 +42,7 @@ import Core.Borrowed( Borrowed ) import Backend.CSharp.FromCore ( csharpFromCore ) import Backend.JavaScript.FromCore( javascriptFromCore ) import Backend.C.FromCore ( cFromCore ) +import Backend.VM.FromCore ( vmFromCore ) import Compile.Options import Compile.Module( Definitions(..), Module(..), modCoreImports ) @@ -142,6 +143,7 @@ codeGen term flags sequential newtypes borrowed kgamma gamma entry imported mod backend = case target flags of CS -> codeGenCS JS _ -> codeGenJS + VM -> codeGenVM _ -> {- let -- for Perceus (Parc) we analyze types inside abstract types and thus need -- access to all defined types; here we freshly extract all type definitions from all @@ -261,6 +263,27 @@ codeGenJS term flags sequential entry outBase core return (\_ -> return (LinkExe outjs (runCommand term flags [node flags,"--stack-size=" ++ show stksize,outjs]))) +{--------------------------------------------------------------- + VM backend +---------------------------------------------------------------} + +codeGenVM :: Terminal -> Flags -> (IO () -> IO ()) -> Maybe (Name,Type) -> FilePath -> Core.Core -> IO Link +codeGenVM term flags sequential entry outBase core + = do let outjs = outBase ++ ".mcore.json" + outName fname = joinPath (dirname outBase) fname + -- extractImport m = Core.Import (modName m) "" {- (modPackageQName m) -} Core.ImportUser Public "" + js = vmFromCore (buildType flags) mbEntry (Core.coreProgImports core) core + mbEntry = case entry of + Just (name,tp) -> Just (name,isAsyncFunction tp) + _ -> Nothing + termTrace term ( "generate vm: " ++ outjs ) + writeDocW 80 outjs js + when (showAsmJS flags) (termInfo term js) + + case mbEntry of + Nothing -> return noLink + Just _ -> + return (\_ -> return (LinkExe outjs (runCommand term flags ["???",outjs]))) {--------------------------------------------------------------- C backend diff --git a/src/Compile/Options.hs b/src/Compile/Options.hs index 98aa31498..fe6ab0b62 100644 --- a/src/Compile/Options.hs +++ b/src/Compile/Options.hs @@ -674,7 +674,8 @@ targets = ("wasm64", \f -> f{ target=C Wasm, platform=platform64 }), ("wasmjs", \f -> f{ target=C WasmJs, platform=platform32 }), ("wasmweb",\f -> f{ target=C WasmWeb, platform=platform32 }), - ("cs", \f -> f{ target=CS, platform=platformCS }) + ("cs", \f -> f{ target=CS, platform=platformCS }), + ("vm", \f -> f{ target=VM, platform=platform64 }) ] -- | Environment table diff --git a/stack.yaml b/stack.yaml index 98a196bd3..beb20a567 100644 --- a/stack.yaml +++ b/stack.yaml @@ -13,6 +13,7 @@ # $ cabal new-run koka # See also . +arch: aarch64 resolver: lts-22.11 # ghc 9.6.4 -- on windows set the codepage to utf-8: `chcp 65001` # resolver: lts-21.24 # ghc 9.4.8 From 8d29cf6d82be3f6ca995a07b3dff5bf74c09ac3a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Tue, 13 Feb 2024 10:57:07 +0100 Subject: [PATCH 02/48] VM: Add compiler options and extern format --- src/Compile/CodeGen.hs | 17 +++++++++-------- src/Compile/Options.hs | 15 +++++++++++++++ src/Kind/Infer.hs | 4 ++++ src/Syntax/Parse.hs | 3 +++ 4 files changed, 31 insertions(+), 8 deletions(-) diff --git a/src/Compile/CodeGen.hs b/src/Compile/CodeGen.hs index e7dee69d6..46a1e5418 100644 --- a/src/Compile/CodeGen.hs +++ b/src/Compile/CodeGen.hs @@ -269,21 +269,22 @@ codeGenJS term flags sequential entry outBase core codeGenVM :: Terminal -> Flags -> (IO () -> IO ()) -> Maybe (Name,Type) -> FilePath -> Core.Core -> IO Link codeGenVM term flags sequential entry outBase core - = do let outjs = outBase ++ ".mcore.json" - outName fname = joinPath (dirname outBase) fname - -- extractImport m = Core.Import (modName m) "" {- (modPackageQName m) -} Core.ImportUser Public "" - js = vmFromCore (buildType flags) mbEntry (Core.coreProgImports core) core + = do let outmcore = outBase ++ ".mcore.json" + let outrpy = outBase ++ ".rpyeffect" + vm = vmFromCore (buildType flags) mbEntry (Core.coreProgImports core) core mbEntry = case entry of Just (name,tp) -> Just (name,isAsyncFunction tp) _ -> Nothing - termTrace term ( "generate vm: " ++ outjs ) - writeDocW 80 outjs js - when (showAsmJS flags) (termInfo term js) + termTrace term ( "generate vm: " ++ outmcore ) + writeDocW 80 outmcore vm + when (showAsmVM flags) (termInfo term vm) + + runCommand term flags [rpyeffectAsm flags, "--from", "mcore-json", outmcore, outrpy] case mbEntry of Nothing -> return noLink Just _ -> - return (\_ -> return (LinkExe outjs (runCommand term flags ["???",outjs]))) + return (\_ -> return (LinkExe outmcore (runCommand term flags [rpyeffectJit flags,outrpy]))) {--------------------------------------------------------------- C backend diff --git a/src/Compile/Options.hs b/src/Compile/Options.hs index fe6ab0b62..ba865f8c8 100644 --- a/src/Compile/Options.hs +++ b/src/Compile/Options.hs @@ -125,6 +125,7 @@ data Flags , showCoreTypes :: !Bool , showAsmCS :: !Bool , showAsmJS :: !Bool + , showAsmVM :: !Bool , showAsmC :: !Bool , _showTypeSigs :: !Bool , showHiddenTypeSigs :: !Bool @@ -150,6 +151,8 @@ data Flags , csc :: !FileName , node :: !FileName , wasmrun :: !FileName + , rpyeffectAsm :: !FileName + , rpyeffectJit :: !FileName , cmake :: !FileName , cmakeArgs :: !String , ccompPath :: !FilePath @@ -268,6 +271,7 @@ flagsNull False -- show asm False False + False False -- typesigs False -- hiddentypesigs False -- show elapsed time @@ -292,6 +296,8 @@ flagsNull "csc" "node" "wasmtime" + "rpyeffect-asm" -- TODO hardcoded for now (for testing) + "rpyeffect-jit" -- TODO hardcoded for now (for testing) "cmake" "" -- cmake args @@ -424,6 +430,8 @@ options = (\(xss,yss) -> (concat xss, concat yss)) $ unzip , option [] ["csc"] (ReqArg cscFlag "cmd") "use as the csharp backend compiler " , option [] ["node"] (ReqArg nodeFlag "cmd") "use to execute node" , option [] ["wasmrun"] (ReqArg wasmrunFlag "cmd") "use to execute wasm" + , option [] ["rpyeffect-asm"] (ReqArg rpyeffectAsmFlag "cmd") "use to compile rpyeffect-asm mcore to rpyeffect" + , option [] ["rpyeffect-jit"] (ReqArg rpyeffectJitFlag "cmd") "use to run rpyeffect code" , option [] ["editor"] (ReqArg editorFlag "cmd") "use as editor" , option [] ["stack"] (ReqArg stackFlag "size") "set stack size (0 for platform default)" , option [] ["heap"] (ReqArg heapFlag "size") "set reserved heap size (0 for platform default)" @@ -450,6 +458,7 @@ options = (\(xss,yss) -> (concat xss, concat yss)) $ unzip , flag [] ["showcoretypes"] (\b f -> f{showCoreTypes=b}) "show full types in core" , flag [] ["showcs"] (\b f -> f{showAsmCS=b}) "show generated c#" , flag [] ["showjs"] (\b f -> f{showAsmJS=b}) "show generated javascript" + , flag [] ["showjs"] (\b f -> f{showAsmVM=b}) "show generated rpyeffect-asm mcore" , flag [] ["showc"] (\b f -> f{showAsmC=b}) "show generated C" , flag [] ["core"] (\b f -> f{genCore=b}) "generate a core file" , flag [] ["checkcore"] (\b f -> f{coreCheck=b}) "check generated core" @@ -612,6 +621,12 @@ options = (\(xss,yss) -> (concat xss, concat yss)) $ unzip wasmrunFlag s = Flag (\f -> f{ wasmrun = s }) + rpyeffectAsmFlag s + = Flag (\f -> f{ rpyeffectAsm = s }) + + rpyeffectJitFlag s + = Flag (\f -> f{ rpyeffectJit = s }) + editorFlag s = Flag (\f -> f{ editor = s }) diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index b3b02d0b7..45ca18eca 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -434,6 +434,7 @@ formatCall tp (target,ExternalInline inline) = (target,inline) formatCall tp (target,ExternalCall fname) = case target of CS -> (target,formatCS) + VM -> (target,formatVM) JS _ -> (target,formatJS) C _ -> (target,formatC) Default -> (target,formatJS) @@ -455,6 +456,9 @@ formatCall tp (target,ExternalCall fname) formatJS = fname ++ arguments + formatVM + = fname ++ arguments -- TODO + formatCS = fname ++ typeArguments ++ arguments diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs index d53c52e5b..27fa612c3 100644 --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -566,6 +566,9 @@ externalTarget <|> do specialId "cs" return CS + <|> + do specialId "vm" + return VM <|> do specialId "js" return (JS JsDefault) From bc1f63f1989a3e5b4c39e14b3e661a2dcdc02e26 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Tue, 13 Feb 2024 11:03:12 +0100 Subject: [PATCH 03/48] VM: Add some helpers for generating mcore --- src/Backend/VM/FromCore.hs | 64 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 64 insertions(+) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index 021c7a435..c37ab1137 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -1304,3 +1304,67 @@ tagField = text "_tag" constdecl :: Doc constdecl = text "const" + +quoted :: Doc -> Doc +quoted d = text $ show $ asString d + +str :: String -> Doc +str s = text $ show $ s + +obj :: [Doc] -> Doc +obj = encloseSep lbrace rbrace comma + +(.=) :: String -> Doc -> Doc +(.=) k v = text (show k ++ ":") <+> v + +-------------------------------------------------------------------------------- +-- Smart-constructors for instructions +-------------------------------------------------------------------------------- +app :: Doc -> [Doc] -> Doc +app fn args = obj [ "op" .= text "\"App\"" + , "fn" .= fn + , "args" .= list args + ] + +primitive :: [Doc] -> String -> [Doc] -> Doc -> Doc +primitive outs name ins body = obj + [ "op" .= str "Primitive" + , "name" .= str name + , "args" .= list ins + , "returns" .= list outs + , "rest" .= body + ] + +-- | Simplified primitive smart-constructor (works almost like function application) +appPrim :: String -- ^ name + -> [Doc] -- ^ args + -> Doc -- ^ return type + -> Doc +appPrim name args tp = primitive [var (str "primitive_result") tp] name args (var (str "primitive_result") tp) + +-- | Pseudo-instruction for not-yet supported parts +notImplemented :: Doc -> Doc +notImplemented doc = appPrim ("Not implemented: " ++ show (asString doc)) [] (tpe "Unit") + +-- TODO other instructions + +var :: Doc -> Doc -> Doc +var x t = obj [ "id" .= x, "type" .= t ] + +---- Types +tFn :: String -> [Doc] -> Doc -> Doc +tFn pur ps r = obj [ "op" .= text (show "Function") + , "params" .= list ps + , "return" .= r + , "purity" .= text (show pur) + ] + +-- | Simple named type +tpe :: String -> Doc +tpe name = obj [ "op" .= text (show name) ] + +---- Other forms + +-- | Definitions +def :: Doc -> Doc -> Doc +def n v = obj [ "name" .= n, "value" .= v ] From c25aba244378077f8cf05da6ff0e744ddfb36855 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Thu, 15 Feb 2024 11:35:57 +0100 Subject: [PATCH 04/48] VM: Make simple Hello World work --- src/Backend/VM/FromCore.hs | 350 +++++++++++++------------------------ src/Compile/Options.hs | 6 +- src/Kind/Infer.hs | 2 +- test/minimal/hello.kk | 5 + 4 files changed, 133 insertions(+), 230 deletions(-) create mode 100644 test/minimal/hello.kk diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index c37ab1137..e9a3c5684 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -61,80 +61,36 @@ vmFromCore buildType mbMain imports core genModule :: BuildType -> Maybe (Name,Bool) -> [Import] -> Core -> Asm Doc genModule buildType mbMain imports core - = do let externs = vcat (concatMap (includeExternal buildType) (coreProgExternals core)) - (tagDefs,defs) = partition isTagDef (coreProgDefs core) + = do let (tagDefs,defs) = partition isTagDef (coreProgDefs core) decls0 <- genGroups True tagDefs decls1 <- genTypeDefs (coreProgTypeDefs core) decls2 <- genGroups True defs let -- `imports = coreProgImports core` is not enough due to inlined definitions (mainEntry) = case mbMain of - Nothing -> (empty) + Nothing -> appPrim "is a library" [] (tpe "Unit") Just (name,isAsync) - -> ( - (text " " <-> text "// main entry:" <-> - ppName (unqualify name) <.> text "($std_core.id);" -- pass id for possible cps translated main - )) + -> app (var (str $ show name) (tFn "Effectful" [] (tpe "Unit"))) [] return $ - vcat ( - [ text "// Koka generated module:" <+> string (show (coreProgName core)) <.> text ", koka version:" <+> string version - , text "\"use strict\";" - , text " " - , text "// imports" + obj + [ "metadata" .= + obj [ "generated by" .= str "Koka" + , "koka version" .= str version + , "program name" .= str (show (coreProgName core)) + ] + , "definitions" .= + list (decls0 + -- ++ [def (var (str "typedefs1") (tpe "Unit")) (notImplemented decls1) ] -- TODO + ++ decls2) + , "main" .= mainEntry ] - ++ - importDecls - ++ - [ text " " - , text "// externals" - , externs - , text " " - , text "// type declarations" - , decls0 - , decls1 - , text " " - , text "// declarations" - , decls2 - , mainEntry - ]) where - importDecls :: [Doc] - importDecls - = [text "import * as" <+> dname <+> text "from" <+> squotes (dpath <.> text ".mjs") <.> semi - | (dpath,dname) <- externalImports ++ normalImports] - - normalImports :: [(Doc,Doc)] - normalImports - = [(moduleImport imp, ppModName (importName imp)) | imp <- imports] - - modName = ppModName (coreProgName core) - exportedValues = let f (DefRec xs) = map defName xs - f (DefNonRec x) = [defName x] - in map unqualify $ concatMap f (coreProgDefs core) - exportedConstrs = let f (Synonym _ ) = [] - f (Data info _) = map conInfoName $ -- filter (isPublic . conInfoVis) -- export all for inlined defs - (dataInfoConstrs info) - u (TypeDefGroup xs) = xs - in map unqualify $ concatMap f $ concatMap u (coreProgTypeDefs core) - isTagDef (DefNonRec def) = isOpenTagName (defName def) isTagDef _ = False - externalImports :: [(Doc,Doc)] - externalImports - = concatMap (importExternal buildType) (coreProgExternals core) - moduleImport :: Import -> Doc moduleImport imp = (text (if null (importPackage imp) then "." else importPackage imp) <.> text "/" <.> text (moduleNameToPath (importName imp))) -includeExternal :: BuildType -> External -> [Doc] -includeExternal buildType ext - = case externalImportLookup (JS JsDefault) buildType "include-inline" ext of - Just content -> [align $ vcat $! map text (lines content)] - _ -> [] - - - importExternal :: BuildType -> External -> [(Doc,Doc)] importExternal buildType ext = case externalImportLookup (JS JsDefault) buildType "library" ext of @@ -144,74 +100,42 @@ importExternal buildType ext _ -> [] --------------------------------------------------------------------------------- --- Generate javascript statements for value definitions +-- Translate types --------------------------------------------------------------------------------- +transformType :: Type -> Doc +transformType (TVar _) = tpe "Ptr" -- erased +transformType (TForall _ _ t) = transformType t -- TODO do we need to thunk +transformType (TFun ps e t) = obj [ "op" .= str "Function" + , "params" .= list [ transformType pt | (_,pt) <- ps] + , "return" .= transformType t + , "purity" .= str "Effectful" -- TODO infer from e + ] +transformType (TCon c) | nameModule (typeConName c) == "std/core/types" = case (nameStem (typeConName c)) of + "unit" -> tpe "Unit" + t -> obj [ "op" .= str "Ptr", "extern_ptr_name" .= (str $ show t) ] +transformType (TCon c) = obj [ "op" .= str "Ptr", "extern_ptr_name" .= (str $ show $ typeConName c) ] +transformType (TApp t as) = transformType t +transformType (TSyn _ _ t) = transformType t -genGroups :: Bool -> [DefGroup] -> Asm Doc +--------------------------------------------------------------------------------- +-- Generate mcore statements for value definitions +--------------------------------------------------------------------------------- + +genGroups :: Bool -> [DefGroup] -> Asm [Doc] genGroups topLevel groups - = localUnique $ - do docs <- mapM (genGroup topLevel) groups - return (vcat docs) + = localUnique $ concat <$> mapM (genGroup topLevel) groups -genGroup :: Bool -> DefGroup -> Asm Doc +genGroup :: Bool -> DefGroup -> Asm [Doc] genGroup topLevel group = case group of - DefRec defs -> do docs <- mapM (genDef topLevel) defs - return (vcat docs) - DefNonRec def -> genDef topLevel def + DefRec defs -> mapM (genDef topLevel) defs + DefNonRec def -> (:[]) <$> genDef topLevel def genDef :: Bool -> Def -> Asm Doc -genDef topLevel def@(Def name tp expr vis sort inl rng comm) - = do penv <- getPrettyEnv - let resDoc = typeComment (Pretty.ppType penv tp) - defDoc <- do mdoc <- tryFunDef name resDoc expr - case mdoc of - Just doc -> return (if (topLevel) then ppVis vis doc else doc) - Nothing -> do doc <- genStat (ResultAssign name Nothing) expr - return (if (topLevel) - then ppVis vis (text "var" <+> ppName (unqualify name) <.> semi <--> doc) - else doc) - - return $ vcat [ text " " - , if null comm - then empty - else align (vcat (space : map text (lines (trim comm)))) {- already a valid javascript comment -} - , defDoc - ] - where - -- remove final newlines and whitespace - trim s = reverse (dropWhile (`elem` " \n\r\t") (reverse s)) - - -ppVis _ doc = text "export" <+> doc -- always export due to inlined definitions --- ppVis _ doc = doc - -tryFunDef :: Name -> CommentDoc -> Expr -> Asm (Maybe Doc) -tryFunDef name comment expr - = case expr of - TypeApp e _ -> tryFunDef name comment e - TypeLam _ e -> tryFunDef name comment e - Lam args eff body -> do inStat <- getInStatement - if (inStat) - then return Nothing - else do fun <- genFunDef' name args comment body - return (Just fun) - _ -> return Nothing - where - genFunDef' :: Name -> [TName] -> CommentDoc -> Expr -> Asm Doc - genFunDef' name params comm body - = do let args = map ( ppName . getName ) params - isTailCall = body `isTailCalling` name - bodyDoc <- (if isTailCall then withStatement else id) - (genStat (ResultReturn (Just name) params) body) - return $ text "function" <+> ppName (unqualify name) - <.> tupled args - <+> comm - <+> ( if isTailCall - then tcoBlock bodyDoc - else debugComment ("genFunDef: no tail calls to " ++ show name ++ " found") - <.> block bodyDoc - ) +genDef topLevel (Def name tp expr vis sort inl rng comm) + = do let n = var (str $ show name) (transformType tp) + v <- genExpr expr + return $ def n v --------------------------------------------------------------------------------- -- Generate value constructors for each defined type @@ -265,7 +189,7 @@ genTypeDef (Data info isExtend) -> genConstr penv c repr name args [] -- normal with tag _ -> genConstr penv c repr name args [(tagField, getConTag modName c repr)] - return (ppVis (conInfoVis c) decl) + return $ text "" ) $ zip (dataInfoConstrs $ info) conReprs return $ linecomment (text "type" <+> pretty (unqualify (dataInfoName info))) <-> vcat docs @@ -304,8 +228,8 @@ getResult result doc getResultX result (puredoc,retdoc) = case result of - ResultReturn _ _ -> text "return" <+> retdoc <.> semi - ResultAssign n ml -> ( if isWildcard n + ResultReturn _ _ -> retdoc + ResultAssign n ml -> notImplemented $ ( if isWildcard n then (if (isEmptyDoc puredoc) then puredoc else puredoc <.> semi) else text "var" <+> ppName (unqualify n) <+> text "=" <+> retdoc <.> semi ) <-> case ml of @@ -394,13 +318,6 @@ tryTailCall result expr genStat :: Result -> Expr -> Asm Doc genStat result expr = fmap (debugWrap "genStat") $ - {- - case extractExternal expr of - Just (tn,fs,es) - -> do (statDoc, exprDoc) <- genExternalExpr tn fs es - return (statDoc <-> getResult result exprDoc) - Nothing - -> -} do mdoc <- tryTailCall result expr case mdoc of Just doc @@ -428,13 +345,16 @@ genExprStat result expr return (vcat docs <-> doc) Let groups body - -> do doc1 <- genGroups False groups - doc2 <- genStat result body - return (doc1 <-> doc2) + -> do defs <- genGroups False groups + body <- genStat result body + return $ obj [ "op" .= str "LetRec" + , "definitions" .= list defs + , "body" .= body + ] -- Handling all other cases - _ -> do (statDoc,exprDoc) <- genExpr expr - return (statDoc <-> getResult result exprDoc) + _ -> do (exprDoc) <- genExpr expr + return (getResult result exprDoc) -- | Generates a statement for a match expression regarding a given return context genMatch :: Result -> [Doc] -> [Branch] -> Asm Doc @@ -452,16 +372,16 @@ genMatch result scrutinees branches -> case e2 of App (Var tn _) [r2] | getName tn == nameReturn - -> do (stmts1, expr1) <- genExpr r1 - (stmts2, expr2) <- genExpr r2 - return $ text "if" <.> parens (head scrutinees) <+> block (stmts1 <-> text "return" <+> expr1 <.> semi) - <-> text "else" <+> block (stmts2 <-> text "return" <+> expr2 <.> semi) - _ -> do (stmts1,expr1) <- genExpr r1 - (stmts2,expr2) <- genExpr e2 + -> do (expr1) <- genExpr r1 + (expr2) <- genExpr r2 + return $ text "if" <.> parens (head scrutinees) <+> block ( text "return" <+> expr1 <.> semi) + <-> text "else" <+> block ( text "return" <+> expr2 <.> semi) + _ -> do (expr1) <- genExpr r1 + (expr2) <- genExpr e2 return $ - (text "if" <.> parens (head scrutinees) <+> block (stmts1 <-> text "return" <+> expr1 <.> semi)) + (text "if" <.> parens (head scrutinees) <+> block ( text "return" <+> expr1 <.> semi)) <--> - (stmts2 <-> getResultX result (if (isExprUnit e2) then text "" else expr2,expr2)) + ( getResultX result (if (isExprUnit e2) then text "" else expr2,expr2)) [Branch [p1] [Guard t1 e1], Branch [p2] [Guard t2 e2]] | isExprTrue t1 @@ -536,14 +456,14 @@ genMatch result scrutinees branches genGuard :: Bool -> Result -> Guard -> Asm Doc genGuard lastBranchLastGuard result (Guard t expr) - = do (testSt, testE) <- genExpr t + = do (testE) <- genExpr t let result' = case result of ResultAssign n _ | lastBranchLastGuard -> ResultAssign n Nothing _ -> result exprSt <- genStat result' expr return $ if isExprTrue t then exprSt - else testSt <-> text "if" <+> parens testE <.> block exprSt + else text "if" <+> parens testE <.> block exprSt -- | Generates a list of boolish expression for matching the pattern genTest :: Name -> (Doc, Pattern) -> [Doc] @@ -626,14 +546,12 @@ genMatch result scrutinees branches --------------------------------------------------------------------------------- -- | Generates javascript statements and a javascript expression from core expression -genExpr :: Expr -> Asm (Doc,Doc) +genExpr :: Expr -> Asm Doc genExpr expr = -- trace ("genExpr: " ++ show expr) $ case expr of -- check whether the expression is pure an can be inlined - _ | isInlineableExpr expr - -> do doc <- genInline expr - return (empty,doc) + _ | isInlineableExpr expr -> genInline expr TypeApp e _ -> genExpr e TypeLam _ e -> genExpr e @@ -643,17 +561,13 @@ genExpr expr -> genExpr arg App (Con _ repr) [arg] | isConIso repr -> genExpr arg - App (Var tname _) [Lit (LitInt i)] | getName tname == nameByte && (i >= 0 && i < 256) - -> return (empty, pretty i) - App (Var tname _) [Lit (LitInt i)] | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT] && isSmallInt i - -> return (empty, pretty i) - App (Var tname _) [Lit (LitInt i)] | getName tname `elem` [nameInt64,nameIntPtrT] && isSmallInt i - -> return (empty, pretty i <.> text "n") + App (Var tname _) [Lit (LitInt i)] + -> return $ obj [ "op" .= str "Literal", "type" .= str "Int", "value" .= pretty i ] -- special: .cctx-field-addr-of: create a tuple with the object and the field name as a string App (TypeApp (Var cfieldOf _) [_]) [Var con _, Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameFieldAddrOf -> do conDoc <- genTName con - return (empty,text "{obj:" <+> conDoc <.> text ", field_name: \"" <.> ppName (unqualify (readQualified fieldName)) <.> text "\"}") + return $ notImplemented (text "{obj:" <+> conDoc <.> text ", field_name: \"" <.> ppName (unqualify (readQualified fieldName)) <.> text "\"}") App f args -> case extractList expr of @@ -662,31 +576,34 @@ genExpr expr Just (tname,formats) -> case args of [Lit (LitInt i)] | getName tname == nameByte && i >= 0 && i < 256 - -> return (empty,pretty i) + -> return (pretty i) [Lit (LitInt i)] | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT] && isSmallInt i - -> return (empty,pretty i) + -> return (pretty i) [Lit (LitInt i)] | getName tname `elem` [nameInt64,nameIntPtrT] && isSmallInt i - -> return (empty,pretty i <.> text "n") + -> return (pretty i <.> text "n") _ -> -- genInlineExternal tname formats argDocs - do (decls,argDocs) <- genExprs args - (edecls,doc) <- genExprExternal tname formats argDocs + do (argDocs) <- genExprs args + (doc) <- genExprExternal tname formats argDocs if (getName tname == nameReturn) - then return (vcat (decls ++ edecls ++ [doc <.> semi]), text "") - else return (vcat (decls ++ edecls), doc) + then return (text "") + else return (doc) Nothing -> do lsDecls <- genExprs (f:trimOptionalArgs args) - let (decls,fdoc:docs) = lsDecls - return (vcat decls, fdoc <.> tupled docs) + let (fdoc:docs) = lsDecls + return $ obj [ "op" .= str "App" + , "fn" .= fdoc + , "args" .= list docs + ] Let groups body -> do decls1 <- genGroups False groups - (decls2,doc) <- genExpr body - return (decls1 <-> decls2, doc) + (doc) <- genExpr body + return $ (notImplemented $ text "defs") -- (decls1 <-> decls2, doc) Case _ _ -> do (doc, tname) <- genVarBinding expr nameDoc <- genTName tname - return (doc, nameDoc) + return $ notImplemented $ text "Case" -- (doc, nameDoc) _ -> failure ("JavaScript.FromCore.genExpr: invalid expression:\n" ++ show expr) @@ -703,11 +620,11 @@ extractList e -> extract (hd:acc) tl _ -> (reverse acc, expr) -genList :: [Expr] -> Expr -> Asm (Doc,Doc) +genList :: [Expr] -> Expr -> Asm Doc genList elems tl - = do (decls,docs) <- genExprs elems - (tdecl,tdoc) <- genExpr tl - return (vcat (decls ++ [tdecl]), text "$std_core_vector.vlist" <.> tupled [list docs, tdoc]) + = do (docs) <- genExprs elems + (tdoc) <- genExpr tl + return (text "$std_core_vector.vlist" <.> tupled [list docs, tdoc]) {- genExternalExpr :: TName -> String -> [Expr] -> Asm (Doc,Doc) @@ -724,10 +641,8 @@ genExternalExpr tname format args ) -} -genExprs :: [Expr] -> Asm ([Doc],[Doc]) -genExprs exprs - = do xs <- mapM genExpr exprs - return (unzip xs) +genExprs :: [Expr] -> Asm [Doc] +genExprs exprs = mapM genExpr exprs -- | Introduces an additional let binding in core if necessary -- The expression in the result is guaranteed to be a Var afterwards @@ -751,15 +666,20 @@ genPure expr Var name (InfoExternal formats) -> genWrapExternal name formats -- unapplied inlined external: wrap as function Var name info - -> genTName name + -> return $ asVar name -- genTName name + Con name repr | nameModule (getName name) == "std/core/types" && nameStem (getName name) == "Unit" + -> return $ obj [ "op" .= str "Literal", "type" .= transformType (tnameType name) ] Con name repr - -> genTName name + -> notImplemented <$> genTName name Lit l -> return $ ppLit l Lam params eff body - -> do args <- mapM genCommentTName params + -> do let args = map asVar params bodyDoc <- genStat (ResultReturn Nothing params) body - return (text "function" <.> tupled args <+> block bodyDoc) + return $ obj [ "op" .= str "Abs" + , "params" .= list args + , "body" .= bodyDoc + ] _ -> failure ("JavaScript.FromCore.genPure: invalid expression:\n" ++ show expr) isPat :: Bool -> Pattern -> Bool @@ -790,7 +710,7 @@ genInline expr [Lit (LitInt i)] | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT] && isSmallInt i -> return (pretty i) [Lit (LitInt i)] | getName tname `elem` [nameInt64,nameIntPtrT] && isSmallInt i - -> return (pretty i <.> text "n") + -> return $ notImplemented $ (pretty i <.> text "n") _ -> genInlineExternal tname formats argDocs Nothing -> case (f,args) of @@ -799,7 +719,7 @@ genInline expr ((Var tname _),[Lit (LitInt i)]) | getName tname `elem` [nameInt64,nameIntPtrT] && isSmallInt i -> return (pretty i <.> text "n") _ -> do fdoc <- genInline f - return (fdoc <.> tupled argDocs) + return $ notImplemented $ (fdoc <.> tupled argDocs) _ -> failure ("JavaScript.FromCore.genInline: invalid expression:\n" ++ show expr) @@ -815,40 +735,36 @@ genWrapExternal :: TName -> [(Target,String)] -> Asm Doc genWrapExternal tname formats = do let n = snd (getTypeArities (typeOf tname)) vs <- genVarNames n - (decls,doc) <- genExprExternal tname formats vs - return $ parens (text "function" <.> tupled vs <+> block (vcat (decls ++ [text "return" <+> doc <.> semi]))) + (doc) <- genExprExternal tname formats vs + return $ notImplemented $ parens (text "function" <.> tupled vs <+> block (vcat ([text "return" <+> doc <.> semi]))) -- inlined external sometimes needs wrapping in a applied function block genInlineExternal :: TName -> [(Target,String)] -> [Doc] -> Asm Doc -genInlineExternal tname formats argDocs - = do (decls,doc) <- genExprExternal tname formats argDocs - if (null decls) - then return doc - else return $ parens $ parens (text "function()" <+> block (vcat (decls ++ [text "return" <+> doc <.> semi]))) <.> text "()" +genInlineExternal tname formats argDocs = genExprExternal tname formats argDocs -- generate external: needs to add try blocks for primitives that can throw exceptions -genExprExternal :: TName -> [(Target,String)] -> [Doc] -> Asm ([Doc],Doc) +genExprExternal :: TName -> [(Target,String)] -> [Doc] -> Asm (Doc) genExprExternal tname formats argDocs0 - = do (decls,doc) <- genExprExternalPrim tname formats argDocs0 + = do (doc) <- genExprExternalPrim tname formats argDocs0 case splitFunType (typeOf tname) of - Nothing -> return (decls,doc) + Nothing -> return (doc) Just (pars,eff,res) -> let (ls,tl) = extractOrderedEffect eff in case filter (\l -> labelName l == nameTpPartial) ls of - [] -> return (decls,doc) + [] -> return (doc) _ -> -- has an exception type, wrap it in a try handler let try = parens $ parens (text "function()" <+> block (vcat ( - [text "try" <+> block (vcat (decls ++ [text "return" <+> doc <.> semi])) + [text "try" <+> block (vcat ([text "return" <+> doc <.> semi])) ,text "catch(_err){ return $std_core._throw_exception(_err); }"] ))) <.> text "()" - in return ([],try) + in return (try) -- special case: .cctx-hole-create -genExprExternalPrim :: TName -> [(Target,String)] -> [Doc] -> Asm ([Doc],Doc) +genExprExternalPrim :: TName -> [(Target,String)] -> [Doc] -> Asm (Doc) genExprExternalPrim tname formats [] | getName tname == nameCCtxHoleCreate - = return ([],text "undefined") + = return (text "undefined") {- -- special case: cfield-set (field is implemented as {value:, field:}) @@ -860,34 +776,16 @@ genExprExternalPrim tname formats [accDoc,resDoc] | getName tname == nameCFieldS genExprExternalPrim tname formats argDocs0 = let name = getName tname format = getFormat tname formats - argDocs = map (\argDoc -> if (all (\c -> isAlphaNum c || c == '_') (asString argDoc)) then argDoc else parens argDoc) argDocs0 - in return $ case map (\fmt -> ppExternalF name fmt argDocs) $ lines format of - [] -> ([],empty) - ds -> (init ds, last ds) - where - ppExternalF :: Name -> String -> [Doc] -> Doc - ppExternalF name [] args - = empty - ppExternalF name k@('\\':'#':xs) args - = char '#' <.> ppExternalF name xs args - ppExternalF name k@('#':'#':xs) args - = failure ("Backend.JavaScript.FromCore: type arguments in javascript external in: " ++ show tname) - ppExternalF name k@('#':y:xs) args - = if y `elem` ['1'..'9'] - then (let n = length args - i = fromEnum y - fromEnum '1' - in assertion ("illegal index in external: " ++ show tname ++ "("++k++"): index: " ++ show i) (i < n) $ - (args!!i) <.> ppExternalF name xs args) - else char y <.> ppExternalF name xs args - ppExternalF name (x:xs) args - = char x <.> ppExternalF name xs args + in return $ (case (tnameType tname) of + TFun _ _ t -> appPrim format argDocs0 (transformType t) + _ -> notImplemented $ text "Primitive non-function") getFormat :: TName -> [(Target,String)] -> String getFormat tname formats - = case lookupTarget (JS JsDefault) formats of -- TODO: pass specific target from the flags + = case lookupTarget VM formats of -- TODO: pass specific target from the flags Nothing -> -- failure ("backend does not support external in " ++ show tname ++ ": " ++ show formats) trace( "warning: backend does not support external in " ++ show tname ) $ - ("$std_core._unsupported_external(\"" ++ (show tname) ++ "\")") + ("undefined external: " ++ (show tname)) Just s -> s genDefName :: TName -> Asm Doc @@ -1124,12 +1022,10 @@ getInStatement ppLit :: Lit -> Doc ppLit lit = case lit of - LitInt i -> if (isSmallInt(i)) - then pretty i - else ppName nameIntConst <.> parens (pretty i <.> text "n") - LitChar c -> text ("0x" ++ showHex 4 (fromEnum c)) - LitFloat d -> text (showsPrec 20 d "") - LitString s -> dquotes (hcat (map escape s)) + LitInt i -> obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= pretty i ] + LitChar c -> notImplemented $ text ("0x" ++ showHex 4 (fromEnum c)) + LitFloat d -> notImplemented $ text (showsPrec 20 d "") + LitString s -> obj [ "op" .= str "Literal", "type" .= tpe "String", "value" .= dquotes (hcat (map escape s)) ] where escape c = if (c < ' ') @@ -1164,7 +1060,7 @@ minSmallInt = -maxSmallInt ppName :: Name -> Doc ppName name - = if isQualified name + = quoted $ if isQualified name then ppModName (qualifier name) <.> dot <.> encode False (unqualify name) else encode False name @@ -1349,7 +1245,9 @@ notImplemented doc = appPrim ("Not implemented: " ++ show (asString doc)) [] (tp -- TODO other instructions var :: Doc -> Doc -> Doc -var x t = obj [ "id" .= x, "type" .= t ] +var x t = obj [ "op" .= str "Var", "id" .= x, "type" .= t ] +asVar :: TName -> Doc +asVar n = var (str $ show $ getName n) (transformType $ tnameType n) ---- Types tFn :: String -> [Doc] -> Doc -> Doc diff --git a/src/Compile/Options.hs b/src/Compile/Options.hs index ba865f8c8..09121db9f 100644 --- a/src/Compile/Options.hs +++ b/src/Compile/Options.hs @@ -296,8 +296,8 @@ flagsNull "csc" "node" "wasmtime" - "rpyeffect-asm" -- TODO hardcoded for now (for testing) - "rpyeffect-jit" -- TODO hardcoded for now (for testing) + "../rpyeffect-asm/target/universal/stage/bin/rpyeffectasm" -- TODO hardcoded for now (for testing) + "../rpyeffect-jit/out/bin/arm64-Darwin/rpyeffect-jit" -- TODO hardcoded for now (for testing) "cmake" "" -- cmake args @@ -458,7 +458,7 @@ options = (\(xss,yss) -> (concat xss, concat yss)) $ unzip , flag [] ["showcoretypes"] (\b f -> f{showCoreTypes=b}) "show full types in core" , flag [] ["showcs"] (\b f -> f{showAsmCS=b}) "show generated c#" , flag [] ["showjs"] (\b f -> f{showAsmJS=b}) "show generated javascript" - , flag [] ["showjs"] (\b f -> f{showAsmVM=b}) "show generated rpyeffect-asm mcore" + , flag [] ["showvm"] (\b f -> f{showAsmVM=b}) "show generated rpyeffect-asm mcore" , flag [] ["showc"] (\b f -> f{showAsmC=b}) "show generated C" , flag [] ["core"] (\b f -> f{genCore=b}) "generate a core file" , flag [] ["checkcore"] (\b f -> f{coreCheck=b}) "check generated core" diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index 45ca18eca..ec229b314 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -457,7 +457,7 @@ formatCall tp (target,ExternalCall fname) = fname ++ arguments formatVM - = fname ++ arguments -- TODO + = fname formatCS = fname ++ typeArguments ++ arguments diff --git a/test/minimal/hello.kk b/test/minimal/hello.kk new file mode 100644 index 000000000..3f830cedf --- /dev/null +++ b/test/minimal/hello.kk @@ -0,0 +1,5 @@ +extern doprint(s : string) : () + vm "println(String): Unit" + +pub fun main() + doprint("Hello") From 2fdedf96f5c9bc47aa1d5135bba788e01e9005ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Thu, 15 Feb 2024 13:44:45 +0100 Subject: [PATCH 05/48] Fix names of generated lib files --- src/Compile/Options.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Compile/Options.hs b/src/Compile/Options.hs index 09121db9f..cee27b7e7 100644 --- a/src/Compile/Options.hs +++ b/src/Compile/Options.hs @@ -1061,6 +1061,7 @@ targetExeExtension target C _ -> exeExtension JS JsWeb -> ".html" JS _ -> ".mjs" + VM -> ".rpyeffect" _ -> exeExtension targetObjExtension target @@ -1070,6 +1071,7 @@ targetObjExtension target C WasmWeb-> ".o" C _ -> objExtension JS _ -> ".mjs" + VM -> ".rpyeffect" _ -> objExtension targetLibFile target fname @@ -1079,6 +1081,7 @@ targetLibFile target fname C WasmWeb-> "lib" ++ fname ++ ".a" C _ -> libPrefix ++ fname ++ libExtension JS _ -> fname ++ ".mjs" -- ? + VM -> fname ++ ".rpyeffect" _ -> libPrefix ++ fname ++ libExtension outName :: Flags -> FilePath -> FilePath From d4e4ef03124d4be57652011a5acd9c01df40dc61 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Mon, 19 Feb 2024 18:55:30 +0100 Subject: [PATCH 06/48] Translate constructor definitions --- src/Backend/VM/FromCore.hs | 127 ++++++++++++++++++------------------- 1 file changed, 60 insertions(+), 67 deletions(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index e9a3c5684..ba6d00308 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -61,10 +61,8 @@ vmFromCore buildType mbMain imports core genModule :: BuildType -> Maybe (Name,Bool) -> [Import] -> Core -> Asm Doc genModule buildType mbMain imports core - = do let (tagDefs,defs) = partition isTagDef (coreProgDefs core) - decls0 <- genGroups True tagDefs + = do decls0 <- genGroups True (coreProgDefs core) decls1 <- genTypeDefs (coreProgTypeDefs core) - decls2 <- genGroups True defs let -- `imports = coreProgImports core` is not enough due to inlined definitions (mainEntry) = case mbMain of Nothing -> appPrim "is a library" [] (tpe "Unit") @@ -79,8 +77,8 @@ genModule buildType mbMain imports core ] , "definitions" .= list (decls0 - -- ++ [def (var (str "typedefs1") (tpe "Unit")) (notImplemented decls1) ] -- TODO - ++ decls2) + ++ decls1 + ) , "main" .= mainEntry ] where @@ -141,69 +139,62 @@ genDef topLevel (Def name tp expr vis sort inl rng comm) -- Generate value constructors for each defined type --------------------------------------------------------------------------------- -genTypeDefs :: TypeDefGroups -> Asm Doc +genTypeDefs :: TypeDefGroups -> Asm [Doc] genTypeDefs groups - = do docs <- mapM (genTypeDefGroup) groups - return (vcat docs) + = concat <$> mapM (genTypeDefGroup) groups -genTypeDefGroup :: TypeDefGroup -> Asm Doc +genTypeDefGroup :: TypeDefGroup -> Asm [Doc] genTypeDefGroup (TypeDefGroup tds) - = do docs <- mapM (genTypeDef) tds - return (vcat docs) + = concat <$> mapM (genTypeDef) tds -genTypeDef ::TypeDef -> Asm Doc +genTypeDef ::TypeDef -> Asm [Doc] genTypeDef (Synonym {}) - = return empty + = return [] genTypeDef (Data info isExtend) = do modName <- getModule let (dataRepr, conReprs) = getDataRepr info - docs <- mapM ( \(c,repr) -> - do let args = map ppName (map fst (conInfoParams c)) - name <- genName (conInfoName c) + mapM ( \(c,repr) -> + do let args = map (\(n,t) -> var (ppName n) (transformType t)) (conInfoParams c) + let name = str $ show (conInfoName c) + let tp = transformType $ conInfoType c penv <- getPrettyEnv - let singletonValue val - = constdecl <+> name <+> text "=" <+> - text val <.> semi <+> linecomment (Pretty.ppType penv (conInfoType c)) - decl <- if (conInfoName c == nameTrue) - then return (constdecl <+> name <+> text "=" <+> text "true" <.> semi) - else if (conInfoName c == nameFalse) - then return (constdecl <+> name <+> text "=" <+> text "false" <.> semi) - else return $ case repr of + let singletonValue val = def (var name (transformType (conInfoType c))) val + if (conInfoName c == nameTrue) + then return $ obj [ "op" .= str "Literal", "type" .= str "Int", "value" .= text "1" ] + else if (conInfoName c == nameFalse) + then return $ obj [ "op" .= str "Literal", "type" .= str "Int", "value" .= text "0" ] + else return $ case repr of -- special ConEnum{} - -> constdecl <+> name <+> text "=" <+> int (conTag repr) <.> semi <+> linecomment (Pretty.ppType penv (conInfoType c)) - ConSingleton{} | conInfoName c == nameOptionalNone - -> singletonValue "undefined" - ConSingleton _ DataStructAsMaybe _ _ - -> singletonValue "null" - ConSingleton _ DataAsMaybe _ _ - -> singletonValue "null" - ConSingleton _ DataAsList _ _ - -> singletonValue "null" + -> debugWrap ("enum ") $ obj ["op" .= str "Literal", "type" .= str "Int", "value" .= int (conTag repr)] +-- ConSingleton{} | conInfoName c == nameOptionalNone +-- -> singletonValue "undefined" +-- ConSingleton _ DataStructAsMaybe _ _ +-- -> singletonValue "null" +-- ConSingleton _ DataAsMaybe _ _ +-- -> singletonValue "null" +-- ConSingleton _ DataAsList _ _ +-- -> singletonValue "null" -- tagless - ConIso{} -> genConstr penv c repr name args [] - ConSingle{} -> genConstr penv c repr name args [] - ConAsCons{} -> genConstr penv c repr name args [] - ConAsJust{} -> genConstr penv c repr name args [] -- [(tagField, getConTag modName c repr)] + ConIso{} -> genConstr penv c repr name tp args [] + ConSingle{} -> genConstr penv c repr name tp args [] + ConAsCons{} -> genConstr penv c repr name tp args [] + ConAsJust{} -> genConstr penv c repr name tp args [] -- [(tagField, getConTag modName c repr)] ConStruct{conDataRepr=DataStructAsMaybe} - -> genConstr penv c repr name args [] + -> genConstr penv c repr name tp args [] -- normal with tag - _ -> genConstr penv c repr name args [(tagField, getConTag modName c repr)] - return $ text "" + _ -> genConstr penv c repr name tp args [(tagField, getConTag modName c repr)] ) $ zip (dataInfoConstrs $ info) conReprs - return $ linecomment (text "type" <+> pretty (unqualify (dataInfoName info))) - <-> vcat docs - <-> text "" where - genConstr penv c repr name args tagFields - = if null args - then debugWrap "genConstr: null fields" - $ constdecl <+> name <+> text "=" <+> object tagFields <.> semi <+> linecomment (Pretty.ppType penv (conInfoType c)) - else debugWrap "genConstr: with fields" - $ text "function" <+> name <.> tupled args <+> comment (Pretty.ppType penv (conInfoType c)) - <+> block ( text "return" <+> - (if (conInfoName c == nameOptional || isConIso repr) then head args - else object (tagFields ++ map (\arg -> (arg, arg)) args)) <.> semi ) + genConstr penv c repr name tp args tagFields + = def (var name tp) (debugWrap "genConstr" $ + obj [ "op" .= str "Abs", "params" .= list args + , "body" .= obj [ "op" .= str "Construct" + , "type_tag" .= (str $ show $ conInfoType c) + , "tag" .= name + , "args" .= list args + ] + ]) getConTag modName coninfo repr = case repr of @@ -246,7 +237,7 @@ tryTailCall result expr ) -> do let (ResultReturn _ params) = result stmts <- genOverride params args - return $ Just $ block $ stmts <-> tailcall + return $ Just $ notImplemented $ block $ stmts <-> tailcall -- Tailcall case 2 App (TypeApp (Var n info) _) args | ( case result of @@ -255,7 +246,7 @@ tryTailCall result expr ) -> do let (ResultReturn _ params) = result stmts <- genOverride params args - return $ Just $ block $ stmts <-> tailcall + return $ Just $ notImplemented $ block $ stmts <-> tailcall _ -> return Nothing where @@ -361,7 +352,7 @@ genMatch :: Result -> [Doc] -> [Branch] -> Asm Doc genMatch result scrutinees branches = fmap (debugWrap "genMatch") $ do case branches of - [] -> fail ("Backend.JavaScript.FromCore.genMatch: no branch in match statement: " ++ show(scrutinees)) + [] -> fail ("Backend.VM.FromCore.genMatch: no branch in match statement: " ++ show(scrutinees)) [b] -> fmap snd $ genBranch True result scrutinees b -- Special handling of return related cases - would be nice to get rid of it @@ -374,11 +365,11 @@ genMatch result scrutinees branches | getName tn == nameReturn -> do (expr1) <- genExpr r1 (expr2) <- genExpr r2 - return $ text "if" <.> parens (head scrutinees) <+> block ( text "return" <+> expr1 <.> semi) + return $ notImplemented $ text "if" <.> parens (head scrutinees) <+> block ( text "return" <+> expr1 <.> semi) <-> text "else" <+> block ( text "return" <+> expr2 <.> semi) _ -> do (expr1) <- genExpr r1 (expr2) <- genExpr e2 - return $ + return $ notImplemented $ (text "if" <.> parens (head scrutinees) <+> block ( text "return" <+> expr1 <.> semi)) <--> ( getResultX result (if (isExprUnit e2) then text "" else expr2,expr2)) @@ -392,10 +383,10 @@ genMatch result scrutinees branches let nameDoc = head scrutinees let test = genTest modName (nameDoc, p1) if (isExprTrue e1 && isExprFalse e2) - then return $ getResult result $ parens (conjunction test) + then return $ notImplemented $ getResult result $ parens (conjunction test) else do doc1 <- withNameSubstitutions (getSubstitutions nameDoc p1) (genInline e1) doc2 <- withNameSubstitutions (getSubstitutions nameDoc p2) (genInline e2) - return $ debugWrap "genMatch: conditional expression" + return $ notImplemented $ debugWrap "genMatch: conditional expression" $ getResult result $ parens (conjunction test) <+> text "?" <+> doc1 <+> text ":" <+> doc2 @@ -403,7 +394,7 @@ genMatch result scrutinees branches | all (\b-> length (branchGuards b) == 1) bs && all (\b->isExprTrue $ guardTest $ head $ branchGuards b) bs -> do xs <- mapM (withStatement . genBranch True result scrutinees) bs - return $ debugWrap "genMatch: guard-free case" + return $ notImplemented $ debugWrap "genMatch: guard-free case" $ hcat ( map (\(conds,d)-> text "if" <+> parens (conjunction conds) <+> block d <-> text "else " ) (init xs) @@ -420,7 +411,7 @@ genMatch result scrutinees branches b <- (withStatement . genBranch True result' scrutinees) (last branches) let ds = map (\(cds,stmts)-> if null cds then stmts - else text "if" <+> parens (conjunction cds) + else notImplemented $ text "if" <+> parens (conjunction cds) <+> block stmts ) bs let d = snd b @@ -463,7 +454,7 @@ genMatch result scrutinees branches exprSt <- genStat result' expr return $ if isExprTrue t then exprSt - else text "if" <+> parens testE <.> block exprSt + else notImplemented $ text "if" <+> parens testE <.> block exprSt -- | Generates a list of boolish expression for matching the pattern genTest :: Name -> (Doc, Pattern) -> [Doc] @@ -670,7 +661,7 @@ genPure expr Con name repr | nameModule (getName name) == "std/core/types" && nameStem (getName name) == "Unit" -> return $ obj [ "op" .= str "Literal", "type" .= transformType (tnameType name) ] Con name repr - -> notImplemented <$> genTName name + -> return $ asVar name Lit l -> return $ ppLit l Lam params eff body @@ -759,7 +750,7 @@ genExprExternal tname formats argDocs0 ,text "catch(_err){ return $std_core._throw_exception(_err); }"] ))) <.> text "()" - in return (try) + in return $ notImplemented (try) -- special case: .cctx-hole-create genExprExternalPrim :: TName -> [(Target,String)] -> [Doc] -> Asm (Doc) @@ -1191,9 +1182,11 @@ debugComment s debugWrap :: String -> Doc -> Doc debugWrap s d - = if debug - then debugComment ("<" ++ s ++ ">") <-> tab d <-> debugComment ("") - else d + = if debug then obj [ + "op" .= str "DebugWrap", + "inner" .= d, + "annotation" .= str s + ] else d tagField :: Doc tagField = text "_tag" From 13b311b8fd36f17746a3cbfe40c9e38b50db2f50 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Mon, 19 Feb 2024 18:55:58 +0100 Subject: [PATCH 07/48] Some simplifications --- src/Backend/VM/FromCore.hs | 89 +------------------------------------- 1 file changed, 1 insertion(+), 88 deletions(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index ba6d00308..7775441a8 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -81,21 +81,6 @@ genModule buildType mbMain imports core ) , "main" .= mainEntry ] - where - isTagDef (DefNonRec def) = isOpenTagName (defName def) - isTagDef _ = False - -moduleImport :: Import -> Doc -moduleImport imp - = (text (if null (importPackage imp) then "." else importPackage imp) <.> text "/" <.> text (moduleNameToPath (importName imp))) - -importExternal :: BuildType -> External -> [(Doc,Doc)] -importExternal buildType ext - = case externalImportLookup (JS JsDefault) buildType "library" ext of - Just path -> [(text path, case externalImportLookup (JS JsDefault) buildType "library-id" ext of - Just name -> text name - Nothing -> text path)] - _ -> [] --------------------------------------------------------------------------------- -- Translate types @@ -1067,79 +1052,7 @@ ppModName name encode :: Bool -> Name -> Doc encode isModule name - = let s = show name - in if (isReserved s) - then text ('$' : s) - else text ( (asciiEncode isModule s)) - -isReserved :: String -> Bool -isReserved s - = if (not $ null s) && (head s == 'T') && all isDigit (tail s) - then True - else s `S.member` reserved - -reserved :: S.Set String -reserved - = S.fromList $ -- JavaScript pseudo-keywords - [ "prototype" - , "toString" - , "arguments" - , "eval" - ] - ++ -- word literals - [ "null" - , "Infinity" - , "NaN" - ] - ++ -- JavaScript keywords - [ "async" - , "await" - , "break" - , "case" - , "catch" - , "continue" - , "const" - , "debugger" - , "default" - , "delete" - , "do" - , "else" - , "finally" - , "for" - , "function" - , "if" - , "in" - , "instanceof" - , "new" - , "return" - , "switch" - , "this" - , "throw" - , "try" - , "typeof" - , "var" - , "void" - , "while" - , "with" - , "yield" - ] - ++ -- reserved for future use - [ "class" - , "enum" - , "export" - , "extends" - , "import" - , "super" - ] - ++ -- special globals - [ "window" - , "document" - , "process" - , "exports" - , "module" - , "Date" - , "Error" - ] + = text $ asciiEncode isModule $ show name block :: Doc -> Doc block doc From e22fd00c31183d8777aa3728befbf449816dfb6f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Wed, 21 Feb 2024 11:13:29 +0100 Subject: [PATCH 08/48] Initial draft of data types + match --- src/Backend/VM/FromCore.hs | 317 ++++++++++++++++--------------------- 1 file changed, 135 insertions(+), 182 deletions(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index 7775441a8..86971735d 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -17,6 +17,7 @@ import Control.Monad import qualified Control.Monad.Fail as F import Data.List ( intersperse, partition ) import Data.Char +import Data.Bifunctor (bimap) import qualified Data.Set as S @@ -35,11 +36,11 @@ import Core.Pretty import Core.CoreVar type CommentDoc = Doc -type ConditionDoc = Doc +type ConditionDoc = Doc -> Doc -> Doc -- cd thn els debug :: Bool -debug = False +debug = True externalNames :: [(TName, Doc)] externalNames @@ -95,6 +96,9 @@ transformType (TFun ps e t) = obj [ "op" .= str "Function" ] transformType (TCon c) | nameModule (typeConName c) == "std/core/types" = case (nameStem (typeConName c)) of "unit" -> tpe "Unit" + "string" -> tpe "String" + "bool" -> tpe "Int" + "int" -> tpe "Int" t -> obj [ "op" .= str "Ptr", "extern_ptr_name" .= (str $ show t) ] transformType (TCon c) = obj [ "op" .= str "Ptr", "extern_ptr_name" .= (str $ show $ typeConName c) ] transformType (TApp t as) = transformType t @@ -153,25 +157,19 @@ genTypeDef (Data info isExtend) ConEnum{} -> debugWrap ("enum ") $ obj ["op" .= str "Literal", "type" .= str "Int", "value" .= int (conTag repr)] -- ConSingleton{} | conInfoName c == nameOptionalNone --- -> singletonValue "undefined" +-- -> null -- ConSingleton _ DataStructAsMaybe _ _ --- -> singletonValue "null" +-- -> null -- ConSingleton _ DataAsMaybe _ _ --- -> singletonValue "null" +-- -> null -- ConSingleton _ DataAsList _ _ --- -> singletonValue "null" - -- tagless - ConIso{} -> genConstr penv c repr name tp args [] - ConSingle{} -> genConstr penv c repr name tp args [] - ConAsCons{} -> genConstr penv c repr name tp args [] - ConAsJust{} -> genConstr penv c repr name tp args [] -- [(tagField, getConTag modName c repr)] - ConStruct{conDataRepr=DataStructAsMaybe} - -> genConstr penv c repr name tp args [] - -- normal with tag - _ -> genConstr penv c repr name tp args [(tagField, getConTag modName c repr)] +-- -> null + -- normal + _ -> genConstr penv c repr name tp args ) $ zip (dataInfoConstrs $ info) conReprs where - genConstr penv c repr name tp args tagFields + null = var (text "-1") (tpe "Ptr") + genConstr penv c repr name tp args = def (var name tp) (debugWrap "genConstr" $ obj [ "op" .= str "Abs", "params" .= list args , "body" .= obj [ "op" .= str "Construct" @@ -248,8 +246,8 @@ tryTailCall result expr then debugComment ("genOverride: skipped overriding `" ++ (show p) ++ "` with itself") else debugComment ("genOverride: preparing tailcall") <.> p <+> text "=" <+> a <.> semi ) (zip docs1 docs2) - return $ - linecomment (text "tail call") <-> vcat stmts <-> vcat assigns + return $ notImplemented $ + linecomment (text "tail call") <-> list (concat stmts) <-> vcat assigns -- if local variables are captured inside a tailcalling function argument, -- we need to capture it by value (instead of reference since we will overwrite the local variables on a tailcall) @@ -310,15 +308,18 @@ genExprStat result expr return (getResult result exprDoc) Case exprs branches - -> do (docs, scrutinees) <- fmap unzip $ mapM (\e-> if isInlineableExpr e && isTypeBool (typeOf e) + -> do (defss, scrutinees) <- unzip <$> mapM (\e-> if isInlineableExpr e && isTypeBool (typeOf e) then do d <- genInline e - return (text "", d) + return ([], d) else do (sd,vn) <- genVarBinding e - vd <- genTName vn + vd <- asVar vn return (sd, vd) ) exprs - doc <- genMatch result scrutinees branches - return (vcat docs <-> doc) + doc <- genMatch scrutinees branches + return $ obj [ "op" .= str "LetRec" + , "definitions" .= list (concat defss) + , "body" .= doc + ] Let groups body -> do defs <- genGroups False groups @@ -333,189 +334,129 @@ genExprStat result expr return (getResult result exprDoc) -- | Generates a statement for a match expression regarding a given return context -genMatch :: Result -> [Doc] -> [Branch] -> Asm Doc -genMatch result scrutinees branches +genMatch :: [Doc] -> [Branch] -> Asm Doc +genMatch scrutinees branches = fmap (debugWrap "genMatch") $ do case branches of [] -> fail ("Backend.VM.FromCore.genMatch: no branch in match statement: " ++ show(scrutinees)) - [b] -> fmap snd $ genBranch True result scrutinees b - - -- Special handling of return related cases - would be nice to get rid of it - [ Branch [p1] [Guard t1 (App (Var tn _) [r1])], Branch [p2] [Guard t2 e2] ] - | getName tn == nameReturn && - isPat True p1 && isPat False p2 && - isExprTrue t1 && isExprTrue t2 - -> case e2 of - App (Var tn _) [r2] - | getName tn == nameReturn - -> do (expr1) <- genExpr r1 - (expr2) <- genExpr r2 - return $ notImplemented $ text "if" <.> parens (head scrutinees) <+> block ( text "return" <+> expr1 <.> semi) - <-> text "else" <+> block ( text "return" <+> expr2 <.> semi) - _ -> do (expr1) <- genExpr r1 - (expr2) <- genExpr e2 - return $ notImplemented $ - (text "if" <.> parens (head scrutinees) <+> block ( text "return" <+> expr1 <.> semi)) - <--> - ( getResultX result (if (isExprUnit e2) then text "" else expr2,expr2)) - - [Branch [p1] [Guard t1 e1], Branch [p2] [Guard t2 e2]] - | isExprTrue t1 - && isExprTrue t2 - && isInlineableExpr e1 - && isInlineableExpr e2 - -> do modName <- getModule - let nameDoc = head scrutinees - let test = genTest modName (nameDoc, p1) - if (isExprTrue e1 && isExprFalse e2) - then return $ notImplemented $ getResult result $ parens (conjunction test) - else do doc1 <- withNameSubstitutions (getSubstitutions nameDoc p1) (genInline e1) - doc2 <- withNameSubstitutions (getSubstitutions nameDoc p2) (genInline e2) - return $ notImplemented $ debugWrap "genMatch: conditional expression" - $ getResult result - $ parens (conjunction test) <+> text "?" <+> doc1 <+> text ":" <+> doc2 + [b] -> do (conds, d) <- genBranch scrutinees b + return $ debugWrap "genMatch: one case" $ (conjunction conds) d (appPrim "non-exhaustive match" [] (tpe "Bottom")) bs | all (\b-> length (branchGuards b) == 1) bs && all (\b->isExprTrue $ guardTest $ head $ branchGuards b) bs - -> do xs <- mapM (withStatement . genBranch True result scrutinees) bs - return $ notImplemented $ debugWrap "genMatch: guard-free case" - $ hcat ( map (\(conds,d)-> text "if" <+> parens (conjunction conds) - <+> block d <-> text "else " - ) (init xs) - ) - <.> block (snd (last xs)) - - _ -> do (labelF, result') <- case result of - ResultReturn _ _ -> return (id, result) - ResultAssign n (Just _) -> return (id, result) -- wohoo, we can jump out from deep in! - ResultAssign n Nothing -> return ( \d-> text "match: " <.> block d - , ResultAssign n (Just $ newName "match") - ) - bs <- mapM (withStatement . genBranch False result' scrutinees) (init branches) - b <- (withStatement . genBranch True result' scrutinees) (last branches) + -> do xs <- mapM (withStatement . genBranch scrutinees) bs + let bs = foldr (.) id $ (map (\(conds,d) -> (conjunction conds d)) xs) + return $ debugWrap "genMatch: guard-free case" + $ bs $ (appPrim "non-exhaustive match" [] (tpe "Bottom")) + + _ -> do bs <- mapM (withStatement . genBranch scrutinees) branches let ds = map (\(cds,stmts)-> if null cds then stmts - else notImplemented $ text "if" <+> parens (conjunction cds) + else notImplemented $ text "if" <+> parens (conjunction cds (text "?thn") (text "?els")) <+> block stmts ) bs - let d = snd b - return $ debugWrap "genMatch: regular case" - $ labelF (vcat ds <-> d) + return $ notImplemented $ debugWrap "genMatch: regular case (with guards)" + (vcat ds) where -- | Generates a statement for a branch with given return context - genBranch :: Bool -> Result -> [Doc] -> Branch -> Asm ([ConditionDoc], Doc) + genBranch :: [Doc] -> Branch -> Asm ([ConditionDoc], Doc) -- Regular catch-all branch generation - genBranch lastBranch result tnDocs branch@(Branch patterns guards) + genBranch tnDocs branch@(Branch patterns guards) = do modName <- getModule - let substs = concatMap (uncurry getSubstitutions) (zip tnDocs patterns) - let conditions = concatMap (genTest modName) (zip tnDocs patterns) + (conditions, substs) <- bimap concat concat . unzip <$> mapM (genTest modName) (zip tnDocs patterns) let se = withNameSubstitutions substs - gs <- mapM (se . genGuard False result) (init guards) - g <- (se . genGuard lastBranch result) (last guards) - return (conditions, debugWrap ("genBranch: " ++ show substs) $ vcat gs <-> g) - - getSubstitutions :: Doc -> Pattern -> [(TName, Doc)] - getSubstitutions nameDoc pat - = case pat of - PatCon tn args repr _ _ _ info skip - -> -- trace ("pattern: " ++ show tn ++ ": " ++ show args ++ ", " ++ show info) $ - concatMap (\(pat',fn)-> getSubstitutions - (nameDoc <.> (if (getName tn == nameOptional || isConIso repr) then empty else (text "." <.> fn))) - pat' - ) - (zip args (map (ppName . fst) (conInfoParams info)) ) - PatVar tn pat' -> (tn, nameDoc):(getSubstitutions nameDoc pat') - PatWild -> [] - PatLit lit -> [] - - genGuard :: Bool -> Result -> Guard -> Asm Doc - genGuard lastBranchLastGuard result (Guard t expr) + gs <- mapM (se . genGuard) guards + return (conditions, debugWrap ("genBranch: " ++ show substs) $ vcat gs) + + genGuard :: Guard -> Asm Doc + genGuard (Guard t expr) = do (testE) <- genExpr t - let result' = case result of - ResultAssign n _ | lastBranchLastGuard -> ResultAssign n Nothing - _ -> result - exprSt <- genStat result' expr + exprSt <- genExpr expr return $ if isExprTrue t then exprSt else notImplemented $ text "if" <+> parens testE <.> block exprSt -- | Generates a list of boolish expression for matching the pattern - genTest :: Name -> (Doc, Pattern) -> [Doc] + genTest :: Name -> (Doc, Pattern) -> Asm ([ConditionDoc], [(TName, Doc)]) genTest modName (scrutinee,pattern) = case pattern of - PatWild -> [] - PatVar _ pat - -> genTest modName (scrutinee,pat) - PatLit lit - -> [scrutinee <+> text "===" <+> ppLit lit] + PatWild -> return $ ([], []) + PatVar tn pat + -> do (conds, substs) <- genTest modName (scrutinee,pat) + return (conds, (tn, scrutinee):substs) + PatLit (LitInt i) + -> return ([ifEqInt scrutinee (text (show i))], []) + PatLit lit@(LitString _) + -> let tmp = var (str "tmp") (tpe "Int") in + return ([(\thn els -> obj [ "op" .= str "Primitive" + , "name" .= str "infixEq(String, String): Boolean" + , "args" .= list [scrutinee, ppLit lit] + , "returns" .= list [tmp] + , "rest" .= ifEqInt tmp (text "1") thn els + ]) + ], []) PatCon tn fields repr _ _ _ info skip --TODO: skip test ? | getName tn == nameTrue - -> [scrutinee] + -> return ([ifEqInt scrutinee (text "1")], []) | getName tn == nameFalse - -> [text "!" <.> scrutinee] + -> return ([ifEqInt scrutinee (text "0")], []) | otherwise -> case repr of -- special ConEnum _ _ _ tag - -> [debugWrap "genTest: enum" $ scrutinee <+> text "===" <+> int tag] - ConSingleton{} - | getName tn == nameOptionalNone - -> [debugWrap "genTest: optional none" $ scrutinee <+> text "=== undefined"] - ConSingleton _ DataStructAsMaybe _ _ - -> [debugWrap "genTest: maybe like nothing" $ scrutinee <+> text "=== null"] -- <+> ppName (getName tn)] - ConSingleton _ DataAsMaybe _ _ - -> [debugWrap "genTest: maybe like nothing" $ scrutinee <+> text "=== null"] -- <+> ppName (getName tn)] - ConSingleton _ DataAsList _ _ - -> [debugWrap "genTest: list like nil" $ scrutinee <+> text "=== null"] -- <+> ppName (getName tn)] - ConSingleton{conTag=tag} - -> [debugWrap "genTest: singleton" $ scrutinee <.> dot <.> tagField <+> text "===" <+> int tag] - ConSingle{} -- always succeeds, but need to test the fields - -> concatMap - (\(field,fieldName) -> genTest modName ( - debugWrap ("genTest: single: " ++ show field ++ " -> " ++ show fieldName) $ - scrutinee <.> dot <.> fieldName, field) ) - (zip fields (map (ppName . fst) (conInfoParams info)) ) - - ConIso{} -- always success - -> [] - ConStruct{conDataRepr=DataStructAsMaybe} - | getName tn == nameOptional - -> [scrutinee <+> text "!== undefined"] ++ concatMap (\field -> genTest modName (scrutinee,field) ) fields - | otherwise - -> let conTest = debugWrap "genTest: asJust" $ scrutinee <+> text "!== null" - fieldTests = concatMap - (\(field,fieldName) -> genTest modName (scrutinee <.> dot <.> fieldName, field) ) - (zip fields (map (ppName . fst) (conInfoParams info)) ) - in (conTest:fieldTests) - ConAsJust{} - | getName tn == nameOptional - -> [scrutinee <+> text "!== undefined"] ++ concatMap (\field -> genTest modName (scrutinee,field) ) fields - | otherwise - -> let conTest = debugWrap "genTest: asJust" $ scrutinee <+> text "!== null" - fieldTests = concatMap - (\(field,fieldName) -> genTest modName (scrutinee <.> dot <.> fieldName, field) ) - (zip fields (map (ppName . fst) (conInfoParams info)) ) - in (conTest:fieldTests) - ConAsCons{} - -> let conTest = debugWrap "genTest: asCons" $ scrutinee <+> text "!== null" - fieldTests = concatMap - (\(field,fieldName) -> genTest modName (scrutinee <.> dot <.> fieldName, field) ) - (zip fields (map (ppName . fst) (conInfoParams info)) ) - in (conTest:fieldTests) - _ -> let conTest = debugWrap "genTest: normal" $ scrutinee <.> dot <.> tagField <+> text "===" <+> getConTag modName info repr - fieldTests = concatMap - (\(field,fieldName) -> genTest modName (debugWrap ("genTest: normal: " ++ show field ++ " -> " ++ show fieldName) $ scrutinee <.> dot <.> fieldName, field) ) - ( zip fields (map (ppName . fst) (conInfoParams info)) ) - in (conTest:fieldTests) + -> return ([ifEqInt scrutinee (int tag)], []) +-- ConSingleton{} +-- | getName tn == nameOptionalNone +-- -> [ifNull scrutinee] +-- ConSingleton _ DataStructAsMaybe _ _ +-- -> [ifNull scrutinee] -- <+> ppName (getName tn)] +-- ConSingleton _ DataAsMaybe _ _ +-- -> [ifNull scrutinee] -- <+> ppName (getName tn)] +-- ConSingleton _ DataAsList _ _ +-- -> [ifNull scrutinee] -- <+> ppName (getName tn)] + _ -> do fieldNames <- (mapM (\(n,t) -> do x <- genVarName (asString $ ppName n) + return $ var x (transformType t)) (conInfoParams info)) + let conTest = ifCon scrutinee (str $ show $ conInfoType info) (str $ show $ conInfoName info) fieldNames + (fieldTests, subfieldSubsts) <- (bimap concat concat) . unzip <$> mapM + (\(field,fieldName) -> genTest modName (debugWrap ("genTest: normal: " ++ show field ++ " -> " ++ show fieldName) fieldName, field) ) + ( zip fields fieldNames ) + -- let fieldSubsts = zipWith (\(n,t) x -> (TName n t, x)) + -- (conInfoParams info) fieldNames + return ((conTest:fieldTests), subfieldSubsts) -- ++ fieldSubsts) + + ifEqInt :: Doc -> Doc -> ConditionDoc + ifEqInt scrutinee lit thn els = obj [ "op" .= str "Switch" + , "scrutinee" .= scrutinee + , "cases" .= list [obj ["value" .= lit, "then" .= thn ]] + , "default" .= els + ] + + ifNull :: Doc -> ConditionDoc + ifNull scrutinee thn els = let tmp = var (str "tmp") (tpe "Int") in + obj [ "op" .= str "Primitive" + , "name" .= str "ptr_eq" + , "args" .= list [scrutinee, var (text "-1") (tpe "Ptr")] + , "returns" .= list [tmp] + , "rest" .= ifEqInt tmp (text "1") thn els + ] + + ifCon :: Doc -> Doc -> Doc -> [Doc] -> ConditionDoc + ifCon scrutinee tpt t fields thn els = debugWrap ("ifCon@" ++ asString scrutinee ++ ": " ++ asString tpt ++ "." ++ asString t ++ "(" ++ asString (tupled fields) ++ ")") + $ obj [ "op" .= str "Match" + , "scrutinee" .= scrutinee + , "type_tag" .= tpt + , "clauses" .= list [obj ["tag" .= t, "params" .= list fields, "body" .= thn]] + , "default_clause" .= obj ["params" .= list [], "body" .= els] + ] -- | Takes a list of docs and concatenates them with logical and - conjunction :: [Doc] -> Doc + conjunction :: [ConditionDoc] -> ConditionDoc conjunction [] - = text "true" - conjunction docs - = hcat (intersperse (text " && ") docs) + = \thn els -> thn + conjunction (doc:docs) + = \thn els -> doc ((conjunction docs) thn els) els --------------------------------------------------------------------------------- -- Expressions that produce statements on their way @@ -574,7 +515,10 @@ genExpr expr Let groups body -> do decls1 <- genGroups False groups (doc) <- genExpr body - return $ (notImplemented $ text "defs") -- (decls1 <-> decls2, doc) + return $ obj [ "op" .= str "Let" + , "definitions" .= list decls1 + , "body".= doc + ] Case _ _ -> do (doc, tname) <- genVarBinding expr @@ -622,13 +566,15 @@ genExprs exprs = mapM genExpr exprs -- | Introduces an additional let binding in core if necessary -- The expression in the result is guaranteed to be a Var afterwards -genVarBinding :: Expr -> Asm (Doc, TName) +genVarBinding :: Expr -> Asm ([Doc], TName) genVarBinding expr = case expr of - Var tn _ -> return $ (empty, tn) + Var tn _ -> return $ ([], tn) _ -> do name <- newVarName "x" - doc <- genStat (ResultAssign name Nothing) expr - return ( doc, TName name (typeOf expr) ) + let tp = typeOf expr + val <- genExpr expr + let defs = [def (var (str $ show name) (transformType tp)) val] + return ( defs, TName name (typeOf expr) ) --------------------------------------------------------------------------------- -- Pure expressions @@ -642,15 +588,19 @@ genPure expr Var name (InfoExternal formats) -> genWrapExternal name formats -- unapplied inlined external: wrap as function Var name info - -> return $ asVar name -- genTName name - Con name repr | nameModule (getName name) == "std/core/types" && nameStem (getName name) == "Unit" + -> asVar name -- genTName name + Con name repr | getName name == nameUnit -> return $ obj [ "op" .= str "Literal", "type" .= transformType (tnameType name) ] + Con name repr | getName name == nameTrue + -> return $ obj [ "op" .= str "Literal", "value" .= text "1", "type" .= transformType (tnameType name) ] + Con name repr | getName name == nameFalse + -> return $ obj [ "op" .= str "Literal", "value" .= text "0", "type" .= transformType (tnameType name) ] Con name repr - -> return $ asVar name + -> asVar name Lit l -> return $ ppLit l Lam params eff body - -> do let args = map asVar params + -> do args <- mapM asVar params bodyDoc <- genStat (ResultReturn Nothing params) body return $ obj [ "op" .= str "Abs" , "params" .= list args @@ -1152,8 +1102,11 @@ notImplemented doc = appPrim ("Not implemented: " ++ show (asString doc)) [] (tp var :: Doc -> Doc -> Doc var x t = obj [ "op" .= str "Var", "id" .= x, "type" .= t ] -asVar :: TName -> Doc -asVar n = var (str $ show $ getName n) (transformType $ tnameType n) +asVar :: TName -> Asm Doc +asVar n = do env <- getEnv + case lookup n (substEnv env) of + Nothing -> return $ var (str $ show $ getName n) (transformType $ tnameType n) + Just s -> return s ---- Types tFn :: String -> [Doc] -> Doc -> Doc From b28bd35d000bb83da79b32951fc2462ac9f8892a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Wed, 21 Feb 2024 11:57:52 +0100 Subject: [PATCH 09/48] Fix type tags for constructors --- src/Backend/VM/FromCore.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index 86971735d..3008d6a52 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -173,12 +173,14 @@ genTypeDef (Data info isExtend) = def (var name tp) (debugWrap "genConstr" $ obj [ "op" .= str "Abs", "params" .= list args , "body" .= obj [ "op" .= str "Construct" - , "type_tag" .= (str $ show $ conInfoType c) + , "type_tag" .= (getConTypeTag c) , "tag" .= name , "args" .= list args ] ]) +getConTypeTag info = case conInfoType info of + TFun _ _ r -> str $ show $ r getConTag modName coninfo repr = case repr of ConOpen{} -> -- ppLit (LitString (show (openConTag (conInfoName coninfo)))) @@ -418,7 +420,7 @@ genMatch scrutinees branches -- -> [ifNull scrutinee] -- <+> ppName (getName tn)] _ -> do fieldNames <- (mapM (\(n,t) -> do x <- genVarName (asString $ ppName n) return $ var x (transformType t)) (conInfoParams info)) - let conTest = ifCon scrutinee (str $ show $ conInfoType info) (str $ show $ conInfoName info) fieldNames + let conTest = ifCon scrutinee (getConTypeTag info) (str $ show $ conInfoName info) fieldNames (fieldTests, subfieldSubsts) <- (bimap concat concat) . unzip <$> mapM (\(field,fieldName) -> genTest modName (debugWrap ("genTest: normal: " ++ show field ++ " -> " ++ show fieldName) fieldName, field) ) ( zip fields fieldNames ) From 8d45ecfcd41a7a1007d9c6d74af2717ea0f94599 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Thu, 7 Mar 2024 12:10:30 +0100 Subject: [PATCH 10/48] WIP Basic support for separate compilation --- src/Backend/VM/FromCore.hs | 33 +++++++++++++++++++++++++-------- src/Compile/Options.hs | 4 ++-- 2 files changed, 27 insertions(+), 10 deletions(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index 3008d6a52..75d2d6242 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -15,7 +15,7 @@ import Lib.Trace import Control.Applicative hiding (empty) import Control.Monad import qualified Control.Monad.Fail as F -import Data.List ( intersperse, partition ) +import Data.List ( intersperse, partition, nub ) import Data.Char import Data.Bifunctor (bimap) @@ -62,7 +62,8 @@ vmFromCore buildType mbMain imports core genModule :: BuildType -> Maybe (Name,Bool) -> [Import] -> Core -> Asm Doc genModule buildType mbMain imports core - = do decls0 <- genGroups True (coreProgDefs core) + = do impdecls <- genLoadLibs imports + decls0 <- genGroups True (coreProgDefs core) decls1 <- genTypeDefs (coreProgTypeDefs core) let -- `imports = coreProgImports core` is not enough due to inlined definitions (mainEntry) = case mbMain of @@ -77,13 +78,24 @@ genModule buildType mbMain imports core , "program name" .= str (show (coreProgName core)) ] , "definitions" .= - list (decls0 + list (impdecls + ++ decls0 ++ decls1 ) , "main" .= mainEntry ] --------------------------------------------------------------------------------- +-- Generate import definitions +--------------------------------------------------------------------------------- +genLoadLibs :: [Import] -> Asm [Doc] +genLoadLibs imports = return $ map genLoadLib $ imports + where genLoadLib imp = let name = (if null (importPackage imp) then "." else importPackage imp) ++ "/" ++ (moduleNameToPath (importName imp)) in + def (var (str ("import$" ++ show (importName imp))) (tpe "Ptr")) + (obj [ "op" .= str "LoadLib" + , "path" .= obj [ "op" .= str "Literal", "type" .= tpe "String", "format" .= str "path", "value" .= str ("$0/" ++ name ++ ".rpyeffect")] + ]) +--------------------------------------------------------------------------------- -- Translate types --------------------------------------------------------------------------------- transformType :: Type -> Doc @@ -179,8 +191,11 @@ genTypeDef (Data info isExtend) ] ]) -getConTypeTag info = case conInfoType info of - TFun _ _ r -> str $ show $ r +getConTypeTag info = getReturn $ conInfoType info + where + getReturn (TFun _ _ r) = str $ show $ r + getReturn (TForall _ _ t) = getReturn t + getReturn t = error $ "Constructor does not have a function type: " ++ show t getConTag modName coninfo repr = case repr of ConOpen{} -> -- ppLit (LitString (show (openConTag (conInfoName coninfo)))) @@ -523,7 +538,8 @@ genExpr expr ] Case _ _ - -> do (doc, tname) <- genVarBinding expr + -> -- trace "Case" $ + do (doc, tname) <- genVarBinding expr nameDoc <- genTName tname return $ notImplemented $ text "Case" -- (doc, nameDoc) @@ -574,7 +590,7 @@ genVarBinding expr Var tn _ -> return $ ([], tn) _ -> do name <- newVarName "x" let tp = typeOf expr - val <- genExpr expr + val <- genExprStat (ResultReturn Nothing []) expr let defs = [def (var (str $ show name) (transformType tp)) val] return ( defs, TName name (typeOf expr) ) @@ -622,7 +638,8 @@ isPat b q -- NOTE: Throws an error if expression is not guaranteed to be effectfree genInline :: Expr -> Asm Doc genInline expr - = case expr of + = -- trace "genInline" $ + case expr of _ | isPureExpr expr -> genPure expr TypeLam _ e -> genInline e TypeApp e _ -> genInline e diff --git a/src/Compile/Options.hs b/src/Compile/Options.hs index cee27b7e7..49678ba19 100644 --- a/src/Compile/Options.hs +++ b/src/Compile/Options.hs @@ -1061,7 +1061,7 @@ targetExeExtension target C _ -> exeExtension JS JsWeb -> ".html" JS _ -> ".mjs" - VM -> ".rpyeffect" + VM -> ".mcore.json" _ -> exeExtension targetObjExtension target @@ -1071,7 +1071,7 @@ targetObjExtension target C WasmWeb-> ".o" C _ -> objExtension JS _ -> ".mjs" - VM -> ".rpyeffect" + VM -> ".mcore.json" _ -> objExtension targetLibFile target fname From 57a0f2f5c5ac2af009fab21ec397e5d6d9862cd2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Thu, 7 Mar 2024 16:22:19 +0100 Subject: [PATCH 11/48] Remove some dead code --- src/Backend/VM/FromCore.hs | 215 ++++--------------------------------- 1 file changed, 21 insertions(+), 194 deletions(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index 75d2d6242..f947d25be 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -35,9 +35,7 @@ import Core.Core import Core.Pretty import Core.CoreVar -type CommentDoc = Doc -type ConditionDoc = Doc -> Doc -> Doc -- cd thn els - +type ConditionDoc = Doc -> Doc -> Doc -- `cd thn els` gets you the doc debug :: Bool debug = True @@ -55,7 +53,7 @@ externalNames vmFromCore :: BuildType -> Maybe (Name,Bool) -> [Import] -> Core -> Doc vmFromCore buildType mbMain imports core - = runAsm (Env moduleName penv externalNames False) (genModule buildType mbMain imports core) + = runAsm (Env moduleName penv externalNames) (genModule buildType mbMain imports core) where moduleName = coreProgName core penv = Pretty.defaultEnv{ Pretty.context = moduleName, Pretty.fullNames = False } @@ -88,10 +86,11 @@ genModule buildType mbMain imports core --------------------------------------------------------------------------------- -- Generate import definitions --------------------------------------------------------------------------------- +libName imp = (var (str ("import$" ++ imp)) (tpe "Ptr")) genLoadLibs :: [Import] -> Asm [Doc] -genLoadLibs imports = return $ map genLoadLib $ imports +genLoadLibs imports = return $ map genLoadLib imports where genLoadLib imp = let name = (if null (importPackage imp) then "." else importPackage imp) ++ "/" ++ (moduleNameToPath (importName imp)) in - def (var (str ("import$" ++ show (importName imp))) (tpe "Ptr")) + def (libName (show $ importName imp)) (obj [ "op" .= str "LoadLib" , "path" .= obj [ "op" .= str "Literal", "type" .= tpe "String", "format" .= str "path", "value" .= str ("$0/" ++ name ++ ".rpyeffect")] ]) @@ -227,94 +226,9 @@ getResultX result (puredoc,retdoc) Nothing -> empty Just l -> text "break" <+> ppName l <.> semi -tryTailCall :: Result -> Expr -> Asm (Maybe Doc) -tryTailCall result expr - = case expr of - -- Tailcall case 1 - App (Var n info) args | ( case result of - ResultReturn (Just m) _ -> m == getName n && infoArity info == (length args) - _ -> False - ) - -> do let (ResultReturn _ params) = result - stmts <- genOverride params args - return $ Just $ notImplemented $ block $ stmts <-> tailcall - - -- Tailcall case 2 - App (TypeApp (Var n info) _) args | ( case result of - ResultReturn (Just m) _ -> m == getName n && infoArity info == (length args) - _ -> False - ) - -> do let (ResultReturn _ params) = result - stmts <- genOverride params args - return $ Just $ notImplemented $ block $ stmts <-> tailcall - - _ -> return Nothing - where - -- overriding function arguments carefully - genOverride :: [TName] -> [Expr] -> Asm Doc - genOverride params args - = fmap (debugWrap "genOverride") $ - do (stmts, varNames) <- do args' <- mapM tailCallArg args - bs <- mapM genVarBinding args' - return (unzip bs) - docs1 <- mapM genTName params - docs2 <- mapM genTName varNames - let assigns = map (\(p,a)-> if p == a - then debugComment ("genOverride: skipped overriding `" ++ (show p) ++ "` with itself") - else debugComment ("genOverride: preparing tailcall") <.> p <+> text "=" <+> a <.> semi - ) (zip docs1 docs2) - return $ notImplemented $ - linecomment (text "tail call") <-> list (concat stmts) <-> vcat assigns - - -- if local variables are captured inside a tailcalling function argument, - -- we need to capture it by value (instead of reference since we will overwrite the local variables on a tailcall) - -- we do this by wrapping the argument inside another function application. - tailCallArg :: Expr -> Asm Expr - tailCallArg expr - = let captured = filter (not . isQualified . getName) $ tnamesList $ capturedVar expr - in if (null captured) - then return expr - else -- trace ("Backend.JavaScript.FromCore.tailCall: capture: " ++ show captured ++ ":\n" ++ show expr) $ - do ns <- mapM (newVarName . show) captured - let cnames = [TName cn tp | (cn,TName _ tp) <- zip ns captured] - sub = [(n,Var cn InfoNone) | (n,cn) <- zip captured cnames] - return $ App (Lam cnames typeTotal (sub |~> expr)) [Var arg InfoNone | arg <- captured] - - capturedVar :: Expr -> TNames - capturedVar expr - = case expr of - Lam _ _ _ -> fv expr -- we only care about captures inside a lambda - Let bgs body -> S.unions (capturedVar body : map capturedDefGroup bgs) - Case es bs -> S.unions (map capturedVar es ++ map capturedBranch bs) - App f args -> S.unions (capturedVar f : map capturedVar args) - TypeLam _ e -> capturedVar e - TypeApp e _ -> capturedVar e - _ -> S.empty - - capturedDefGroup bg - = case bg of - DefRec defs -> S.difference (S.unions (map capturedDef defs)) (bv defs) - DefNonRec def-> capturedDef def - - capturedDef def - = capturedVar (defExpr def) - - capturedBranch (Branch pat grds) - = S.difference (S.unions (map capturedGuard grds)) (bv pat) - - capturedGuard (Guard test expr) - = S.union (capturedVar test) (capturedVar expr) - -- | Generates a statement from an expression by applying a return context (deeply) inside genStat :: Result -> Expr -> Asm Doc -genStat result expr - = fmap (debugWrap "genStat") $ - do mdoc <- tryTailCall result expr - case mdoc of - Just doc - -> return doc - Nothing - -> genExprStat result expr +genStat result expr = genExprStat result expr genExprStat result expr @@ -362,16 +276,16 @@ genMatch scrutinees branches bs | all (\b-> length (branchGuards b) == 1) bs && all (\b->isExprTrue $ guardTest $ head $ branchGuards b) bs - -> do xs <- mapM (withStatement . genBranch scrutinees) bs + -> do xs <- mapM (genBranch scrutinees) bs let bs = foldr (.) id $ (map (\(conds,d) -> (conjunction conds d)) xs) return $ debugWrap "genMatch: guard-free case" $ bs $ (appPrim "non-exhaustive match" [] (tpe "Bottom")) - _ -> do bs <- mapM (withStatement . genBranch scrutinees) branches + _ -> do bs <- mapM (genBranch scrutinees) branches let ds = map (\(cds,stmts)-> if null cds then stmts else notImplemented $ text "if" <+> parens (conjunction cds (text "?thn") (text "?els")) - <+> block stmts + -- <+> block stmts ) bs return $ notImplemented $ debugWrap "genMatch: regular case (with guards)" (vcat ds) @@ -393,7 +307,7 @@ genMatch scrutinees branches exprSt <- genExpr expr return $ if isExprTrue t then exprSt - else notImplemented $ text "if" <+> parens testE <.> block exprSt + else notImplemented $ text "if" -- <+> parens testE <.> block exprSt -- | Generates a list of boolish expression for matching the pattern genTest :: Name -> (Doc, Pattern) -> Asm ([ConditionDoc], [(TName, Doc)]) @@ -564,21 +478,6 @@ genList elems tl (tdoc) <- genExpr tl return (text "$std_core_vector.vlist" <.> tupled [list docs, tdoc]) -{- -genExternalExpr :: TName -> String -> [Expr] -> Asm (Doc,Doc) -genExternalExpr tname format args - | getName tname == nameReturn - = do (statDoc,exprDoc) <- genExpr (head args) - return (statDoc <-> text "return" <+> exprDoc <.> semi <.> debugComment "premature return statement (2)" - , text "") -- emptyness of doc is important! no other way to tell to not generate assignment/return/whatever! - | otherwise - = do (statDocs,argDocs) <- genExprs args - doc <- genExternal tname format argDocs - return ( debugComment "" <.> vcat statDocs <.> debugComment "" - , debugComment "" <.> doc <.> debugComment "" - ) --} - genExprs :: [Expr] -> Asm [Doc] genExprs exprs = mapM genExpr exprs @@ -681,7 +580,7 @@ genWrapExternal tname formats = do let n = snd (getTypeArities (typeOf tname)) vs <- genVarNames n (doc) <- genExprExternal tname formats vs - return $ notImplemented $ parens (text "function" <.> tupled vs <+> block (vcat ([text "return" <+> doc <.> semi]))) + return $ notImplemented $ parens (text "function" ) -- <.> tupled vs <+> block (vcat ([text "return" <+> doc <.> semi]))) -- inlined external sometimes needs wrapping in a applied function block genInlineExternal :: TName -> [(Target,String)] -> [Doc] -> Asm Doc @@ -699,10 +598,10 @@ genExprExternal tname formats argDocs0 [] -> return (doc) _ -> -- has an exception type, wrap it in a try handler let try = parens $ - parens (text "function()" <+> block (vcat ( - [text "try" <+> block (vcat ([text "return" <+> doc <.> semi])) - ,text "catch(_err){ return $std_core._throw_exception(_err); }"] - ))) + parens (text "function()") -- <+> block (vcat ( + -- [text "try" <+> block (vcat ([text "return" <+> doc <.> semi])) + -- ,text "catch(_err){ return $std_core._throw_exception(_err); }"] + -- ))) <.> text "()" in return $ notImplemented (try) @@ -741,16 +640,16 @@ genTName :: TName -> Asm Doc genTName tname = do env <- getEnv case lookup tname (substEnv env) of - Nothing -> genName (getName tname) + Nothing -> genName (getName tname) (tnameType tname) Just d -> return d -genName :: Name -> Asm Doc -genName name +genName :: Name -> Type -> Asm Doc +genName name tpe = if (isQualified name) then do modname <- getModule if (qualifier name == modname) then return (ppName (unqualify name)) - else return (ppName name) + else return $ obj [ "op" .= str "Qualified", "lib" .= libName (nameModule name), "name" .= (ppName name), "type" .= transformType tpe ] else return (ppName name) genVarName :: String -> Asm Doc @@ -766,7 +665,7 @@ genVarNames i = do ns <- newVarNames i genCommentTName :: TName -> Asm Doc genCommentTName (TName n t) = do env <- getPrettyEnv - return $ ppName n <+> comment (Pretty.ppType env t ) + return $ ppName n -- <+> comment (Pretty.ppType env t ) trimOptionalArgs args = reverse (dropWhile isOptionalNone (reverse args)) @@ -887,7 +786,6 @@ data St = St { uniq :: Int data Env = Env { moduleName :: Name -- | current module , prettyEnv :: Pretty.Env -- | for printing nice types , substEnv :: [(TName, Doc)] -- | substituting names - , inStatement :: Bool -- | for generating correct function declarations in strict mode } data Result = ResultReturn (Maybe Name) [TName] -- first field carries function name if not anonymous and second the arguments which are always known @@ -942,28 +840,13 @@ getPrettyEnv = do env <- getEnv return (prettyEnv env) -withTypeVars :: [TypeVar] -> Asm a -> Asm a -withTypeVars vars asm - = withEnv (\env -> env{ prettyEnv = Pretty.niceEnv (prettyEnv env) vars }) asm - withNameSubstitutions :: [(TName, Doc)] -> Asm a -> Asm a withNameSubstitutions subs asm = withEnv (\env -> env{ substEnv = subs ++ substEnv env }) asm -withStatement :: Asm a -> Asm a -withStatement asm - = withEnv (\env -> env{ inStatement = True }) asm - -getInStatement :: Asm Bool -getInStatement - = do env <- getEnv - return (inStatement env) - --------------------------------------------------------------------------------- -- Pretty printing --------------------------------------------------------------------------------- - - ppLit :: Lit -> Doc ppLit lit = case lit of @@ -992,11 +875,6 @@ ppLit lit lo = (code `mod` 0x0400) + 0xDC00 in text ("\\u" ++ showHex 4 hi ++ "\\u" ++ showHex 4 lo) -isSmallLitInt expr - = case expr of - Lit (LitInt i) -> isSmallInt i - _ -> False - isSmallInt i = (i > minSmallInt && i < maxSmallInt) maxSmallInt, minSmallInt :: Integer @@ -1009,12 +887,6 @@ ppName name then ppModName (qualifier name) <.> dot <.> encode False (unqualify name) else encode False name -ppQName :: Name -> Name -> Doc -ppQName modName name - = if (modName == qualifier name) -- We need to qualify always since otherwise we may clash with local variables. i.e. fun f( x : int ) { Main.x( x ) } - then ppName (unqualify name) - else ppName name - ppModName :: Name -> Doc ppModName name = text "$" <.> encode True (name) @@ -1023,45 +895,6 @@ encode :: Bool -> Name -> Doc encode isModule name = text $ asciiEncode isModule $ show name -block :: Doc -> Doc -block doc - = text "{" <--> tab doc <--> text "}" - - -tcoBlock :: Doc -> Doc -tcoBlock doc - = text "{ tailcall: while(1)" <-> - text "{" <--> tab ( doc ) <--> text "}}" - -tailcall :: Doc -tailcall = text "continue tailcall;" - -object :: [(Doc, Doc)] -> Doc -object xs - = text "{" <+> hcat ( punctuate (comma <.> space) (map f xs) ) <+> text "}" - where - f (d1, d2) = d1 <.> colon <+> d2 - -tab :: Doc -> Doc -tab doc - = indent 2 doc - -typeComment = comment - -comment :: Doc -> Doc -comment d - = text "/*" <+> d <+> text "*/ " - -linecomment :: Doc -> Doc -linecomment d - = text "//" <+> d - -debugComment :: String -> Doc -debugComment s - = if debug - then comment (text s) - else empty - debugWrap :: String -> Doc -> Doc debugWrap s d = if debug then obj [ @@ -1070,12 +903,6 @@ debugWrap s d "annotation" .= str s ] else d -tagField :: Doc -tagField = text "_tag" - -constdecl :: Doc -constdecl = text "const" - quoted :: Doc -> Doc quoted d = text $ show $ asString d @@ -1143,4 +970,4 @@ tpe name = obj [ "op" .= text (show name) ] -- | Definitions def :: Doc -> Doc -> Doc -def n v = obj [ "name" .= n, "value" .= v ] +def n v = obj [ "name" .= n, "value" .= v ] \ No newline at end of file From d5019b1aaf60d6200c823f5af7e7ea642d229082 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 8 Mar 2024 10:17:56 +0100 Subject: [PATCH 12/48] VM backend: refactor: Remove `Result` type --- src/Backend/VM/FromCore.hs | 35 ++++++----------------------------- 1 file changed, 6 insertions(+), 29 deletions(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index f947d25be..1625aaf92 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -209,34 +209,14 @@ openConTag name -- Statements --------------------------------------------------------------------------------- --- | Applies a return context -getResult :: Result -> Doc -> Doc -getResult result doc - = if isEmptyDoc doc - then text "" - else getResultX result (doc,doc) - -getResultX result (puredoc,retdoc) - = case result of - ResultReturn _ _ -> retdoc - ResultAssign n ml -> notImplemented $ ( if isWildcard n - then (if (isEmptyDoc puredoc) then puredoc else puredoc <.> semi) - else text "var" <+> ppName (unqualify n) <+> text "=" <+> retdoc <.> semi - ) <-> case ml of - Nothing -> empty - Just l -> text "break" <+> ppName l <.> semi - -- | Generates a statement from an expression by applying a return context (deeply) inside -genStat :: Result -> Expr -> Asm Doc -genStat result expr = genExprStat result expr - -genExprStat result expr +genExprStat expr = case expr of -- If expression is inlineable, inline it _ | isInlineableExpr expr -> do exprDoc <- genInline expr - return (getResult result exprDoc) + return exprDoc Case exprs branches -> do (defss, scrutinees) <- unzip <$> mapM (\e-> if isInlineableExpr e && isTypeBool (typeOf e) @@ -254,7 +234,7 @@ genExprStat result expr Let groups body -> do defs <- genGroups False groups - body <- genStat result body + body <- genExprStat body return $ obj [ "op" .= str "LetRec" , "definitions" .= list defs , "body" .= body @@ -262,7 +242,7 @@ genExprStat result expr -- Handling all other cases _ -> do (exprDoc) <- genExpr expr - return (getResult result exprDoc) + return exprDoc -- | Generates a statement for a match expression regarding a given return context genMatch :: [Doc] -> [Branch] -> Asm Doc @@ -489,7 +469,7 @@ genVarBinding expr Var tn _ -> return $ ([], tn) _ -> do name <- newVarName "x" let tp = typeOf expr - val <- genExprStat (ResultReturn Nothing []) expr + val <- genExprStat expr let defs = [def (var (str $ show name) (transformType tp)) val] return ( defs, TName name (typeOf expr) ) @@ -518,7 +498,7 @@ genPure expr -> return $ ppLit l Lam params eff body -> do args <- mapM asVar params - bodyDoc <- genStat (ResultReturn Nothing params) body + bodyDoc <- genExprStat body return $ obj [ "op" .= str "Abs" , "params" .= list args , "body" .= bodyDoc @@ -788,9 +768,6 @@ data Env = Env { moduleName :: Name -- | current modul , substEnv :: [(TName, Doc)] -- | substituting names } -data Result = ResultReturn (Maybe Name) [TName] -- first field carries function name if not anonymous and second the arguments which are always known - | ResultAssign Name (Maybe Name) -- variable name and optional label to break - initSt = St 0 instance HasUnique Asm where From a4bf1ac6162b74b5be645c500d43c85f9efd62bf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 8 Mar 2024 10:20:04 +0100 Subject: [PATCH 13/48] VM: treat all ints equally --- src/Backend/VM/FromCore.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index 1625aaf92..2046799a0 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -531,17 +531,13 @@ genInline expr case extractExtern f of Just (tname,formats) -> case args of - [Lit (LitInt i)] | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT] && isSmallInt i + [Lit (LitInt i)] | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT, nameInt64,nameIntPtrT] && isSmallInt i -> return (pretty i) - [Lit (LitInt i)] | getName tname `elem` [nameInt64,nameIntPtrT] && isSmallInt i - -> return $ notImplemented $ (pretty i <.> text "n") _ -> genInlineExternal tname formats argDocs Nothing -> case (f,args) of - ((Var tname _),[Lit (LitInt i)]) | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT] && isSmallInt i + ((Var tname _),[Lit (LitInt i)]) | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT,nameInt64,nameIntPtrT] && isSmallInt i -> return (pretty i) - ((Var tname _),[Lit (LitInt i)]) | getName tname `elem` [nameInt64,nameIntPtrT] && isSmallInt i - -> return (pretty i <.> text "n") _ -> do fdoc <- genInline f return $ notImplemented $ (fdoc <.> tupled argDocs) From c722e5094f0aa0da649c5ffbd97024d94579051b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 8 Mar 2024 10:25:20 +0100 Subject: [PATCH 14/48] VM: Partially-applied externs --- src/Backend/VM/FromCore.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index 2046799a0..b794d5472 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -541,7 +541,7 @@ genInline expr _ -> do fdoc <- genInline f return $ notImplemented $ (fdoc <.> tupled argDocs) - _ -> failure ("JavaScript.FromCore.genInline: invalid expression:\n" ++ show expr) + _ -> failure ("VM.FromCore.genInline: invalid expression:\n" ++ show expr) extractExtern :: Expr -> Maybe (TName,[(Target,String)]) extractExtern expr @@ -555,8 +555,12 @@ genWrapExternal :: TName -> [(Target,String)] -> Asm Doc genWrapExternal tname formats = do let n = snd (getTypeArities (typeOf tname)) vs <- genVarNames n - (doc) <- genExprExternal tname formats vs - return $ notImplemented $ parens (text "function" ) -- <.> tupled vs <+> block (vcat ([text "return" <+> doc <.> semi]))) + doc <- genExprExternal tname formats vs + return $ obj [ "op" .= str "Abs" + , "params" .= list vs + , "body" .= doc + ] + -- $ notImplemented $ parens (text "function" ) -- <.> tupled vs <+> block (vcat ([text "return" <+> doc <.> semi]))) -- inlined external sometimes needs wrapping in a applied function block genInlineExternal :: TName -> [(Target,String)] -> [Doc] -> Asm Doc From e56e6420fa6a0ec9b7a4252bc305a8fd629d4451 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 8 Mar 2024 11:38:00 +0100 Subject: [PATCH 15/48] Use AlternativeChoice/Fail to generate match clauses --- src/Backend/VM/FromCore.hs | 53 +++++++++++++++++++------------------- 1 file changed, 26 insertions(+), 27 deletions(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index b794d5472..f4ef406e5 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -35,7 +35,7 @@ import Core.Core import Core.Pretty import Core.CoreVar -type ConditionDoc = Doc -> Doc -> Doc -- `cd thn els` gets you the doc +type ConditionDoc = Doc -> Doc -- `cd thn` gets you the doc; expects to be in an alternative-choice debug :: Bool debug = True @@ -251,24 +251,25 @@ genMatch scrutinees branches case branches of [] -> fail ("Backend.VM.FromCore.genMatch: no branch in match statement: " ++ show(scrutinees)) [b] -> do (conds, d) <- genBranch scrutinees b - return $ debugWrap "genMatch: one case" $ (conjunction conds) d (appPrim "non-exhaustive match" [] (tpe "Bottom")) + return $ debugWrap "genMatch: one case" $ obj [ "op" .= str "AlternativeChoice" + , "choices" .= list [(conjunction conds) d, (appPrim "non-exhaustive match" [] (tpe "Bottom"))] + ] bs | all (\b-> length (branchGuards b) == 1) bs && all (\b->isExprTrue $ guardTest $ head $ branchGuards b) bs -> do xs <- mapM (genBranch scrutinees) bs - let bs = foldr (.) id $ (map (\(conds,d) -> (conjunction conds d)) xs) + let bs = map (\(conds,d) -> (conjunction conds d)) xs return $ debugWrap "genMatch: guard-free case" - $ bs $ (appPrim "non-exhaustive match" [] (tpe "Bottom")) + $ obj [ "op" .= str "AlternativeChoice" + , "choices" .= list (bs ++ [appPrim "non-exhaustive match" [] (tpe "Bottom")]) + ] _ -> do bs <- mapM (genBranch scrutinees) branches - let ds = map (\(cds,stmts)-> if null cds - then stmts - else notImplemented $ text "if" <+> parens (conjunction cds (text "?thn") (text "?els")) - -- <+> block stmts - ) bs - return $ notImplemented $ debugWrap "genMatch: regular case (with guards)" - (vcat ds) + let ds = map (\(cds,stmts)-> conjunction cds stmts) bs + return $ obj [ "op" .= str "AlternativeChoice" + , "choices" .= list ds + ] where -- | Generates a statement for a branch with given return context genBranch :: [Doc] -> Branch -> Asm ([ConditionDoc], Doc) @@ -283,12 +284,12 @@ genMatch scrutinees branches genGuard :: Guard -> Asm Doc genGuard (Guard t expr) - = do (testE) <- genExpr t - exprSt <- genExpr expr + = do testE <- genExpr t + exprSt <- genExpr expr return $ if isExprTrue t then exprSt - else notImplemented $ text "if" -- <+> parens testE <.> block exprSt - + else ifEqInt testE (text "1") exprSt + -- | Generates a list of boolish expression for matching the pattern genTest :: Name -> (Doc, Pattern) -> Asm ([ConditionDoc], [(TName, Doc)]) genTest modName (scrutinee,pattern) @@ -301,11 +302,11 @@ genMatch scrutinees branches -> return ([ifEqInt scrutinee (text (show i))], []) PatLit lit@(LitString _) -> let tmp = var (str "tmp") (tpe "Int") in - return ([(\thn els -> obj [ "op" .= str "Primitive" + return ([(\thn -> obj [ "op" .= str "Primitive" , "name" .= str "infixEq(String, String): Boolean" , "args" .= list [scrutinee, ppLit lit] , "returns" .= list [tmp] - , "rest" .= ifEqInt tmp (text "1") thn els + , "rest" .= ifEqInt tmp (text "1") thn ]) ], []) PatCon tn fields repr _ _ _ info skip --TODO: skip test ? @@ -338,36 +339,34 @@ genMatch scrutinees branches return ((conTest:fieldTests), subfieldSubsts) -- ++ fieldSubsts) ifEqInt :: Doc -> Doc -> ConditionDoc - ifEqInt scrutinee lit thn els = obj [ "op" .= str "Switch" + ifEqInt scrutinee lit thn = obj [ "op" .= str "Switch" , "scrutinee" .= scrutinee , "cases" .= list [obj ["value" .= lit, "then" .= thn ]] - , "default" .= els + , "default" .= obj ["op" .= str "AlternativeFail"] ] ifNull :: Doc -> ConditionDoc - ifNull scrutinee thn els = let tmp = var (str "tmp") (tpe "Int") in + ifNull scrutinee thn = let tmp = var (str "tmp") (tpe "Int") in obj [ "op" .= str "Primitive" , "name" .= str "ptr_eq" , "args" .= list [scrutinee, var (text "-1") (tpe "Ptr")] , "returns" .= list [tmp] - , "rest" .= ifEqInt tmp (text "1") thn els + , "rest" .= ifEqInt tmp (text "1") thn ] ifCon :: Doc -> Doc -> Doc -> [Doc] -> ConditionDoc - ifCon scrutinee tpt t fields thn els = debugWrap ("ifCon@" ++ asString scrutinee ++ ": " ++ asString tpt ++ "." ++ asString t ++ "(" ++ asString (tupled fields) ++ ")") + ifCon scrutinee tpt t fields thn = debugWrap ("ifCon@" ++ asString scrutinee ++ ": " ++ asString tpt ++ "." ++ asString t ++ "(" ++ asString (tupled fields) ++ ")") $ obj [ "op" .= str "Match" , "scrutinee" .= scrutinee , "type_tag" .= tpt , "clauses" .= list [obj ["tag" .= t, "params" .= list fields, "body" .= thn]] - , "default_clause" .= obj ["params" .= list [], "body" .= els] + , "default_clause" .= obj ["params" .= list [], "body" .= obj ["op" .= str "AlternativeFail"]] ] -- | Takes a list of docs and concatenates them with logical and conjunction :: [ConditionDoc] -> ConditionDoc - conjunction [] - = \thn els -> thn - conjunction (doc:docs) - = \thn els -> doc ((conjunction docs) thn els) els + conjunction [] = id + conjunction (doc:docs) = doc . (conjunction docs) --------------------------------------------------------------------------------- -- Expressions that produce statements on their way From 61cec889173084180c9f7a98f1f97474784fc1c4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 8 Mar 2024 11:46:52 +0100 Subject: [PATCH 16/48] VM: Complete some missing implementations --- src/Backend/VM/FromCore.hs | 41 ++++++++++---------------------------- 1 file changed, 10 insertions(+), 31 deletions(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index f4ef406e5..d092ac7b2 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -538,8 +538,10 @@ genInline expr ((Var tname _),[Lit (LitInt i)]) | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT,nameInt64,nameIntPtrT] && isSmallInt i -> return (pretty i) _ -> do fdoc <- genInline f - return $ notImplemented $ (fdoc <.> tupled argDocs) - + return $ obj [ "op" .= str "App" + , "fn" .= fdoc + , "args" .= list argDocs + ] _ -> failure ("VM.FromCore.genInline: invalid expression:\n" ++ show expr) extractExtern :: Expr -> Maybe (TName,[(Target,String)]) @@ -559,43 +561,20 @@ genWrapExternal tname formats , "params" .= list vs , "body" .= doc ] - -- $ notImplemented $ parens (text "function" ) -- <.> tupled vs <+> block (vcat ([text "return" <+> doc <.> semi]))) -- inlined external sometimes needs wrapping in a applied function block genInlineExternal :: TName -> [(Target,String)] -> [Doc] -> Asm Doc -genInlineExternal tname formats argDocs = genExprExternal tname formats argDocs +genInlineExternal = genExprExternal -- generate external: needs to add try blocks for primitives that can throw exceptions genExprExternal :: TName -> [(Target,String)] -> [Doc] -> Asm (Doc) -genExprExternal tname formats argDocs0 - = do (doc) <- genExprExternalPrim tname formats argDocs0 - case splitFunType (typeOf tname) of - Nothing -> return (doc) - Just (pars,eff,res) - -> let (ls,tl) = extractOrderedEffect eff - in case filter (\l -> labelName l == nameTpPartial) ls of - [] -> return (doc) - _ -> -- has an exception type, wrap it in a try handler - let try = parens $ - parens (text "function()") -- <+> block (vcat ( - -- [text "try" <+> block (vcat ([text "return" <+> doc <.> semi])) - -- ,text "catch(_err){ return $std_core._throw_exception(_err); }"] - -- ))) - <.> text "()" - in return $ notImplemented (try) +genExprExternal = genExprExternalPrim + -- special case: .cctx-hole-create genExprExternalPrim :: TName -> [(Target,String)] -> [Doc] -> Asm (Doc) genExprExternalPrim tname formats [] | getName tname == nameCCtxHoleCreate - = return (text "undefined") - -{- --- special case: cfield-set (field is implemented as {value:, field:}) -genExprExternalPrim tname formats [accDoc,resDoc] | getName tname == nameCFieldSet - = return ([], tupled [accDoc <.> text ".value[" <.> accDoc <.> text ".field] =" <+> resDoc, text "$std_core_types._Unit_"]) --} - --- normal external + = return $ notImplemented $ text $ show $ getName tname genExprExternalPrim tname formats argDocs0 = let name = getName tname format = getFormat tname formats @@ -827,8 +806,8 @@ ppLit :: Lit -> Doc ppLit lit = case lit of LitInt i -> obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= pretty i ] - LitChar c -> notImplemented $ text ("0x" ++ showHex 4 (fromEnum c)) - LitFloat d -> notImplemented $ text (showsPrec 20 d "") + LitChar c -> obj [ "op" .= str "Literal", "type" .= tpe "String", "value" .= dquotes (escape c)] + LitFloat d -> obj [ "op" .= str "Literal", "type" .= tpe "Double", "value" .= text (showsPrec 20 d "") ] LitString s -> obj [ "op" .= str "Literal", "type" .= tpe "String", "value" .= dquotes (hcat (map escape s)) ] where escape c From 9a50d3d066d201683d2b9f48231bf48308db7855 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 8 Mar 2024 12:00:31 +0100 Subject: [PATCH 17/48] VM backend: refactor: Remove some dead code --- src/Backend/VM/FromCore.hs | 83 ++------------------------------------ 1 file changed, 4 insertions(+), 79 deletions(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index d092ac7b2..569260cbd 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -202,9 +202,6 @@ getConTag modName coninfo repr in ppName (if (qualifier name == modName) then unqualify name else name) _ -> int (conTag repr) -openConTag name - = name - --------------------------------------------------------------------------------- -- Statements --------------------------------------------------------------------------------- @@ -345,15 +342,6 @@ genMatch scrutinees branches , "default" .= obj ["op" .= str "AlternativeFail"] ] - ifNull :: Doc -> ConditionDoc - ifNull scrutinee thn = let tmp = var (str "tmp") (tpe "Int") in - obj [ "op" .= str "Primitive" - , "name" .= str "ptr_eq" - , "args" .= list [scrutinee, var (text "-1") (tpe "Ptr")] - , "returns" .= list [tmp] - , "rest" .= ifEqInt tmp (text "1") thn - ] - ifCon :: Doc -> Doc -> Doc -> [Doc] -> ConditionDoc ifCon scrutinee tpt t fields thn = debugWrap ("ifCon@" ++ asString scrutinee ++ ": " ++ asString tpt ++ "." ++ asString t ++ "(" ++ asString (tupled fields) ++ ")") $ obj [ "op" .= str "Match" @@ -504,14 +492,6 @@ genPure expr ] _ -> failure ("JavaScript.FromCore.genPure: invalid expression:\n" ++ show expr) -isPat :: Bool -> Pattern -> Bool -isPat b q - = case q of - PatWild -> False - PatLit _ -> False - PatVar _ q' -> isPat b q' - PatCon {} -> getName (patConName q) == if b then nameTrue else nameFalse - -- | Generates an effect-free javasript expression -- NOTE: Throws an error if expression is not guaranteed to be effectfree genInline :: Expr -> Asm Doc @@ -532,7 +512,7 @@ genInline expr -> case args of [Lit (LitInt i)] | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT, nameInt64,nameIntPtrT] && isSmallInt i -> return (pretty i) - _ -> genInlineExternal tname formats argDocs + _ -> genExprExternal tname formats argDocs Nothing -> case (f,args) of ((Var tname _),[Lit (LitInt i)]) | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT,nameInt64,nameIntPtrT] && isSmallInt i @@ -562,20 +542,11 @@ genWrapExternal tname formats , "body" .= doc ] --- inlined external sometimes needs wrapping in a applied function block -genInlineExternal :: TName -> [(Target,String)] -> [Doc] -> Asm Doc -genInlineExternal = genExprExternal - --- generate external: needs to add try blocks for primitives that can throw exceptions -genExprExternal :: TName -> [(Target,String)] -> [Doc] -> Asm (Doc) -genExprExternal = genExprExternalPrim - - -- special case: .cctx-hole-create -genExprExternalPrim :: TName -> [(Target,String)] -> [Doc] -> Asm (Doc) -genExprExternalPrim tname formats [] | getName tname == nameCCtxHoleCreate +genExprExternal :: TName -> [(Target,String)] -> [Doc] -> Asm (Doc) +genExprExternal tname formats [] | getName tname == nameCCtxHoleCreate = return $ notImplemented $ text $ show $ getName tname -genExprExternalPrim tname formats argDocs0 +genExprExternal tname formats argDocs0 = let name = getName tname format = getFormat tname formats in return $ (case (tnameType tname) of @@ -619,12 +590,6 @@ genVarNames :: Int -> Asm [Doc] genVarNames i = do ns <- newVarNames i return $ map ppName ns --- | Generate a name with its type in comments -genCommentTName :: TName -> Asm Doc -genCommentTName (TName n t) - = do env <- getPrettyEnv - return $ ppName n -- <+> comment (Pretty.ppType env t ) - trimOptionalArgs args = reverse (dropWhile isOptionalNone (reverse args)) where @@ -651,14 +616,6 @@ extractExternal expr Nothing -> failure ("backend does not support external in " ++ show tn ++ show fs) Just s -> s -isFunExpr :: Expr -> Bool -isFunExpr expr - = case expr of - TypeApp e _ -> isFunExpr e - TypeLam _ e -> isFunExpr e - Lam args eff body -> True - _ -> False - isInlineableExpr :: Expr -> Bool isInlineableExpr expr = case expr of @@ -688,29 +645,6 @@ isPureExpr expr Lam _ _ _ -> True _ -> False - -isTailCalling :: Expr -> Name -> Bool -isTailCalling expr n - = case expr of - TypeApp expr _ -> expr `isTailCalling` n -- trivial - TypeLam _ expr -> expr `isTailCalling` n -- trivial - Lam _ _ _ -> False -- lambda body is a new context, can't tailcall - Var _ _ -> False -- a variable is not a call - Con _ _ -> False -- a constructor is not a call - Lit _ -> False -- a literal is not a call - App (Var tn info) args | getName tn == n -- direct application can be a tail call - -> infoArity info == length args - App (TypeApp (Var tn info) _) args | getName tn == n -- tailcalled function might be polymorphic and is applied to types before - -> infoArity info == length args - App (Var tn _) [e] | getName tn == nameReturn -- a return statement is transparent in terms of tail calling - -> e `isTailCalling` n - App _ _ -> False -- other applications don't apply - Let _ e -> e `isTailCalling` n -- tail calls can only happen in the actual body - Case _ bs -> any f1 bs -- match statement get analyzed in depth - where - f1 (Branch _ gs) = any f2 gs -- does any of the guards tailcall? - f2 (Guard _ e) = e `isTailCalling` n -- does the guarded expression tailcall? - --------------------------------------------------------------------------------- -- The assembly monad --------------------------------------------------------------------------------- @@ -752,15 +686,6 @@ instance HasUnique Asm where updateUnique f = Asm (\env st -> (uniq st, st{ uniq = f (uniq st)})) -updateSt f - = Asm (\env st -> (st,f st)) - -getSt - = updateSt id - -setSt st - = updateSt (const st) - getEnv = Asm (\env st -> (env, st)) From c88330ec6fae27ace8d74a8796e8fb77903bba12 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 8 Mar 2024 12:29:50 +0100 Subject: [PATCH 18/48] VM: Fix wrapping of partially-applied externals --- src/Backend/VM/FromCore.hs | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index 569260cbd..e1caf321f 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -534,13 +534,16 @@ extractExtern expr -- not fully applied external gets wrapped in a function genWrapExternal :: TName -> [(Target,String)] -> Asm Doc genWrapExternal tname formats - = do let n = snd (getTypeArities (typeOf tname)) - vs <- genVarNames n - doc <- genExprExternal tname formats vs - return $ obj [ "op" .= str "Abs" - , "params" .= list vs - , "body" .= doc - ] + = case (splitFunScheme (typeOf tname)) of + Just (_,_,pars,_,_) -> do + let ts = map snd pars + vs <- genVarNames ts + doc <- genExprExternal tname formats vs + return $ obj [ "op" .= str "Abs" + , "params" .= list vs + , "body" .= doc + ] + Nothing -> return $ notImplemented $ text "Non-function external" -- special case: .cctx-hole-create genExprExternal :: TName -> [(Target,String)] -> [Doc] -> Asm (Doc) @@ -561,10 +564,6 @@ getFormat tname formats ("undefined external: " ++ (show tname)) Just s -> s -genDefName :: TName -> Asm Doc -genDefName tname - = return (ppName (unqualify (getName tname))) - genTName :: TName -> Asm Doc genTName tname = do env <- getEnv @@ -586,9 +585,10 @@ genVarName s = do n <- newVarName s return $ ppName n -- | Generates `i` fresh variables and delivers them as `Doc` right away -genVarNames :: Int -> Asm [Doc] -genVarNames i = do ns <- newVarNames i - return $ map ppName ns +genVarNames :: [Type] -> Asm [Doc] +genVarNames ts = do ns <- newVarNames (length ts) + let tns = zipWith TName ns ts + mapM genTName tns trimOptionalArgs args = reverse (dropWhile isOptionalNone (reverse args)) From 2e99fe33efaeaed6c8a98c5ae40fd7bda3e5191a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 8 Mar 2024 15:12:11 +0100 Subject: [PATCH 19/48] VM: Fix some name generation issues --- src/Backend/VM/FromCore.hs | 45 ++++++++++++++++++-------------------- 1 file changed, 21 insertions(+), 24 deletions(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index e1caf321f..d1805737c 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -67,7 +67,7 @@ genModule buildType mbMain imports core (mainEntry) = case mbMain of Nothing -> appPrim "is a library" [] (tpe "Unit") Just (name,isAsync) - -> app (var (str $ show name) (tFn "Effectful" [] (tpe "Unit"))) [] + -> app (var (ppName name) (tFn "Effectful" [] (tpe "Unit"))) [] return $ obj [ "metadata" .= @@ -131,7 +131,7 @@ genGroup topLevel group genDef :: Bool -> Def -> Asm Doc genDef topLevel (Def name tp expr vis sort inl rng comm) - = do let n = var (str $ show name) (transformType tp) + = do let n = var (ppName name) (transformType tp) v <- genExpr expr return $ def n v @@ -154,7 +154,7 @@ genTypeDef (Data info isExtend) = do modName <- getModule let (dataRepr, conReprs) = getDataRepr info mapM ( \(c,repr) -> - do let args = map (\(n,t) -> var (ppName n) (transformType t)) (conInfoParams c) + do args <- mapM (\(n,t) -> genTName $ TName n t) (conInfoParams c) let name = str $ show (conInfoName c) let tp = transformType $ conInfoType c penv <- getPrettyEnv @@ -192,9 +192,10 @@ genTypeDef (Data info isExtend) getConTypeTag info = getReturn $ conInfoType info where - getReturn (TFun _ _ r) = str $ show $ r + getReturn (TFun _ _ r) = str $ show r getReturn (TForall _ _ t) = getReturn t - getReturn t = error $ "Constructor does not have a function type: " ++ show t + getReturn (TApp t _) = getReturn t + getReturn t = str $ show t getConTag modName coninfo repr = case repr of ConOpen{} -> -- ppLit (LitString (show (openConTag (conInfoName coninfo)))) @@ -220,7 +221,7 @@ genExprStat expr then do d <- genInline e return ([], d) else do (sd,vn) <- genVarBinding e - vd <- asVar vn + vd <- genTName vn return (sd, vd) ) exprs doc <- genMatch scrutinees branches @@ -277,7 +278,7 @@ genMatch scrutinees branches let se = withNameSubstitutions substs gs <- mapM (se . genGuard) guards - return (conditions, debugWrap ("genBranch: " ++ show substs) $ vcat gs) + return (conditions, debugWrap ("genBranch: " ++ show substs) $ vcat gs) -- FIXME genGuard :: Guard -> Asm Doc genGuard (Guard t expr) @@ -413,7 +414,7 @@ genExpr expr Let groups body -> do decls1 <- genGroups False groups (doc) <- genExpr body - return $ obj [ "op" .= str "Let" + return $ obj [ "op" .= str "LetRec" , "definitions" .= list decls1 , "body".= doc ] @@ -457,7 +458,7 @@ genVarBinding expr _ -> do name <- newVarName "x" let tp = typeOf expr val <- genExprStat expr - let defs = [def (var (str $ show name) (transformType tp)) val] + let defs = [def (var (ppName name) (transformType tp)) val] return ( defs, TName name (typeOf expr) ) --------------------------------------------------------------------------------- @@ -472,7 +473,7 @@ genPure expr Var name (InfoExternal formats) -> genWrapExternal name formats -- unapplied inlined external: wrap as function Var name info - -> asVar name -- genTName name + -> genTName name Con name repr | getName name == nameUnit -> return $ obj [ "op" .= str "Literal", "type" .= transformType (tnameType name) ] Con name repr | getName name == nameTrue @@ -480,13 +481,14 @@ genPure expr Con name repr | getName name == nameFalse -> return $ obj [ "op" .= str "Literal", "value" .= text "0", "type" .= transformType (tnameType name) ] Con name repr - -> asVar name + -> genTName name Lit l -> return $ ppLit l Lam params eff body - -> do args <- mapM asVar params + -> do args <- mapM genTName params bodyDoc <- genExprStat body - return $ obj [ "op" .= str "Abs" + return $ debugWrap "genPure: pure lambda in core code" + $ obj [ "op" .= str "Abs" , "params" .= list args , "body" .= bodyDoc ] @@ -539,7 +541,8 @@ genWrapExternal tname formats let ts = map snd pars vs <- genVarNames ts doc <- genExprExternal tname formats vs - return $ obj [ "op" .= str "Abs" + return $ debugWrap "genWrapExternal" + $ obj [ "op" .= str "Abs" , "params" .= list vs , "body" .= doc ] @@ -576,9 +579,9 @@ genName name tpe = if (isQualified name) then do modname <- getModule if (qualifier name == modname) - then return (ppName (unqualify name)) + then return $ var (ppName (unqualify name)) (transformType tpe) else return $ obj [ "op" .= str "Qualified", "lib" .= libName (nameModule name), "name" .= (ppName name), "type" .= transformType tpe ] - else return (ppName name) + else return $ var (ppName name) (transformType tpe) genVarName :: String -> Asm Doc genVarName s = do n <- newVarName s @@ -764,12 +767,11 @@ minSmallInt = -maxSmallInt ppName :: Name -> Doc ppName name = quoted $ if isQualified name - then ppModName (qualifier name) <.> dot <.> encode False (unqualify name) + then ppModName (qualifier name) <.> text "/" <.> encode False (unqualify name) else encode False name ppModName :: Name -> Doc -ppModName name - = text "$" <.> encode True (name) +ppModName name = encode True (name) encode :: Bool -> Name -> Doc encode isModule name @@ -828,11 +830,6 @@ notImplemented doc = appPrim ("Not implemented: " ++ show (asString doc)) [] (tp var :: Doc -> Doc -> Doc var x t = obj [ "op" .= str "Var", "id" .= x, "type" .= t ] -asVar :: TName -> Asm Doc -asVar n = do env <- getEnv - case lookup n (substEnv env) of - Nothing -> return $ var (str $ show $ getName n) (transformType $ tnameType n) - Just s -> return s ---- Types tFn :: String -> [Doc] -> Doc -> Doc From a199739416a1fa77aa6be7e9850eccc38efb9642 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 8 Mar 2024 15:15:51 +0100 Subject: [PATCH 20/48] VM: Generate full names also for local variables --- src/Backend/VM/FromCore.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index d1805737c..70aa5bb76 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -579,7 +579,7 @@ genName name tpe = if (isQualified name) then do modname <- getModule if (qualifier name == modname) - then return $ var (ppName (unqualify name)) (transformType tpe) + then return $ var (ppName name) (transformType tpe) else return $ obj [ "op" .= str "Qualified", "lib" .= libName (nameModule name), "name" .= (ppName name), "type" .= transformType tpe ] else return $ var (ppName name) (transformType tpe) From 3a03ae2b6b2fa54f10395e05d77efe7597ca63fe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Tue, 19 Mar 2024 12:10:01 +0100 Subject: [PATCH 21/48] Add "VM" to core pretty printer and parser --- src/Core/Parse.hs | 3 +++ src/Core/Pretty.hs | 1 + 2 files changed, 4 insertions(+) diff --git a/src/Core/Parse.hs b/src/Core/Parse.hs index 073ea2cc2..0b48881da 100644 --- a/src/Core/Parse.hs +++ b/src/Core/Parse.hs @@ -363,6 +363,9 @@ externalTarget <|> do specialId "js" return (JS JsDefault) + <|> + do specialId "vm" + return VM <|> return Default diff --git a/src/Core/Pretty.hs b/src/Core/Pretty.hs index 55f26cec3..67b3f0100 100644 --- a/src/Core/Pretty.hs +++ b/src/Core/Pretty.hs @@ -200,6 +200,7 @@ ppTarget env target CS -> text "cs " C _ -> text "c " JS _ -> text "js " + VM -> text "vm " -- _ -> keyword env (show target) <.> space From 8953320288925b0a87ede18684c3a6432d1f0bc4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Tue, 19 Mar 2024 12:10:45 +0100 Subject: [PATCH 22/48] VM: Fix generated names and types --- src/Backend/VM/FromCore.hs | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index 70aa5bb76..ff573de33 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -98,7 +98,7 @@ genLoadLibs imports = return $ map genLoadLib imports -- Translate types --------------------------------------------------------------------------------- transformType :: Type -> Doc -transformType (TVar _) = tpe "Ptr" -- erased +transformType (TVar _) = tpe "Top" -- erased transformType (TForall _ _ t) = transformType t -- TODO do we need to thunk transformType (TFun ps e t) = obj [ "op" .= str "Function" , "params" .= list [ transformType pt | (_,pt) <- ps] @@ -132,8 +132,9 @@ genGroup topLevel group genDef :: Bool -> Def -> Asm Doc genDef topLevel (Def name tp expr vis sort inl rng comm) = do let n = var (ppName name) (transformType tp) + let e = ppName name v <- genExpr expr - return $ def n v + return $ edef n v [e] --------------------------------------------------------------------------------- -- Generate value constructors for each defined type @@ -155,7 +156,7 @@ genTypeDef (Data info isExtend) let (dataRepr, conReprs) = getDataRepr info mapM ( \(c,repr) -> do args <- mapM (\(n,t) -> genTName $ TName n t) (conInfoParams c) - let name = str $ show (conInfoName c) + let name = ppName (conInfoName c) let tp = transformType $ conInfoType c penv <- getPrettyEnv let singletonValue val = def (var name (transformType (conInfoType c))) val @@ -190,12 +191,11 @@ genTypeDef (Data info isExtend) ] ]) -getConTypeTag info = getReturn $ conInfoType info - where - getReturn (TFun _ _ r) = str $ show r - getReturn (TForall _ _ t) = getReturn t - getReturn (TApp t _) = getReturn t - getReturn t = str $ show t +getConTypeTag info = str $ show $ getReturn $ conInfoType info +getReturn (TFun _ _ r) = r +getReturn (TForall _ _ t) = getReturn t +getReturn (TApp t _) = getReturn t +getReturn t = t getConTag modName coninfo repr = case repr of ConOpen{} -> -- ppLit (LitString (show (openConTag (conInfoName coninfo)))) @@ -555,9 +555,8 @@ genExprExternal tname formats [] | getName tname == nameCCtxHoleCreate genExprExternal tname formats argDocs0 = let name = getName tname format = getFormat tname formats - in return $ (case (tnameType tname) of - TFun _ _ t -> appPrim format argDocs0 (transformType t) - _ -> notImplemented $ text "Primitive non-function") + t = getReturn (tnameType tname) + in return $ appPrim format argDocs0 (transformType t) getFormat :: TName -> [(Target,String)] -> String getFormat tname formats @@ -580,7 +579,7 @@ genName name tpe then do modname <- getModule if (qualifier name == modname) then return $ var (ppName name) (transformType tpe) - else return $ obj [ "op" .= str "Qualified", "lib" .= libName (nameModule name), "name" .= (ppName name), "type" .= transformType tpe ] + else return $ obj [ "op" .= str "Qualified", "lib" .= libName (nameModule name), "name" .= ppName name, "type" .= transformType tpe ] else return $ var (ppName name) (transformType tpe) genVarName :: String -> Asm Doc @@ -824,7 +823,7 @@ appPrim name args tp = primitive [var (str "primitive_result") tp] name args (va -- | Pseudo-instruction for not-yet supported parts notImplemented :: Doc -> Doc -notImplemented doc = appPrim ("Not implemented: " ++ show (asString doc)) [] (tpe "Unit") +notImplemented doc = appPrim ("Not implemented: " ++ show (asString doc)) [] (tpe "Bottom") -- TODO other instructions @@ -847,4 +846,6 @@ tpe name = obj [ "op" .= text (show name) ] -- | Definitions def :: Doc -> Doc -> Doc -def n v = obj [ "name" .= n, "value" .= v ] \ No newline at end of file +def n v = obj [ "name" .= n, "value" .= v ] +edef :: Doc -> Doc -> [Doc] -> Doc +edef n v es = obj [ "name" .= n, "value" .= v, "export_as" .= list es ] \ No newline at end of file From 15fb4f357c753739ebd43e25c6281bf480fbad07 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Wed, 20 Mar 2024 10:44:39 +0100 Subject: [PATCH 23/48] Add first functions in stdlib --- lib/std/core/console.kk | 1 + lib/std/core/types.kk | 3 +++ 2 files changed, 4 insertions(+) diff --git a/lib/std/core/console.kk b/lib/std/core/console.kk index 34b8afe54..d2ead518c 100644 --- a/lib/std/core/console.kk +++ b/lib/std/core/console.kk @@ -39,6 +39,7 @@ extern xprintsln(s : string) : console () c "kk_println" cs "Console.WriteLine" js "_println" + vm "println(String): Unit" // Print a string to the console extern xprints( s : string) : console () diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index 079fc4e17..eee31ce08 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -337,18 +337,21 @@ pub inline extern ref( value : a) : alloc ref c "kk_ref_alloc" cs inline "new Ref<##1,##2>(#1)" js inline "{ value: #1 }" + vm "mkRef(Ptr): Ref[Ptr]" // Assign a new value to a reference. pub inline extern set( ^ref : ref, assigned : a) : > () c "kk_ref_set_borrow" cs inline "#1.Set(#2)" js inline "((#1).value = #2)" + vm "setRef(Ref[Ptr], Ptr): Unit" // Read the value of a reference. pub inline extern ref/(!) : forall ( ref : ref) -> |e> a with(hdiv) c "kk_ref_get" cs inline "#1.Value" js inline "#1.value" + vm "getRef(Ref[Ptr]): Ptr" // Modify the value of a reference. // This is especially useful when the reference contains a vector, because From 23dbddb964455381048447b123a5fda9d2485115 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Mon, 25 Mar 2024 15:59:35 +0100 Subject: [PATCH 24/48] Some minor fixes --- src/Backend/VM/FromCore.hs | 45 +++++++++++++++++++------------------- src/Compile/Options.hs | 2 +- 2 files changed, 24 insertions(+), 23 deletions(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index ff573de33..d7f817d5c 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -161,13 +161,13 @@ genTypeDef (Data info isExtend) penv <- getPrettyEnv let singletonValue val = def (var name (transformType (conInfoType c))) val if (conInfoName c == nameTrue) - then return $ obj [ "op" .= str "Literal", "type" .= str "Int", "value" .= text "1" ] + then return $ def (var name (tpe "Int")) $ obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= text "1" ] else if (conInfoName c == nameFalse) - then return $ obj [ "op" .= str "Literal", "type" .= str "Int", "value" .= text "0" ] + then return $ def (var name (tpe "Int")) $ obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= text "0" ] else return $ case repr of -- special ConEnum{} - -> debugWrap ("enum ") $ obj ["op" .= str "Literal", "type" .= str "Int", "value" .= int (conTag repr)] + -> def (var name (tpe "Int")) $ debugWrap ("enum ") $ obj ["op" .= str "Literal", "type" .= tpe "Int", "value" .= int (conTag repr)] -- ConSingleton{} | conInfoName c == nameOptionalNone -- -> null -- ConSingleton _ DataStructAsMaybe _ _ @@ -181,27 +181,32 @@ genTypeDef (Data info isExtend) ) $ zip (dataInfoConstrs $ info) conReprs where null = var (text "-1") (tpe "Ptr") + genConstr penv c repr name tp [] + = edef (var name tp) (debugWrap "genConstr" $ + obj [ "op" .= str "Construct" + , "type_tag" .= (getConTypeTag c) + , "tag" .= name + , "args" .= list [] + ]) + [name] genConstr penv c repr name tp args - = def (var name tp) (debugWrap "genConstr" $ + = edef (var name tp) (debugWrap "genConstr" $ obj [ "op" .= str "Abs", "params" .= list args , "body" .= obj [ "op" .= str "Construct" , "type_tag" .= (getConTypeTag c) , "tag" .= name , "args" .= list args ] - ]) + ]) + [name] -getConTypeTag info = str $ show $ getReturn $ conInfoType info -getReturn (TFun _ _ r) = r +getConTypeTag info = str $ show $ getTConName $ getReturn $ conInfoType info + where + getTConName (TCon c) = typeconName c +getReturn (TFun _ _ r) = getReturn r getReturn (TForall _ _ t) = getReturn t getReturn (TApp t _) = getReturn t -getReturn t = t -getConTag modName coninfo repr - = case repr of - ConOpen{} -> -- ppLit (LitString (show (openConTag (conInfoName coninfo)))) - let name = toOpenTagName (conInfoName coninfo) - in ppName (if (qualifier name == modName) then unqualify name else name) - _ -> int (conTag repr) +getReturn r = r --------------------------------------------------------------------------------- -- Statements @@ -378,7 +383,7 @@ genExpr expr App (Con _ repr) [arg] | isConIso repr -> genExpr arg App (Var tname _) [Lit (LitInt i)] - -> return $ obj [ "op" .= str "Literal", "type" .= str "Int", "value" .= pretty i ] + -> return $ obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= pretty i ] -- special: .cctx-field-addr-of: create a tuple with the object and the field name as a string App (TypeApp (Var cfieldOf _) [_]) [Var con _, Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameFieldAddrOf @@ -419,12 +424,8 @@ genExpr expr , "body".= doc ] - Case _ _ - -> -- trace "Case" $ - do (doc, tname) <- genVarBinding expr - nameDoc <- genTName tname - return $ notImplemented $ text "Case" -- (doc, nameDoc) - + c@(Case _ _) + -> genExprStat c _ -> failure ("JavaScript.FromCore.genExpr: invalid expression:\n" ++ show expr) extractList :: Expr -> Maybe ([Expr],Expr) @@ -774,7 +775,7 @@ ppModName name = encode True (name) encode :: Bool -> Name -> Doc encode isModule name - = text $ asciiEncode isModule $ show name + = text $ show name debugWrap :: String -> Doc -> Doc debugWrap s d diff --git a/src/Compile/Options.hs b/src/Compile/Options.hs index 49678ba19..9d860bf80 100644 --- a/src/Compile/Options.hs +++ b/src/Compile/Options.hs @@ -690,7 +690,7 @@ targets = ("wasmjs", \f -> f{ target=C WasmJs, platform=platform32 }), ("wasmweb",\f -> f{ target=C WasmWeb, platform=platform32 }), ("cs", \f -> f{ target=CS, platform=platformCS }), - ("vm", \f -> f{ target=VM, platform=platform64 }) + ("vm", \f -> f{ target=VM, platform=platform64, enableMon = False }) ] -- | Environment table From 1434e5f6055e5cec9c7f6ef066a6456907634ad5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Mon, 25 Mar 2024 16:00:01 +0100 Subject: [PATCH 25/48] Add some primitives --- lib/std/core/console.kk | 1 + lib/std/core/int.kk | 17 +++++++++++++++++ src/Backend/VM/FromCore.hs | 6 +++--- 3 files changed, 21 insertions(+), 3 deletions(-) diff --git a/lib/std/core/console.kk b/lib/std/core/console.kk index d2ead518c..3adfb2ed7 100644 --- a/lib/std/core/console.kk +++ b/lib/std/core/console.kk @@ -46,6 +46,7 @@ extern xprints( s : string) : console () c "kk_print" cs "Console.Write" js "_print" + vm "!sexp:(\"write(OutStream, String): Unit\" (\"getStdout(): OutStream\") $arg0:str)" // _Unsafe_. This function removes the state effect from the effect of an action inline extern unsafe-nostate( action : () -> ,console> a ) : (() -> console a) diff --git a/lib/std/core/int.kk b/lib/std/core/int.kk index f47a849f9..cebadec9d 100644 --- a/lib/std/core/int.kk +++ b/lib/std/core/int.kk @@ -45,41 +45,48 @@ pub inline fip extern (==)(^x : int, ^y : int) : bool c "kk_integer_eq_borrow" cs inline "(#1 == #2)" js "$std_core_types._int_eq" + vm "infixEq(Int, Int): Boolean" // Are two integers not equal? pub inline fip extern (!=)(^x : int, ^y : int) : bool c "kk_integer_neq_borrow" cs inline "(#1 != #2)" js "$std_core_types._int_ne" + vm "infixNeq(Int, Int): Boolean" // Is the first integer smaller or equal to the second? pub inline fip extern (<=)(^x : int, ^y : int) : bool c "kk_integer_lte_borrow" cs inline "(#1 <= #2)" js "$std_core_types._int_le" + vm "infixLte(Int, Int): Boolean" // Is the first integer greater or equal to the second? pub inline fip extern (>=)(^x : int, ^y : int) : bool c "kk_integer_gte_borrow" cs inline "(#1 >= #2)" js "$std_core_types._int_ge" + vm "infixGte(Int, Int): Boolean" // Is the first integer smaller than the second? pub inline fip extern (<)(^x : int, ^y : int) : bool c "kk_integer_lt_borrow" cs inline "(#1 < #2)" js "$std_core_types._int_lt" + vm "infixLt(Int, Int): Boolean" // Is the first integer greater than the second? pub inline fip extern (>)(^x : int, ^y : int) : bool c "kk_integer_gt_borrow" cs inline "(#1 > #2)" js "$std_core_types._int_gt" + vm "infixGt(Int, Int): Boolean" inline fip extern int-add : (int,int) -> int c "kk_integer_add" cs inline "(#1 + #2)" js "$std_core_types._int_add" + vm "infixAdd(Int, Int): Int" // Add two integers. pub fip fun (+)(x : int, y : int ) : int @@ -89,6 +96,7 @@ inline fip extern int-sub : (int,int) -> int c "kk_integer_sub" cs inline "(#1 - #2)" js "$std_core_types._int_sub" + vm "infixSub(Int, Int): Int" // Substract two integers. pub fip fun (-)(x : int, y : int ) : int @@ -99,18 +107,21 @@ pub inline fip extern (*) : (int,int) -> int c "kk_integer_mul" cs inline "(#1 * #2)" js "$std_core_types._int_mul" + vm "infixMul(Int, Int): Int" // Euclidean-0 division of two integers. See also `divmod:(x : int, y : int) -> (int,int)`. pub inline fip extern (/)(x:int,y:int) : int c "kk_integer_div" cs "Primitive.IntDiv" js "$std_core_types._int_div" + vm "infixDiv(Int, Int): Int" // Euclidean modulus of two integers; always a non-negative number. See also `divmod:(x : int, y : int) -> (int,int)`. pub inline fip extern (%) : (int,int) -> int c "kk_integer_mod" cs "Primitive.IntMod" js "$std_core_types._int_mod" + vm "mod(Int, Int): Int" /* Euclidean-0 division & modulus. Euclidean division is defined as: For any `D` and `d` where ``d!=0`` , we have: @@ -135,6 +146,7 @@ pub fip extern divmod(x:int,y:int) : (int,int) c "kk_integer_div_mod_tuple" cs "Primitive.IntDivMod" js "$std_core_types._int_divmod" + vm "!sexp:(prim ($d:int $m:int) (\"divmod(Int, Int): Int, Int\" $arg0:int $arg1:int) (make $divmodPair $divmodPair ($d:int $m:int)))" pub fip fun negate(i : int) : int ~i @@ -144,24 +156,28 @@ pub inline fip extern (~)(i:int) : int c "kk_integer_neg" cs inline "(-#1)" js "$std_core_types._int_negate" + vm "neg(Int): Int" // Is this an odd integer? pub inline fip extern is-odd( i : int ) : bool c "kk_integer_is_odd" cs inline "!(#1.IsEven)" js "$std_core_types._int_isodd" + vm "!sexp:(\"infixEq(Int, Int): Boolean\" (\"mod(Int, Int): Int\" $arg0:int 2) 1)" // Is this equal to zero? pub inline fip extern is-zero( ^x : int) : bool c inline "kk_integer_is_zero_borrow(#1)" cs inline "(#1.IsZero)" js "$std_core_types._int_iszero" + vm "!sexp:(\"infixEq(Int, Int): Boolean\" $arg0:int 0)" // Return the absolute value of an integer. pub inline fip extern abs(i : int) : int c "kk_integer_abs" cs "BigInteger.Abs" js "$std_core_types._int_abs" + vm "abs(Int): Int" @@ -259,6 +275,7 @@ pub extern show( i : int ) : string c "kk_integer_to_string" cs inline "#1.ToString()" js inline "#1.toString()" + vm "show(Int): String" // Convert an int to a boolean, using `False` for 0 and `True` otherwise. pub fun bool( i : int ) : bool diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index d7f817d5c..247eb4e11 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -65,7 +65,7 @@ genModule buildType mbMain imports core decls1 <- genTypeDefs (coreProgTypeDefs core) let -- `imports = coreProgImports core` is not enough due to inlined definitions (mainEntry) = case mbMain of - Nothing -> appPrim "is a library" [] (tpe "Unit") + Nothing -> appPrim "!undefined:is a library" [] (tpe "Unit") Just (name,isAsync) -> app (var (ppName name) (tFn "Effectful" [] (tpe "Unit"))) [] return $ @@ -564,7 +564,7 @@ getFormat tname formats = case lookupTarget VM formats of -- TODO: pass specific target from the flags Nothing -> -- failure ("backend does not support external in " ++ show tname ++ ": " ++ show formats) trace( "warning: backend does not support external in " ++ show tname ) $ - ("undefined external: " ++ (show tname)) + ("!undefined: " ++ (show tname)) Just s -> s genTName :: TName -> Asm Doc @@ -824,7 +824,7 @@ appPrim name args tp = primitive [var (str "primitive_result") tp] name args (va -- | Pseudo-instruction for not-yet supported parts notImplemented :: Doc -> Doc -notImplemented doc = appPrim ("Not implemented: " ++ show (asString doc)) [] (tpe "Bottom") +notImplemented doc = appPrim ("!undefined: " ++ show (asString doc)) [] (tpe "Bottom") -- TODO other instructions From b60b63d06142e1b2ae248c34af7fb460eae16689 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Tue, 26 Mar 2024 10:08:57 +0100 Subject: [PATCH 26/48] Re-add accidentally removed guard --- src/Backend/VM/FromCore.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index 247eb4e11..0110db2b3 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -382,7 +382,7 @@ genExpr expr -> genExpr arg App (Con _ repr) [arg] | isConIso repr -> genExpr arg - App (Var tname _) [Lit (LitInt i)] + App (Var tname _) [Lit (LitInt i)] | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT,nameInt64,nameIntPtrT,nameByte] -> return $ obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= pretty i ] -- special: .cctx-field-addr-of: create a tuple with the object and the field name as a string From 2a60b3a4b4253beae83d15aebef988170d3c754e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Thu, 28 Mar 2024 09:33:43 +0100 Subject: [PATCH 27/48] Minor --- lib/std/core/hnd.kk | 1 + src/Backend/VM/FromCore.hs | 6 +----- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/lib/std/core/hnd.kk b/lib/std/core/hnd.kk index f2f7c3f64..50e70a39b 100644 --- a/lib/std/core/hnd.kk +++ b/lib/std/core/hnd.kk @@ -230,6 +230,7 @@ inline extern evv-set( w : evv ) : e () pub extern @evv-is-affine() : bool c inline "kk_evv_is_affine(kk_context())" js inline "$std_core_hnd._evv_is_affine_()" + vm "!sexp:0" // ----------------------------------------------------------------------------------- diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index 0110db2b3..f0bd34976 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -396,12 +396,8 @@ genExpr expr Nothing -> case extractExtern f of Just (tname,formats) -> case args of - [Lit (LitInt i)] | getName tname == nameByte && i >= 0 && i < 256 + [Lit (LitInt i)] | getName tname `elem` [nameByte, nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT, nameInt64, nameIntPtrT] -> return (pretty i) - [Lit (LitInt i)] | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT] && isSmallInt i - -> return (pretty i) - [Lit (LitInt i)] | getName tname `elem` [nameInt64,nameIntPtrT] && isSmallInt i - -> return (pretty i <.> text "n") _ -> -- genInlineExternal tname formats argDocs do (argDocs) <- genExprs args (doc) <- genExprExternal tname formats argDocs From e3d707cfe3388e87f106001031b2a4100ce60232 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 5 Apr 2024 11:28:35 +0200 Subject: [PATCH 28/48] Initial draft with working handlers --- lib/std/core/hnd.kk | 44 +++++++++++++++++++++-- lib/std/core/types.kk | 1 + src/Backend/VM/FromCore.hs | 73 +++++++++++++++++++++++++++++--------- src/Common/NamePrim.hs | 19 +++++++++- src/Compile/Options.hs | 2 +- 5 files changed, 118 insertions(+), 21 deletions(-) diff --git a/lib/std/core/hnd.kk b/lib/std/core/hnd.kk index 50e70a39b..47c491e5d 100644 --- a/lib/std/core/hnd.kk +++ b/lib/std/core/hnd.kk @@ -157,11 +157,12 @@ extern eq-marker( x : marker, y : marker ) : bool extern fresh-marker() : marker c inline "kk_marker_unique(kk_context())" js inline "$marker_unique++" + vm "!sexp:(fresh-label)" extern fresh-marker-named() : marker c inline "-kk_marker_unique(kk_context())" js inline "-($marker_unique++)" - + vm "!sexp:(fresh-label)" // ------------------------------------------- @@ -175,6 +176,7 @@ extern fresh-marker-named() : marker extern evv-insert( evv : evv, ev : ev ) : e1 evv c "kk_evv_insert" js "_evv_insert" + vm "!sexp:(make $evv $cons ($arg1:ptr $arg0:ptr))" // show evidence for debug purposes extern evv-show( evv : evv ) : string @@ -186,6 +188,7 @@ extern evv-show( evv : evv ) : string extern evv-eq(evv0 : evv, evv1 : evv ) : bool c "kk_evv_eq" js inline "(#1) === (#2)" + vm "ptr_eq" // ------------------------------------------- @@ -196,6 +199,8 @@ extern evv-eq(evv0 : evv, evv1 : evv ) : bool pub inline extern @evv-at ( i : ev-index ) : ev // pretend total; don't simplify c "kk_evv_at" js "$std_core_hnd._evv_at" + vm "!sexp:(letrec ((define $elt:top (lambda ($l:ptr $n:int) (switch $n:int (0 (project $l:ptr $evv $cons 0)) (_ ($elt:top (project $l:ptr $evv $cons 1) (\"infixSub(Int, Int): Int\" $n:int 1))))) )) ($elt:top (\"getRef(Ref[Ptr]): Ptr\" (\"getGlobal(String): Ptr\" \"current-evv\")) $arg0:int))" + // TODO move elt to extern file // (dynamically) find evidence insertion/deletion index in the evidence vector // The compiler optimizes `@evv-index` to a static index when apparent from the effect type. @@ -207,11 +212,13 @@ pub extern @evv-index( htag : htag ) : e ev-index extern evv-get() : e evv c "kk_evv_get" js "$std_core_hnd._evv_get" + vm "!sexp:(\"getRef(Ref[Ptr]): Ptr\" (\"getGlobal(String): Ptr\" \"current-evv\"))" // Set the current evidence vector. inline extern evv-set( w : evv ) : e () c "kk_evv_set" js "$std_core_hnd._evv_set" + vm "!sexp:(\"setRef(Ref[Ptr], Ptr): Unit\" (\"getGlobal(String): Ptr\" \"current-evv\") $arg0:ptr)" // Does the current evidence vector consist solely of affine handlers? // This is called in backends that do not have context paths (like javascript) @@ -276,10 +283,12 @@ extern evv-swap-create( indices : vector ) : e evv //not quite the pub inline extern yielding() : bool c "kk_yielding" js "$std_core_hnd._yielding" + vm "!sexp:0" pub inline extern yielding-non-final() : bool c "kk_yielding_non_final" js "$std_core_hnd._yielding_non_final" + vm "!sexp:0" pub noinline extern yield-extend(next : a -> e b ) : e b c "kk_yield_extend" @@ -302,11 +311,18 @@ inline extern keep-yielding-final() : e r extern yield-prompt( m: marker ) : yld c "kk_yield_prompt" js "_yield_prompt" + vm "!sexp:(reset ($arg0:ptr $ignore:ptr) $std/core/hnd/Pure:ptr (($ret:ptr) $ret:ptr))" extern yield-to-prim( m : marker, clause : (resume-result -> e1 r) -> e1 r ) : e (() -> b) c "kk_yield_to" js "$std_core_hnd._yield_to" +extern @yield-to-prim-vm( m : marker, clause : (b -> e1 r) -> e1 r ) : e b + vm "!sexp:(debugWrap \"yield-to-prim\" (shift:top ($arg0:ptr 0) ($resume:ptr) ($arg1:ptr (lambda ($val:ptr) (debugWrap \"Resuming\" (resume $resume:ptr $val:ptr) ) )))) )" + +extern @not_implemented() : a + vm "!undefined:Not implemented." + extern yield-to-final( m : marker, clause : (resume-result -> e1 r) -> e1 r ) : e b c "kk_yield_final" js "$std_core_hnd._yield_final" @@ -318,6 +334,10 @@ noinline fun yield-to( m : marker, clause : (resume-result -> e1 r) - // val keep1 = guard(w0) // check the evidence is correctly restored f() +noinline fun @yield-to-vm( m : marker, clause : (b -> e1 r) -> e1 r ) : e1 b + //val w0 = evv-get() + @yield-to-prim-vm(m, clause) + pub type yield-info extern yield-capture() : e yield-info @@ -416,6 +436,20 @@ pub noinline fun @hhandle( tag:htag, h : h, ret: a -> e r, action : () - // call action first (this may be yielding), then check the result prompt(w0,w1,ev,m,ret,cast-ev0(action)()) +extern @reset-vm( m : marker, ret : a -> e0 r, action : () -> e0 a) : e0 r + vm "!sexp:(debugWrap \"reset\" (reset ($arg0:ptr $ignore:ptr) ($arg2:ptr) (($res:top) ($arg1:ptr $res:top)) ) )" + +pub noinline fun @hhandle-vm( tag:htag, h : h, ret: a -> e r, action : () -> e1 a ) : e r + // insert new evidence for our handler + val w0 = evv-get() + val m = fresh-marker() + val ev = Ev(tag,m,h,w0) + val w1 = evv-insert(w0,ev) + evv-set(w1) + val res = @reset-vm(m,ret,cast-ev0(action)) + evv-set(w0) + res + // ------------------------------------------- // named handler // (which is not inserted into the evidence vector) @@ -427,6 +461,7 @@ pub noinline fun @named-handle( tag:htag, h : h, ret: a -> e r, action : val ev = Ev(tag,m,h,w0) prompt(w0,w0,ev,m,ret,cast-ev1(action)(ev)) +// TODO define @named-handle-vm to make this work // ------------------------------------------- // mask @@ -508,6 +543,7 @@ inline extern eq( ^x : int, ^y : int) : bool c "kk_integer_eq_borrow" cs inline "(#1 == #2)" js inline "(#1 == #2)" // $std_core_types._int_eq" + vm "infixEq(Int, Int): Int" pub fun initially(init : (int) -> e (), action : () -> e a ) : e a @@ -556,6 +592,7 @@ abstract value type clause1V,e::E,r::V> inline extern cast-clause0( f : (marker,ev) -> e1 b) : e ((marker,ev) -> e b) inline "#1" + vm "!sexp:(debugWrap \"cast-clause0\" $arg0:ptr)" inline extern cast-clause1( f : (marker,ev,a) -> e1 b) : e ((marker,ev,a) -> e b) inline "#1" @@ -605,7 +642,7 @@ fun protect-check( resumed : ref, k : resume-result -> e r, r then k(Finalize(res)) //finalize(k,res) else res -fun protect( x : a, clause : (x:a, k: b -> e r) -> e r, k : resume-result -> e r ) : e r +noinline fun protect( x : a, clause : (x:a, k: b -> e r) -> e r, k : resume-result -> e r ) : e r val resumed = (unsafe-st{ref(False)})() fun kprotect(ret) (unsafe-st{resumed := True})() @@ -614,6 +651,9 @@ fun protect( x : a, clause : (x:a, k: b -> e r) -> e r, k : resume-result - if yielding() return yield-extend( fn(xres) protect-check(resumed,k,xres) ) protect-check(resumed,k,res) +noinline fun @protect-vm( x : a, clause : (x:a, k: b -> e r) -> e r, k : b -> e r) : e r + clause(x, k) + /* pub fun clause-control1( clause : (x:a, k: b -> e r) -> e r ) : clause1 Clause1(fn(m,w,x){ yield-to(m, fn(k){ clause(x, fn(r){ k({r}) } ) }) }) diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index eee31ce08..b1d9fbc1d 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -305,6 +305,7 @@ pub fip extern @make-ssize_t( i : int) : ssize_t // Append two strings pub extern (++)(x : string, y : string) : string c "kk_string_cat" + vm "infixConcat(String, String): String" inline "(#1 + #2)" diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index f0bd34976..d07d87c1a 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -34,6 +34,7 @@ import Common.Syntax import Core.Core import Core.Pretty import Core.CoreVar +import Data.Tuple (swap) type ConditionDoc = Doc -> Doc -- `cd thn` gets you the doc; expects to be in an alternative-choice @@ -47,6 +48,9 @@ externalNames , (TName nameOptionalNone typeOptional, text "undefined") -- ugly but has real performance benefit ] +intTypes :: [Name] +intTypes = [nameTpSSizeT,nameInt16,nameInt64,nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT,nameIntPtrT,nameByte,nameTpEvIndex] + -------------------------------------------------------------------------- -- Generate JavaScript code from System-F core language -------------------------------------------------------------------------- @@ -60,14 +64,19 @@ vmFromCore buildType mbMain imports core genModule :: BuildType -> Maybe (Name,Bool) -> [Import] -> Core -> Asm Doc genModule buildType mbMain imports core - = do impdecls <- genLoadLibs imports + = do rememberDataInfos (coreProgTypeDefs core) + impdecls <- genLoadLibs imports decls0 <- genGroups True (coreProgDefs core) decls1 <- genTypeDefs (coreProgTypeDefs core) let -- `imports = coreProgImports core` is not enough due to inlined definitions (mainEntry) = case mbMain of Nothing -> appPrim "!undefined:is a library" [] (tpe "Unit") Just (name,isAsync) - -> app (var (ppName name) (tFn "Effectful" [] (tpe "Unit"))) [] + -> obj [ "op" .= str "Seq" + , "elems" .= list [ appPrim "!sexp:(\"setGlobal(String, Ptr): Unit\" \"current-evv\" (\"mkRef(Ptr): Ref[Ptr]\" (make $evv $nil ())))" [] (tpe "Unit") + , app (var (ppName name) (tFn "Effectful" [] (tpe "Unit"))) [] + ] + ] return $ obj [ "metadata" .= @@ -105,6 +114,7 @@ transformType (TFun ps e t) = obj [ "op" .= str "Function" , "return" .= transformType t , "purity" .= str "Effectful" -- TODO infer from e ] +transformType (TCon c) | (typeConName c) `elem` intTypes = tpe "Int" transformType (TCon c) | nameModule (typeConName c) == "std/core/types" = case (nameStem (typeConName c)) of "unit" -> tpe "Unit" "string" -> tpe "String" @@ -129,12 +139,32 @@ genGroup topLevel group DefRec defs -> mapM (genDef topLevel) defs DefNonRec def -> (:[]) <$> genDef topLevel def +switchNames :: [(Name, Name)] +switchNames = + [ (nameHandle, nameHandleVM) + -- , (nameNamedHandle, nameNamedHandleVM) + , (nameYieldTo, nameYieldToVM) + , (nameProtect, nameProtectVM) + ] + genDef :: Bool -> Def -> Asm Doc +genDef topLevel (Def name tp expr vis sort inl rng comm) | name `elem` (map fst switchNames) + = do let Just nameNew = lookup name switchNames + let n = var (ppName nameNew) (transformType tp) + let e = ppName nameNew + v <- genExpr expr + return $ edef n (debugWrap ("Def of " ++ show n) v) [e] +genDef topLevel (Def name tp expr vis sort inl rng comm) | name `elem` (map snd switchNames) + = do let Just nameNew = lookup name (map swap switchNames) + let n = var (ppName nameNew) (transformType tp) + let e = ppName nameNew + v <- genExpr expr + return $ edef n (debugWrap ("Def of " ++ show n) v) [e] genDef topLevel (Def name tp expr vis sort inl rng comm) = do let n = var (ppName name) (transformType tp) let e = ppName name v <- genExpr expr - return $ edef n v [e] + return $ edef n (debugWrap ("Def of " ++ show n) v) [e] --------------------------------------------------------------------------------- -- Generate value constructors for each defined type @@ -166,8 +196,8 @@ genTypeDef (Data info isExtend) then return $ def (var name (tpe "Int")) $ obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= text "0" ] else return $ case repr of -- special - ConEnum{} - -> def (var name (tpe "Int")) $ debugWrap ("enum ") $ obj ["op" .= str "Literal", "type" .= tpe "Int", "value" .= int (conTag repr)] +-- ConEnum{} +-- -> def (var name (tpe "Int")) $ debugWrap ("enum ") $ obj ["op" .= str "Literal", "type" .= tpe "Int", "value" .= int (conTag repr)] -- ConSingleton{} | conInfoName c == nameOptionalNone -- -> null -- ConSingleton _ DataStructAsMaybe _ _ @@ -320,8 +350,8 @@ genMatch scrutinees branches | otherwise -> case repr of -- special - ConEnum _ _ _ tag - -> return ([ifEqInt scrutinee (int tag)], []) +-- ConEnum _ _ _ tag +-- -> return ([ifEqInt scrutinee (int tag)], []) -- ConSingleton{} -- | getName tn == nameOptionalNone -- -> [ifNull scrutinee] @@ -370,6 +400,7 @@ genMatch scrutinees branches genExpr :: Expr -> Asm Doc genExpr expr = -- trace ("genExpr: " ++ show expr) $ + fmap (debugWrap ("genExpr: " ++ show expr)) $ case expr of -- check whether the expression is pure an can be inlined _ | isInlineableExpr expr -> genInline expr @@ -378,11 +409,7 @@ genExpr expr TypeLam _ e -> genExpr e -- handle not inlineable cases - App (TypeApp (Con name repr) _) [arg] | getName name == nameOptional || isConIso repr - -> genExpr arg - App (Con _ repr) [arg] | isConIso repr - -> genExpr arg - App (Var tname _) [Lit (LitInt i)] | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT,nameInt64,nameIntPtrT,nameByte] + App (Var tname _) [Lit (LitInt i)] | getName tname `elem` intTypes -> return $ obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= pretty i ] -- special: .cctx-field-addr-of: create a tuple with the object and the field name as a string @@ -672,6 +699,7 @@ runAsm initEnv (Asm asm) (doc,st) -> doc data St = St { uniq :: Int + , dataInfos :: [(Name,DataInfo)] } data Env = Env { moduleName :: Name -- | current module @@ -679,7 +707,7 @@ data Env = Env { moduleName :: Name -- | current modul , substEnv :: [(TName, Doc)] -- | substituting names } -initSt = St 0 +initSt = St 0 [] instance HasUnique Asm where updateUnique f @@ -697,6 +725,15 @@ localUnique asm setUnique u return x +findDataInfo :: Name -> Asm (Maybe DataInfo) +findDataInfo n = Asm (\env st -> ((lookup n $ dataInfos st), st)) + +rememberDataInfos :: TypeDefGroups -> Asm () +rememberDataInfos = mapM_ onGroups + where onGroups (TypeDefGroup tds) = mapM_ onTypeDef tds + onTypeDef d = remember (typeDefDataInfo d) + remember d = Asm (\env st -> ((), st{dataInfos = (dataInfoName d, d):(dataInfos st)})) + newVarName :: String -> Asm Name newVarName s = do u <- unique @@ -730,11 +767,10 @@ ppLit :: Lit -> Doc ppLit lit = case lit of LitInt i -> obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= pretty i ] - LitChar c -> obj [ "op" .= str "Literal", "type" .= tpe "String", "value" .= dquotes (escape c)] + LitChar c -> litStr [c] LitFloat d -> obj [ "op" .= str "Literal", "type" .= tpe "Double", "value" .= text (showsPrec 20 d "") ] - LitString s -> obj [ "op" .= str "Literal", "type" .= tpe "String", "value" .= dquotes (hcat (map escape s)) ] - where - escape c + LitString s -> litStr s +escape c = if (c < ' ') then (if (c=='\n') then text "\\n" else if (c == '\r') then text "\\r" @@ -818,6 +854,9 @@ appPrim :: String -- ^ name -> Doc appPrim name args tp = primitive [var (str "primitive_result") tp] name args (var (str "primitive_result") tp) +litStr :: String -> Doc +litStr s = obj [ "op" .= str "Literal", "type" .= tpe "String", "value" .= dquotes (hcat (map escape s)) ] + -- | Pseudo-instruction for not-yet supported parts notImplemented :: Doc -> Doc notImplemented doc = appPrim ("!undefined: " ++ show (asString doc)) [] (tpe "Bottom") diff --git a/src/Common/NamePrim.hs b/src/Common/NamePrim.hs index b5950799b..c1b544a02 100644 --- a/src/Common/NamePrim.hs +++ b/src/Common/NamePrim.hs @@ -49,10 +49,13 @@ module Common.NamePrim -- Effects , nameTpHTag, nameHTag - , nameTpClause, namePerform + , nameTpClause, namePerform, isNameTpClause , nameTpEvv, nameEvvAt, nameEvvIndex , nameOpenAt, nameOpen, nameOpenNone , nameTpEv, nameHandle, nameNamedHandle + , nameHandleVM, nameNamedHandleVM + , nameYieldTo, nameYieldToVM + , nameProtect, nameProtectVM , nameTpResumeContext , nameClause , nameIdentity @@ -333,6 +336,12 @@ nameEvvIsAffine = coreHndName ("@evv-is-affine") nameHandle = coreHndName "@hhandle" nameNamedHandle = coreHndName "@named-handle" +nameHandleVM = coreHndName "@hhandle-vm" +nameNamedHandleVM = coreHndName "@named-handle-vm" +nameYieldTo = coreHndName "yield-to" +nameYieldToVM = coreHndName "@yield-to-vm" +nameProtect = coreHndName "protect" +nameProtectVM = coreHndName "@protect-vm" nameYielding = coreHndName "yielding" nameYieldExtend = coreHndName "yield-extend" @@ -353,6 +362,14 @@ isClauseTailName name then Just (read (drop 11 s)) else Nothing +isNameTpClause :: Name -> Maybe Int +isNameTpClause name | nameModule name /= nameModule nameCoreHnd = Nothing +isNameTpClause name + = let s = nameLocal name + in if (s `startsWith` "clause" && all isDigit (drop 6 s)) + then Just (read (drop 6 s)) + else Nothing + {-------------------------------------------------------------------------- std/core/types --------------------------------------------------------------------------} diff --git a/src/Compile/Options.hs b/src/Compile/Options.hs index 9d860bf80..fa9ba5af3 100644 --- a/src/Compile/Options.hs +++ b/src/Compile/Options.hs @@ -690,7 +690,7 @@ targets = ("wasmjs", \f -> f{ target=C WasmJs, platform=platform32 }), ("wasmweb",\f -> f{ target=C WasmWeb, platform=platform32 }), ("cs", \f -> f{ target=CS, platform=platformCS }), - ("vm", \f -> f{ target=VM, platform=platform64, enableMon = False }) + ("vm", \f -> f{ target=VM, platform=platform64, enableMon = False, optctail = False }) ] -- | Environment table From 010da9e0fbdcf9028e04da9d2a74d11ee9b5130f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 12 Apr 2024 09:57:32 +0200 Subject: [PATCH 29/48] Use the fact that codata will be monomorphized --- lib/std/core/hnd.kk | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/std/core/hnd.kk b/lib/std/core/hnd.kk index 47c491e5d..7e353b099 100644 --- a/lib/std/core/hnd.kk +++ b/lib/std/core/hnd.kk @@ -318,7 +318,7 @@ extern yield-to-prim( m : marker, clause : (resume-result -> e1 r) -> js "$std_core_hnd._yield_to" extern @yield-to-prim-vm( m : marker, clause : (b -> e1 r) -> e1 r ) : e b - vm "!sexp:(debugWrap \"yield-to-prim\" (shift:top ($arg0:ptr 0) ($resume:ptr) ($arg1:ptr (lambda ($val:ptr) (debugWrap \"Resuming\" (resume $resume:ptr $val:ptr) ) )))) )" + vm "!sexp:(debugWrap \"yield-to-prim\" (shift:top ($arg0:ptr 0) ($resume:ptr) ($arg1:ptr (lambda ($val:top) (debugWrap \"Resuming\" (resume $resume:ptr $val:top) ) )))) )" extern @not_implemented() : a vm "!undefined:Not implemented." From 68925d8681ebc972121d812839a19e4b2531f5c7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Wed, 24 Apr 2024 10:26:46 +0200 Subject: [PATCH 30/48] Fix effects --- lib/std/core/hnd.kk | 2 +- src/Backend/VM/FromCore.hs | 5 +---- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/lib/std/core/hnd.kk b/lib/std/core/hnd.kk index 7e353b099..b6e6cead6 100644 --- a/lib/std/core/hnd.kk +++ b/lib/std/core/hnd.kk @@ -437,7 +437,7 @@ pub noinline fun @hhandle( tag:htag, h : h, ret: a -> e r, action : () - prompt(w0,w1,ev,m,ret,cast-ev0(action)()) extern @reset-vm( m : marker, ret : a -> e0 r, action : () -> e0 a) : e0 r - vm "!sexp:(debugWrap \"reset\" (reset ($arg0:ptr $ignore:ptr) ($arg2:ptr) (($res:top) ($arg1:ptr $res:top)) ) )" + vm "!sexp:(debugWrap \"reset\" (reset ($arg0:ptr $ignore:ptr) (let ((define $ret:top ($arg2:ptr))) $ret:top) (($res:top) (debugWrap \"returnClause\" ($arg1:ptr $res:top) ) ) ) )" pub noinline fun @hhandle-vm( tag:htag, h : h, ret: a -> e r, action : () -> e1 a ) : e r // insert new evidence for our handler diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index d07d87c1a..e081e42f7 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -43,10 +43,7 @@ debug = True externalNames :: [(TName, Doc)] externalNames - = [ (conName exprTrue, text "true") - , (conName exprFalse, text "false") - , (TName nameOptionalNone typeOptional, text "undefined") -- ugly but has real performance benefit - ] + = [] intTypes :: [Name] intTypes = [nameTpSSizeT,nameInt16,nameInt64,nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT,nameIntPtrT,nameByte,nameTpEvIndex] From 5fbeb63b9c4555127eae9b7b9849d5cf87e2f2ef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Wed, 24 Apr 2024 10:27:05 +0200 Subject: [PATCH 31/48] Some more primitives --- lib/std/core.kk | 4 ++-- lib/std/core/string.kk | 1 + lib/std/core/vector.kk | 2 ++ lib/std/os/env.kk | 1 + 4 files changed, 6 insertions(+), 2 deletions(-) diff --git a/lib/std/core.kk b/lib/std/core.kk index c012e7b07..3f0deb999 100644 --- a/lib/std/core.kk +++ b/lib/std/core.kk @@ -221,12 +221,12 @@ pub extern main-console : forall ( main : () -> e a ) -> e a js inline "(#1)()" -// Return the host environment: `dotnet`, `browser`, `webworker`, `node`, or `libc`. +// Return the host environment: `dotnet`, `browser`, `webworker`, `node`, or `libc`, or `vm`. pub extern host() : ndet string c "kk_get_host" cs inline "\"dotnet\"" js inline "$std_core_console._host" - + vm "!sexp:\"vm\"" // The default exception handler pub fun @default-exn(action : () -> () ) : () diff --git a/lib/std/core/string.kk b/lib/std/core/string.kk index 4f4883737..bbad95800 100644 --- a/lib/std/core/string.kk +++ b/lib/std/core/string.kk @@ -44,6 +44,7 @@ pub inline extern (==) : (string,string) -> bool c "kk_string_is_eq" cs inline "(#1 == #2)" js inline "(#1 === #2)" + vm "infixEq(String, String): Boolean" // Are two strings not equal? pub inline extern (!=) : (string,string) -> bool diff --git a/lib/std/core/vector.kk b/lib/std/core/vector.kk index a54dee712..3217f0404 100644 --- a/lib/std/core/vector.kk +++ b/lib/std/core/vector.kk @@ -28,6 +28,7 @@ inline extern unsafe-idx( ^v : vector, index : ssize_t ) : total a c "kk_vector_at_borrow" cs inline "(#1)[#2]" js inline "(#1)[#2]" + vm "unsafeIndex(Array[Ptr], Int): Ptr" inline extern unsafe-assign : forall ( v : vector, i : ssize_t, x : a ) -> total () c "kk_vector_unsafe_assign" @@ -50,6 +51,7 @@ inline extern lengthz( ^v : vector ) : ssize_t c "kk_vector_len_borrow" cs inline "((#1).Length)" js inline "((#1).length)" + vm "length(Array[Ptr]): Int" // Create a new vector of length `n` with initial elements `init`` . extern vector-alloc(n : ssize_t, init : a) : e vector diff --git a/lib/std/os/env.kk b/lib/std/os/env.kk index 9101eb29c..460d235a6 100644 --- a/lib/std/os/env.kk +++ b/lib/std/os/env.kk @@ -44,6 +44,7 @@ extern os-get-argv() : ndet vector c "kk_os_get_argv" cs "System.Environment.GetCommandLineArgs" js inline "(typeof process !== 'undefined' ? process.argv : [])" + vm "getArgs(): Array[String]" // The unprocessed command line that was used to start this program. From 9c1d5243ca8c3c7ca39a94eb3de3b491efcc73f4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Tue, 30 Apr 2024 13:00:46 +0200 Subject: [PATCH 32/48] More stdlib --- lib/std/core/hnd.kk | 12 ++++---- lib/std/core/inline/hnd.mcore.sexp | 28 +++++++++++++++++++ lib/std/core/inline/int.mcore.sexp | 17 ++++++++++++ lib/std/core/inline/vector.mcore.sexp | 11 ++++++++ lib/std/core/int.kk | 5 ++-- lib/std/core/vector.kk | 2 ++ src/Backend/VM/FromCore.hs | 40 ++++++++++++--------------- src/Compile/CodeGen.hs | 3 +- 8 files changed, 88 insertions(+), 30 deletions(-) create mode 100644 lib/std/core/inline/hnd.mcore.sexp create mode 100644 lib/std/core/inline/int.mcore.sexp create mode 100644 lib/std/core/inline/vector.mcore.sexp diff --git a/lib/std/core/hnd.kk b/lib/std/core/hnd.kk index b6e6cead6..4c6c1b640 100644 --- a/lib/std/core/hnd.kk +++ b/lib/std/core/hnd.kk @@ -109,6 +109,7 @@ import std/core/undiv extern import c file "inline/hnd" js file "inline/hnd.js" + vm file "inline/hnd.mcore.sexp" // ------------------------------------------- // Internal types @@ -199,8 +200,7 @@ extern evv-eq(evv0 : evv, evv1 : evv ) : bool pub inline extern @evv-at ( i : ev-index ) : ev // pretend total; don't simplify c "kk_evv_at" js "$std_core_hnd._evv_at" - vm "!sexp:(letrec ((define $elt:top (lambda ($l:ptr $n:int) (switch $n:int (0 (project $l:ptr $evv $cons 0)) (_ ($elt:top (project $l:ptr $evv $cons 1) (\"infixSub(Int, Int): Int\" $n:int 1))))) )) ($elt:top (\"getRef(Ref[Ptr]): Ptr\" (\"getGlobal(String): Ptr\" \"current-evv\")) $arg0:int))" - // TODO move elt to extern file + vm "!sexp:((qualified $\"import$std/core/hnd\":ptr \"elt\" (fun Pure (ptr int) ptr)) ((qualified $\"import$std/core/hnd\":ptr \"getCurrentEvv\" (fun Effectful () ptr))) $arg0:int)" // (dynamically) find evidence insertion/deletion index in the evidence vector // The compiler optimizes `@evv-index` to a static index when apparent from the effect type. @@ -212,13 +212,13 @@ pub extern @evv-index( htag : htag ) : e ev-index extern evv-get() : e evv c "kk_evv_get" js "$std_core_hnd._evv_get" - vm "!sexp:(\"getRef(Ref[Ptr]): Ptr\" (\"getGlobal(String): Ptr\" \"current-evv\"))" + vm "!sexp:($getCurrentEvv:(fun Effectful () ptr))" // Set the current evidence vector. inline extern evv-set( w : evv ) : e () c "kk_evv_set" js "$std_core_hnd._evv_set" - vm "!sexp:(\"setRef(Ref[Ptr], Ptr): Unit\" (\"getGlobal(String): Ptr\" \"current-evv\") $arg0:ptr)" + vm "!sexp:((qualified $\"import$std/core/hnd\":ptr \"setCurrentEvv\" (fun Effectful (ptr) unit)) $arg0:ptr)" // Does the current evidence vector consist solely of affine handlers? // This is called in backends that do not have context paths (like javascript) @@ -249,6 +249,7 @@ pub extern @evv-is-affine() : bool inline extern evv-swap( w : evv ) : e evv c "kk_evv_swap" js "$std_core_hnd._evv_swap" + vm "!sexp:((qualified $\"import$std/core/hnd\":ptr \"swapCurrentEvv\" (fun Effectful (ptr) ptr)) $arg0:ptr)" // Remove evidence at index `i` of the current evidence vector, and return the old one. // (used by `mask`) @@ -437,7 +438,7 @@ pub noinline fun @hhandle( tag:htag, h : h, ret: a -> e r, action : () - prompt(w0,w1,ev,m,ret,cast-ev0(action)()) extern @reset-vm( m : marker, ret : a -> e0 r, action : () -> e0 a) : e0 r - vm "!sexp:(debugWrap \"reset\" (reset ($arg0:ptr $ignore:ptr) (let ((define $ret:top ($arg2:ptr))) $ret:top) (($res:top) (debugWrap \"returnClause\" ($arg1:ptr $res:top) ) ) ) )" + vm "!sexp:(debugWrap \"reset\" (reset ($arg0:ptr $ignore:ptr) (the top ($arg2:ptr)) (($res:top) (debugWrap \"returnClause\" ($arg1:ptr $res:top) ) ) ) )" pub noinline fun @hhandle-vm( tag:htag, h : h, ret: a -> e r, action : () -> e1 a ) : e r // insert new evidence for our handler @@ -537,6 +538,7 @@ inline extern add(i : int, j : int) : int c "kk_integer_add" cs inline "(#1 + #2)" js inline "(#1 + #2)" // "$std_core_types._int_add" + vm "infixAdd(Int, Int): Int" // are two integers equal? inline extern eq( ^x : int, ^y : int) : bool diff --git a/lib/std/core/inline/hnd.mcore.sexp b/lib/std/core/inline/hnd.mcore.sexp new file mode 100644 index 000000000..f0a67abf8 --- /dev/null +++ b/lib/std/core/inline/hnd.mcore.sexp @@ -0,0 +1,28 @@ +(define $"import$std/core/hnd":ptr (this-lib)) + +;; Current evidence vector +;; ----------------------- +(define $getCurrentEvv:(fun Effectful () ptr) (lambda () + ("getRef(Ref[Ptr]): Ptr" ("getGlobal(String): Ptr" "current-evv"))) + :export-as ("getCurrentEvv")) +(define $setCurrentEvv:(fun Effectful (ptr) unit) (lambda ($evv:ptr) + ("setRef(Ref[Ptr], Ptr): Unit" ("getGlobal(String): Ptr" "current-evv") $evv:ptr)) + :export-as ("setCurrentEvv")) +(define $swapCurrentEvv:(fun Effectful (ptr) ptr) (lambda ($evv:ptr) + (letrec ((define $ref:ptr ("getGlobal(String): Ptr" "current-evv")) + (define $old:ptr ("getRef(Ref[Ptr]): Ptr" $ref:ptr))) + (begin + ("setRef(Ref[Ptr], Ptr): Unit" $ref:ptr $evv:ptr) + $old:ptr))) + :export-as ("swapCurrentEvv")) + +;; List utilities +;; -------------- +(define $elt:top (lambda ($l:ptr $n:int) + (switch $n:int + (0 (project $l:ptr $evv $cons 0)) + (_ ($elt:top (project $l:ptr $evv $cons 1) + ("infixSub(Int, Int): Int" $n:int 1))))) + :export-as ("elt")) + +(unit) \ No newline at end of file diff --git a/lib/std/core/inline/int.mcore.sexp b/lib/std/core/inline/int.mcore.sexp new file mode 100644 index 000000000..cf7339daf --- /dev/null +++ b/lib/std/core/inline/int.mcore.sexp @@ -0,0 +1,17 @@ +;; Converting from strings +(define $parseWithBase:top (lambda ($s:str $base:int) + (prim ($res:int $err:int) ("read(String, Int): Int" $s:str $base:int) + (switch + (1 ;; OK + (make $std/core/types/maybe $std/core/types/Just ($res:top))) + (_ ;; couldnt parse + (make $std/core/types/maybe $std/core/types/Nothing ())))))) +(define $xparseImpl:(fun Pure (ptr int) ptr) (lambda ($s:str $hex:int) + (switch $hex:int + (0 ;; parse + ($parseWithBase:top $s:str 0) + ) + (_ ;; hexadecimal + ($parseWithBase:top $s:str 16))))) + +(unit) \ No newline at end of file diff --git a/lib/std/core/inline/vector.mcore.sexp b/lib/std/core/inline/vector.mcore.sexp new file mode 100644 index 000000000..efd5cdb95 --- /dev/null +++ b/lib/std/core/inline/vector.mcore.sexp @@ -0,0 +1,11 @@ +;; File with definitions for vectors (incomplete) +(define $vectorToList:top (lambda ($vec:ptr $tail:ptr $i:int) + (switch $i:int + (0 $tail:ptr) + (_ (letrec ((define $ni:int ("infixSub(Int, Int): Int" $i:int 1)) + (define $el:ptr ("unsafeIndex(Array[Ptr], Int): Ptr" $vec:ptr $ni:int)) + (define $ntl:ptr (make $std/core/types/list $std/core/types/Cons + ($el:ptr $tail:ptr)))) + ($vectorToList:top $vec:ptr $ntl:ptr $ni:int)))))) + +(unit) \ No newline at end of file diff --git a/lib/std/core/int.kk b/lib/std/core/int.kk index cebadec9d..886c8b862 100644 --- a/lib/std/core/int.kk +++ b/lib/std/core/int.kk @@ -23,6 +23,7 @@ import std/core/types extern import c file "inline/int.h" js file "inline/int.js" + vm file "inline/int.mcore.sexp" pub fip fun order( i : int ) : order if i < 0 then Lt @@ -302,14 +303,14 @@ pub fip fun mbint( m : maybe ) : int // An empty string, or a string starting with white space will result in `Nothing` // A string can start with a `-` sign for negative numbers, // and with `0x` or `0X` for hexadecimal numbers (in which case the `hex` parameter is ignored). -pub fun parse-int( s : string, hex : bool = False) : maybe +pub noinline fun parse-int( s : string, hex : bool = False) : maybe s.xparse(hex) noinline extern xparse( s : string, hex : bool ) : maybe c "kk_integer_xparse" cs "Primitive.IntParse" js "_int_parse" - + vm "!sexp:($xparseImpl:(fun Pure (ptr int) ptr) $arg0:ptr $arg1:int)" // ---------------------------------------------------------------------------- diff --git a/lib/std/core/vector.kk b/lib/std/core/vector.kk index 3217f0404..9e3aac42f 100644 --- a/lib/std/core/vector.kk +++ b/lib/std/core/vector.kk @@ -18,6 +18,7 @@ import std/core/int extern import c file "inline/vector" js file "inline/vector.js" + vm file "inline/vector.mcore.sexp" // ---------------------------------------------------------------------------- // Vectors @@ -138,6 +139,7 @@ pub extern vlist( v : vector, tail : list = [] ) : list c "kk_vector_to_list" cs inline "Primitive.VList<##1>(#1,#2)" js inline "_vlist(#1,#2)" + vm "!sexp:($vectorToList:top $arg0:ptr $arg1:ptr (\"length(Array[Ptr]): Int\" $arg0:ptr))" // Convert a list to a vector. pub fun list/vector( xs : list ) : vector diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index e081e42f7..bb1929ea3 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -62,6 +62,7 @@ vmFromCore buildType mbMain imports core genModule :: BuildType -> Maybe (Name,Bool) -> [Import] -> Core -> Asm Doc genModule buildType mbMain imports core = do rememberDataInfos (coreProgTypeDefs core) + let externIncludes = concatMap (genExternInclude buildType) (coreProgExternals core) impdecls <- genLoadLibs imports decls0 <- genGroups True (coreProgDefs core) decls1 <- genTypeDefs (coreProgTypeDefs core) @@ -81,13 +82,23 @@ genModule buildType mbMain imports core , "koka version" .= str version , "program name" .= str (show (coreProgName core)) ] + , "includes" .= list externIncludes , "definitions" .= - list (impdecls + list ( impdecls ++ decls0 ++ decls1 ) , "main" .= mainEntry ] +--------------------------------------------------------------------------------- +-- Extern includes +--------------------------------------------------------------------------------- +genExternInclude :: BuildType -> External -> [Doc] +genExternInclude buildType (e@ExternalImport{}) = + case externalImportLookup VM buildType "include-inline" e of + Just content -> [obj ["format" .= str "sexp", "value" .= str content]] + Nothing -> [] +genExternInclude _ _ = [] --------------------------------------------------------------------------------- -- Generate import definitions @@ -429,13 +440,9 @@ genExpr expr then return (text "") else return (doc) Nothing - -> do lsDecls <- genExprs (f:trimOptionalArgs args) + -> do lsDecls <- genExprs (f:args) let (fdoc:docs) = lsDecls - return $ obj [ "op" .= str "App" - , "fn" .= fdoc - , "args" .= list docs - ] - + return $ app fdoc docs Let groups body -> do decls1 <- genGroups False groups (doc) <- genExpr body @@ -524,12 +531,12 @@ genInline expr _ | isPureExpr expr -> genPure expr TypeLam _ e -> genInline e TypeApp e _ -> genInline e - App (TypeApp (Con name repr) _) [arg] | getName name == nameOptional || isConIso repr + App (TypeApp (Con name repr) _) [arg] | isConIso repr -> genInline arg App (Con _ repr) [arg] | isConIso repr -> genInline arg App f args - -> do argDocs <- mapM genInline (trimOptionalArgs args) + -> do argDocs <- mapM genInline args case extractExtern f of Just (tname,formats) -> case args of @@ -541,10 +548,7 @@ genInline expr ((Var tname _),[Lit (LitInt i)]) | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT,nameInt64,nameIntPtrT] && isSmallInt i -> return (pretty i) _ -> do fdoc <- genInline f - return $ obj [ "op" .= str "App" - , "fn" .= fdoc - , "args" .= list argDocs - ] + return $ app fdoc argDocs _ -> failure ("VM.FromCore.genInline: invalid expression:\n" ++ show expr) extractExtern :: Expr -> Maybe (TName,[(Target,String)]) @@ -613,14 +617,6 @@ genVarNames ts = do ns <- newVarNames (length ts) let tns = zipWith TName ns ts mapM genTName tns -trimOptionalArgs args - = reverse (dropWhile isOptionalNone (reverse args)) - where - isOptionalNone arg - = case arg of - TypeApp (Con tname _) _ -> getName tname == nameOptionalNone - _ -> False - --------------------------------------------------------------------------------- -- Classification --------------------------------------------------------------------------------- @@ -830,7 +826,7 @@ obj = encloseSep lbrace rbrace comma -- Smart-constructors for instructions -------------------------------------------------------------------------------- app :: Doc -> [Doc] -> Doc -app fn args = obj [ "op" .= text "\"App\"" +app fn args = obj [ "op" .= str "App" , "fn" .= fn , "args" .= list args ] diff --git a/src/Compile/CodeGen.hs b/src/Compile/CodeGen.hs index 46a1e5418..908f86036 100644 --- a/src/Compile/CodeGen.hs +++ b/src/Compile/CodeGen.hs @@ -279,7 +279,8 @@ codeGenVM term flags sequential entry outBase core writeDocW 80 outmcore vm when (showAsmVM flags) (termInfo term vm) - runCommand term flags [rpyeffectAsm flags, "--from", "mcore-json", outmcore, outrpy] + -- FIXME: for now, use debug flags + runCommand term flags [rpyeffectAsm flags, "--debug", "--check-contracts", "--from", "mcore-json", outmcore, outrpy] case mbEntry of Nothing -> return noLink From 5af34d8e6d5b73f271cf4d743904d97511ece139 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Thu, 2 May 2024 14:24:48 +0200 Subject: [PATCH 33/48] Fix unsupported externs in other backends --- lib/std/core/hnd.kk | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lib/std/core/hnd.kk b/lib/std/core/hnd.kk index 4c6c1b640..46becf442 100644 --- a/lib/std/core/hnd.kk +++ b/lib/std/core/hnd.kk @@ -320,9 +320,8 @@ extern yield-to-prim( m : marker, clause : (resume-result -> e1 r) -> extern @yield-to-prim-vm( m : marker, clause : (b -> e1 r) -> e1 r ) : e b vm "!sexp:(debugWrap \"yield-to-prim\" (shift:top ($arg0:ptr 0) ($resume:ptr) ($arg1:ptr (lambda ($val:top) (debugWrap \"Resuming\" (resume $resume:ptr $val:top) ) )))) )" - -extern @not_implemented() : a - vm "!undefined:Not implemented." + c inline "kk_box_null()" + js inline "undefined" extern yield-to-final( m : marker, clause : (resume-result -> e1 r) -> e1 r ) : e b c "kk_yield_final" @@ -438,6 +437,8 @@ pub noinline fun @hhandle( tag:htag, h : h, ret: a -> e r, action : () - prompt(w0,w1,ev,m,ret,cast-ev0(action)()) extern @reset-vm( m : marker, ret : a -> e0 r, action : () -> e0 a) : e0 r + c inline "kk_box_null()" + js inline "undefined" vm "!sexp:(debugWrap \"reset\" (reset ($arg0:ptr $ignore:ptr) (the top ($arg2:ptr)) (($res:top) (debugWrap \"returnClause\" ($arg1:ptr $res:top) ) ) ) )" pub noinline fun @hhandle-vm( tag:htag, h : h, ret: a -> e r, action : () -> e1 a ) : e r From 60e7c68e5ec0f219e10936b04f8c527866193a45 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Thu, 2 May 2024 15:23:44 +0200 Subject: [PATCH 34/48] Fix parsing ints --- lib/std/core/inline/int.mcore.sexp | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/std/core/inline/int.mcore.sexp b/lib/std/core/inline/int.mcore.sexp index cf7339daf..541bce62b 100644 --- a/lib/std/core/inline/int.mcore.sexp +++ b/lib/std/core/inline/int.mcore.sexp @@ -1,17 +1,17 @@ ;; Converting from strings -(define $parseWithBase:top (lambda ($s:str $base:int) +(define $parseWithBase:(fun Pure (str int) ptr) (lambda ($s:str $base:int) (prim ($res:int $err:int) ("read(String, Int): Int" $s:str $base:int) - (switch + (switch $err:int (1 ;; OK (make $std/core/types/maybe $std/core/types/Just ($res:top))) (_ ;; couldnt parse (make $std/core/types/maybe $std/core/types/Nothing ())))))) -(define $xparseImpl:(fun Pure (ptr int) ptr) (lambda ($s:str $hex:int) +(define $xparseImpl:(fun Pure (str int) ptr) (lambda ($s:str $hex:int) (switch $hex:int (0 ;; parse - ($parseWithBase:top $s:str 0) + ($parseWithBase:(fun Pure (str int) ptr) $s:str 0) ) (_ ;; hexadecimal - ($parseWithBase:top $s:str 16))))) + ($parseWithBase:(fun Pure (str int) ptr) $s:str 16))))) (unit) \ No newline at end of file From d333ab519dc48fd297f3ee1b782025e1dce8e3a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 3 May 2024 10:22:10 +0200 Subject: [PATCH 35/48] Type-annotate returns from match clauses --- src/Backend/VM/FromCore.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index bb1929ea3..8e12281b4 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -259,7 +259,7 @@ genExprStat expr -> do exprDoc <- genInline expr return exprDoc - Case exprs branches + caseExpr@(Case exprs branches) -> do (defss, scrutinees) <- unzip <$> mapM (\e-> if isInlineableExpr e && isTypeBool (typeOf e) then do d <- genInline e return ([], d) @@ -267,7 +267,7 @@ genExprStat expr vd <- genTName vn return (sd, vd) ) exprs - doc <- genMatch scrutinees branches + doc <- genMatch scrutinees branches (typeOf caseExpr) return $ obj [ "op" .= str "LetRec" , "definitions" .= list (concat defss) , "body" .= doc @@ -286,8 +286,8 @@ genExprStat expr return exprDoc -- | Generates a statement for a match expression regarding a given return context -genMatch :: [Doc] -> [Branch] -> Asm Doc -genMatch scrutinees branches +genMatch :: [Doc] -> [Branch] -> Type -> Asm Doc +genMatch scrutinees branches atTpe = fmap (debugWrap "genMatch") $ do case branches of [] -> fail ("Backend.VM.FromCore.genMatch: no branch in match statement: " ++ show(scrutinees)) @@ -321,15 +321,16 @@ genMatch scrutinees branches let se = withNameSubstitutions substs gs <- mapM (se . genGuard) guards - return (conditions, debugWrap ("genBranch: " ++ show substs) $ vcat gs) -- FIXME + return (conditions, debugWrap ("genBranch: " ++ show substs) $ vcat gs) -- FIXME TODO use AlternativeChoice instead of vcat genGuard :: Guard -> Asm Doc genGuard (Guard t expr) = do testE <- genExpr t exprSt <- genExpr expr + let exprSt' = obj [ "op" .= str "The", "type" .= transformType atTpe, "term" .= exprSt ] return $ if isExprTrue t - then exprSt - else ifEqInt testE (text "1") exprSt + then exprSt' + else ifEqInt testE (text "1") exprSt' -- | Generates a list of boolish expression for matching the pattern genTest :: Name -> (Doc, Pattern) -> Asm ([ConditionDoc], [(TName, Doc)]) From 89d60136caecbf09600a63952e6f9f46f0fae763 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 3 May 2024 10:31:00 +0200 Subject: [PATCH 36/48] Fix generation of matches with mulitple guard alternaitves --- src/Backend/VM/FromCore.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index 8e12281b4..03d1e866b 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -321,7 +321,8 @@ genMatch scrutinees branches atTpe let se = withNameSubstitutions substs gs <- mapM (se . genGuard) guards - return (conditions, debugWrap ("genBranch: " ++ show substs) $ vcat gs) -- FIXME TODO use AlternativeChoice instead of vcat + return (conditions, debugWrap ("genBranch: " ++ show substs) + $ obj [ "op" .= str "AlternativeChoice", "choices" .= list gs ]) genGuard :: Guard -> Asm Doc genGuard (Guard t expr) From 8c168a99548715239fb0675b4cd03c0037cbbcd6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 3 May 2024 10:31:21 +0200 Subject: [PATCH 37/48] Do not spuriously drop first argument on vm --- lib/std/os/env.kk | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/std/os/env.kk b/lib/std/os/env.kk index 460d235a6..6ae7c8149 100644 --- a/lib/std/os/env.kk +++ b/lib/std/os/env.kk @@ -62,8 +62,10 @@ pub fun get-argv() : ndet list // The `arguments` list will be `["--flag","bla"]` pub fun get-args() : ndet list val is-node = (host() == "node") + val is-vm = (host() == "vm") match get-argv() Cons(x,xx) | is-node && x.path.stemname == "node" -> xx.drop(1) + xs | is-vm -> xs xs -> xs.drop(1) // Return the main OS name: windows, linux, macos, unix, posix, ios, tvos, watchos, unknown. From ee67067572666128d351d732cadcf775ebeca0b3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 3 May 2024 11:59:47 +0200 Subject: [PATCH 38/48] lib: local references for vm --- lib/std/core/types.kk | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index b1d9fbc1d..a2b096e09 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -396,18 +396,21 @@ pub inline extern local-new(value:a) : |e> local-var c "kk_ref_alloc" cs inline "new Ref<##1,##2>(#1)" js inline "{ value: #1 }" + vm "mkRef(Ptr): Ref[Ptr]" // Assign a new value to a local variable pub inline extern local-set( ^v: local-var, assigned: a) : |e> () c "kk_ref_set_borrow" cs inline "#1.Set(#2)"; js inline "((#1).value = #2)" + vm "setRef(Ref[Ptr], Ptr): Unit" // Read the value of a local variable. pub inline extern local-get : forall (v: local-var) -> |e> a with(hdiv) c "kk_ref_get" cs inline "#1.Value"; js inline "((#1).value)"; + vm "getRef(Ref[Ptr]): Ptr" // _Internal_: if local mutation is unobservable, the `:local` effect can be erased by using the `local-scope` function. // See also: _State in Haskell, by Simon Peyton Jones and John Launchbury_. From 4f7cc1a22e2971d92ca0b778160333fa0544a788 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 17 May 2024 09:58:13 +0200 Subject: [PATCH 39/48] Add some int32 features to run bench/koka/counter --- lib/std/num/int32.kk | 10 ++++++++++ src/Backend/VM/FromCore.hs | 13 +++++++------ 2 files changed, 17 insertions(+), 6 deletions(-) diff --git a/lib/std/num/int32.kk b/lib/std/num/int32.kk index e14d9a787..72fea70dd 100644 --- a/lib/std/num/int32.kk +++ b/lib/std/num/int32.kk @@ -41,12 +41,14 @@ pub inline fip extern int32( i : int) : int32 c "kk_integer_clamp32" cs "Primitive.IntToInt32" js "$std_core_types._int_clamp32" + vm "!sexp:$arg0:num" // Convert an `:int32` to an `:int`. pub inline fip extern int( i : int32 ) : int c "kk_integer_from_int" cs inline "(new BigInteger(#1))" js "$std_core_types._int_from_int32" + vm "!sexp:$arg0:num" /* // Convert a `:float64` to an `:int32`. The float64 is clamped to the @@ -101,37 +103,45 @@ pub fun show-hex32( i : int32, width : int = 8, use-capitals : bool = True, pre pub inline fip extern (==)(x : int32, y : int32) : bool inline "(#1 == #2)" js inline "(#1 === #2)" + vm "infixEq(Int, Int): Boolean" // Are two 32-bit integers not equal? pub inline fip extern (!=)(x : int32, y : int32) : bool inline "(#1 != #2)" js inline "(#1 !== #2)" + vm "infixNeq(Int, Int): Boolean" // Is the first 32-bit integer smaller or equal to the second? pub inline fip extern (<=)(x : int32, y : int32) : bool inline "(#1 <= #2)" + vm "infixLte(Int, Int): Boolean" // Is the first 32-bit integer larger or equal to the second? pub inline fip extern (>=)(x : int32, y : int32) : bool inline "(#1 >= #2)" + vm "infixGte(Int, Int): Boolean" // Is the first 32-bit integer smaller than the second? pub inline fip extern (<)(x : int32, y : int32) : bool inline "(#1 < #2)" + vm "infixLt(Int, Int): Boolean" // Is the first 32-bit integer larger than the second? pub inline fip extern (>)(x : int32, y : int32) : bool inline "(#1 > #2)" + vm "infixGt(Int, Int): Boolean" // Add two 32-bit integers. pub inline fip extern (+)(x : int32, y : int32) : int32 c inline "(int32_t)((uint32_t)#1 + (uint32_t)#2)" // avoid UB js inline "((#1 + #2)|0)" + vm "infixAdd(Int, Int): Int" // Subtract two 32-bit integers. pub inline fip extern (-)(x : int32, y : int32) : int32 c inline "(int32_t)((uint32_t)#1 - (uint32_t)#2)" // avoid UB js inline "((#1 - #2)|0)" + vm "infixSub(Int, Int): Int" // Is the 32-bit integer negative? pub inline fip extern is-neg( i : int32 ) : bool diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index 03d1e866b..59fdcbae2 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -128,6 +128,7 @@ transformType (TCon c) | nameModule (typeConName c) == "std/core/types" = case ( "string" -> tpe "String" "bool" -> tpe "Int" "int" -> tpe "Int" + "int32" -> tpe "Int" t -> obj [ "op" .= str "Ptr", "extern_ptr_name" .= (str $ show t) ] transformType (TCon c) = obj [ "op" .= str "Ptr", "extern_ptr_name" .= (str $ show $ typeConName c) ] transformType (TApp t as) = transformType t @@ -433,8 +434,8 @@ genExpr expr Nothing -> case extractExtern f of Just (tname,formats) -> case args of - [Lit (LitInt i)] | getName tname `elem` [nameByte, nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT, nameInt64, nameIntPtrT] - -> return (pretty i) + [Lit (LitInt i)] | getName tname `elem` intTypes + -> return $ obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= pretty i ] _ -> -- genInlineExternal tname formats argDocs do (argDocs) <- genExprs args (doc) <- genExprExternal tname formats argDocs @@ -542,13 +543,13 @@ genInline expr case extractExtern f of Just (tname,formats) -> case args of - [Lit (LitInt i)] | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT, nameInt64,nameIntPtrT] && isSmallInt i - -> return (pretty i) + [Lit (LitInt i)] | getName tname `elem` intTypes + -> return $ obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= pretty i ] _ -> genExprExternal tname formats argDocs Nothing -> case (f,args) of - ((Var tname _),[Lit (LitInt i)]) | getName tname `elem` [nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT,nameInt64,nameIntPtrT] && isSmallInt i - -> return (pretty i) + ((Var tname _),[Lit (LitInt i)]) | getName tname `elem` intTypes && isSmallInt i + -> return $ obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= pretty i ] _ -> do fdoc <- genInline f return $ app fdoc argDocs _ -> failure ("VM.FromCore.genInline: invalid expression:\n" ++ show expr) From 31ff978a1fdca3b9d84f814f7db8975263e53885 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 17 May 2024 09:59:49 +0200 Subject: [PATCH 40/48] promote_ptr evv in evv-at --- lib/std/core/hnd.kk | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/std/core/hnd.kk b/lib/std/core/hnd.kk index 46becf442..079fcf9c9 100644 --- a/lib/std/core/hnd.kk +++ b/lib/std/core/hnd.kk @@ -200,7 +200,7 @@ extern evv-eq(evv0 : evv, evv1 : evv ) : bool pub inline extern @evv-at ( i : ev-index ) : ev // pretend total; don't simplify c "kk_evv_at" js "$std_core_hnd._evv_at" - vm "!sexp:((qualified $\"import$std/core/hnd\":ptr \"elt\" (fun Pure (ptr int) ptr)) ((qualified $\"import$std/core/hnd\":ptr \"getCurrentEvv\" (fun Effectful () ptr))) $arg0:int)" + vm "!sexp:((qualified $\"import$std/core/hnd\":ptr \"elt\" (fun Pure (ptr int) ptr)) (\"promote_ptr\" ((qualified $\"import$std/core/hnd\":ptr \"getCurrentEvv\" (fun Effectful () ptr)))) $arg0:int)" // (dynamically) find evidence insertion/deletion index in the evidence vector // The compiler optimizes `@evv-index` to a static index when apparent from the effect type. From 3fa3ed431f67a279e08e2e5efcae53720917f754 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Thu, 23 May 2024 16:48:45 +0200 Subject: [PATCH 41/48] Fix adjustment of evidence indices for VM --- lib/std/core/hnd.kk | 4 +++- lib/std/core/inline/hnd.mcore.sexp | 15 +++++++++++++++ src/Compile/Optimize.hs | 3 +++ 3 files changed, 21 insertions(+), 1 deletion(-) diff --git a/lib/std/core/hnd.kk b/lib/std/core/hnd.kk index 079fcf9c9..b7b3a50b3 100644 --- a/lib/std/core/hnd.kk +++ b/lib/std/core/hnd.kk @@ -262,12 +262,14 @@ extern evv-swap-delete( i : ev-index, behind : bool ) : e1 evv inline extern evv-swap-create0() : e evv //not quite the right effect type but avoids unbound effect types c "kk_evv_swap_create0" js "$std_core_hnd._evv_swap_create0" + vm "!sexp:((qualified $\"import$std/core/hnd\":ptr \"evvSwapCreate0\" (fun Effectful () ptr)))" // Swap the current evidence vector with a singleton vector (with the evidence at current index `i`). // (this is common in open calls to switch to a singleton effect context when calling operations) inline extern evv-swap-create1( i : ev-index ) : e evv //not quite the right effect type but avoids unbound effect types c "kk_evv_swap_create1" js "$std_core_hnd._evv_swap_create1" + vm "!sexp:((qualified $\"import$std/core/hnd\":ptr \"evvSwapCreate1\" (fun Effectful (int) ptr)) $arg0:ptr)" // Swap the current evidence vector with a new vector consisting of evidence // at indices `indices` in the current vector. @@ -314,7 +316,7 @@ extern yield-prompt( m: marker ) : yld js "_yield_prompt" vm "!sexp:(reset ($arg0:ptr $ignore:ptr) $std/core/hnd/Pure:ptr (($ret:ptr) $ret:ptr))" -extern yield-to-prim( m : marker, clause : (resume-result -> e1 r) -> e1 r ) : e (() -> b) +noinline extern yield-to-prim( m : marker, clause : (resume-result -> e1 r) -> e1 r ) : e (() -> b) c "kk_yield_to" js "$std_core_hnd._yield_to" diff --git a/lib/std/core/inline/hnd.mcore.sexp b/lib/std/core/inline/hnd.mcore.sexp index f0a67abf8..910810229 100644 --- a/lib/std/core/inline/hnd.mcore.sexp +++ b/lib/std/core/inline/hnd.mcore.sexp @@ -15,6 +15,21 @@ ("setRef(Ref[Ptr], Ptr): Unit" $ref:ptr $evv:ptr) $old:ptr))) :export-as ("swapCurrentEvv")) +(define $evvSwapCreate1:(fun Effectful (int) ptr) (lambda ($n:int) + (letrec ((define $cur:ptr ($getCurrentEvv:(fun Effectful () ptr))) + (define $ev:ptr ($elt:top $cur:ptr $n:int)) + (define $next:ptr (make $evv $cons ($ev:ptr (make $evv $nil ()))))) + (begin + ($setCurrentEvv:(fun Effectful (ptr) unit) $next:ptr) + $cur:ptr))) + :export-as ("evvSwapCreate1")) +(define $evvSwapCreate0:(fun Effectful () ptr) (lambda () + (letrec ((define $cur:ptr ($getCurrentEvv:(fun Effectful () ptr))) + (define $next:ptr (make $evv $nil ()))) + (begin + ($setCurrentEvv:(fun Effectful (ptr) unit) $next:ptr) + $cur:ptr))) + :export-as ("evvSwapCreate0")) ;; List utilities ;; -------------- diff --git a/src/Compile/Optimize.hs b/src/Compile/Optimize.hs index aa7e1a1a1..1108acb5a 100644 --- a/src/Compile/Optimize.hs +++ b/src/Compile/Optimize.hs @@ -112,6 +112,9 @@ coreOptimize flags newtypes gamma inlines coreProgram -- trace (show progName ++ ": monadic transform") $ do Core.Monadic.monTransform penv openResolve penv gamma -- must be after monTransform + + when (target flags == VM) $ openResolve penv gamma + checkCoreDefs "monadic transform" -- simplify open applications (needed before inlining open defs) From f5736a0523cae2e9e34561a71fdd3abd02e609c3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 24 May 2024 14:35:37 +0200 Subject: [PATCH 42/48] Correctly restore evidence on resume --- lib/std/core/hnd.kk | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lib/std/core/hnd.kk b/lib/std/core/hnd.kk index b7b3a50b3..b6db79c10 100644 --- a/lib/std/core/hnd.kk +++ b/lib/std/core/hnd.kk @@ -337,8 +337,10 @@ noinline fun yield-to( m : marker, clause : (resume-result -> e1 r) - f() noinline fun @yield-to-vm( m : marker, clause : (b -> e1 r) -> e1 r ) : e1 b - //val w0 = evv-get() - @yield-to-prim-vm(m, clause) + val w0 = evv-get() + val r = @yield-to-prim-vm(m, clause) + evv-set(w0) + r pub type yield-info From ec2e1d945d5e4edf7c009bb61e33e04888515e2e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Wed, 29 May 2024 11:59:34 +0200 Subject: [PATCH 43/48] Fix ordering in evidence vectors --- lib/std/core/hnd.kk | 3 ++- lib/std/core/inline/hnd.mcore.sexp | 26 ++++++++++++++++++++++++++ 2 files changed, 28 insertions(+), 1 deletion(-) diff --git a/lib/std/core/hnd.kk b/lib/std/core/hnd.kk index b6db79c10..f67a5f2ed 100644 --- a/lib/std/core/hnd.kk +++ b/lib/std/core/hnd.kk @@ -177,7 +177,7 @@ extern fresh-marker-named() : marker extern evv-insert( evv : evv, ev : ev ) : e1 evv c "kk_evv_insert" js "_evv_insert" - vm "!sexp:(make $evv $cons ($arg1:ptr $arg0:ptr))" + vm "!sexp:($evvInsert:(fun Pure (ptr ptr) ptr) $arg0:ptr $arg1:ptr)" // show evidence for debug purposes extern evv-show( evv : evv ) : string @@ -207,6 +207,7 @@ pub inline extern @evv-at ( i : ev-index ) : ev // pretend total; don't pub extern @evv-index( htag : htag ) : e ev-index c "kk_evv_index" js "__evv_index" + vm "!sexp:($evvIndex:(fun Pure (ptr ptr int) int) ($getCurrentEvv:(fun Effectful (ptr) ptr)) $arg0:ptr 0)" // Get the current evidence vector. extern evv-get() : e evv diff --git a/lib/std/core/inline/hnd.mcore.sexp b/lib/std/core/inline/hnd.mcore.sexp index 910810229..9d92fb06f 100644 --- a/lib/std/core/inline/hnd.mcore.sexp +++ b/lib/std/core/inline/hnd.mcore.sexp @@ -30,6 +30,32 @@ ($setCurrentEvv:(fun Effectful (ptr) unit) $next:ptr) $cur:ptr))) :export-as ("evvSwapCreate0")) +(define $evHtag:(fun Pure (ptr) str) (lambda ($ev:ptr) + (project (project $ev:ptr $std/core/hnd/ev $std/core/hnd/Ev 0) + $std/core/hnd/htag $std/core/hnd/Htag 0))) +(define $evvInsert:(fun Pure (ptr ptr) ptr) (lambda ($evv:ptr $ev:ptr) + (match ($evv:ptr $evv) + ($cons ($fst:ptr $rst:ptr) + (switch ("infixGt(String, String): Boolean" + ($evHtag:(fun Pure (ptr) str) $ev:ptr) + ($evHtag:(fun Pure (ptr) str) $fst:ptr)) + (1 (make $evv $cons ( + $fst:ptr + ($evvInsert:(fun Pure (ptr ptr) ptr) $rst:ptr $ev:ptr)))) + (_ (make $evv $cons ($ev:ptr $evv:ptr))))) + (_ () (make $evv $cons ($ev:ptr $evv:ptr))))) + :export-as ("evvInsert")) +(define $evvIndex:(fun Pure (ptr ptr int) int) (lambda ($evv:ptr $htag:ptr $acc:int) ;; Find by htag + (match ($evv:ptr $evv) + ($cons ($fst:ptr $rst:ptr) + (switch ("infixEq(String, String): Boolean" + (project $htag:ptr $std/core/hnd/htag $std/core/hnd/Htag 0) + ($evHtag:(fun Pure (ptr) str) $fst:ptr)) + (1 $acc:int) + (_ ($evvIndex:(fun Pure (ptr ptr int) int) $rst:ptr $htag:ptr + ("infixAdd(Int, Int): Int" $acc:int 1))))) + (_ () ("!undefined:no evidence for htag")))) + :export-as ("evvIndex")) ;; List utilities ;; -------------- From d77c13e0b9f74a36c99ac90e66387d5f76b5dd08 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Tue, 4 Jun 2024 14:52:35 +0200 Subject: [PATCH 44/48] Fix local mutable variables for VM --- lib/std/core/hnd.kk | 8 ++++++++ src/Backend/VM/FromCore.hs | 1 + src/Common/NamePrim.hs | 2 ++ src/Compile/Optimize.hs | 7 ++++--- 4 files changed, 15 insertions(+), 3 deletions(-) diff --git a/lib/std/core/hnd.kk b/lib/std/core/hnd.kk index f67a5f2ed..1d131b9a8 100644 --- a/lib/std/core/hnd.kk +++ b/lib/std/core/hnd.kk @@ -508,6 +508,14 @@ pub inline fun local-var(init:a, action: (l:local-var) -> |e> b ) val res = cast-ev1(action)(std/core/types/@byref(loc)) prompt-local-var(std/core/types/@byref(loc),res) +extern @prompt-local-var-prim-vm(init: a, action: (l:local-var) -> |e> b): |e> b + vm "!sexp:(debugWrap \"prompt-local-var-prim\" (reset ((fresh-label) $reg:ptr) (the top (letref ($ref:ptr $reg:ptr $arg0:top) ($arg1:top $ref:ptr))) (($res:top) $res:top)))" + c inline "kk_box_null()" + js inline "undefined" + +pub fun local-var-vm(init:a, action: (l:local-var) -> |e> b ) : |e> b + @prompt-local-var-prim-vm(init, action) + // ------------------------------------------- // Finally diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs index 59fdcbae2..081677c39 100644 --- a/src/Backend/VM/FromCore.hs +++ b/src/Backend/VM/FromCore.hs @@ -154,6 +154,7 @@ switchNames = -- , (nameNamedHandle, nameNamedHandleVM) , (nameYieldTo, nameYieldToVM) , (nameProtect, nameProtectVM) + , (nameLocalVar, nameLocalVarVM) ] genDef :: Bool -> Def -> Asm Doc diff --git a/src/Common/NamePrim.hs b/src/Common/NamePrim.hs index c1b544a02..9362da199 100644 --- a/src/Common/NamePrim.hs +++ b/src/Common/NamePrim.hs @@ -154,6 +154,7 @@ module Common.NamePrim , nameTpRef, nameRef , nameTpLocalVar, nameTpLocal , nameLocalVar, nameRunLocal, nameLocalSet, nameLocalGet, nameLocalNew + , nameLocalVarVM , nameTpOptional @@ -399,6 +400,7 @@ nameTpLocal = coreTypesName "local" nameRef = coreTypesName "ref" nameLocalNew = coreTypesName "local-new" nameLocalVar = coreHndName "local-var" +nameLocalVarVM = coreHndName "local-var-vm" nameRunLocal = coreTypesName "local-scope" nameTpTotal = nameEffectEmpty -- coreTypesName "total" diff --git a/src/Compile/Optimize.hs b/src/Compile/Optimize.hs index 1108acb5a..6ee4279cf 100644 --- a/src/Compile/Optimize.hs +++ b/src/Compile/Optimize.hs @@ -19,7 +19,7 @@ import Common.Error import Common.Range import Common.Unique import Common.Name -import Common.NamePrim( isPrimitiveModule, isPrimitiveName, nameCoreHnd ) +import Common.NamePrim( isPrimitiveModule, isPrimitiveName, nameCoreHnd, nameLocalVar ) import Common.Syntax import qualified Common.NameSet as S import Core.Pretty( prettyDef ) @@ -58,6 +58,7 @@ coreOptimize flags newtypes gamma inlines coreProgram let progName = Core.coreProgName coreProgram penv = prettyEnvFromFlags flags checkCoreDefs title = when (coreCheck flags) $ Core.Check.checkCore False False penv gamma + vmInlineFilter = if (target flags == VM) then (\n -> n `notElem` [nameLocalVar]) else const True -- when (show progName == "std/text/parse") $ -- trace ("compile " ++ show progName ++ ", gamma: " ++ showHidden gamma) $ return () @@ -77,7 +78,7 @@ coreOptimize flags newtypes gamma inlines coreProgram when (optInlineMax flags > 0) $ do let inlinesX = if isPrimitiveModule progName then inlines else inlinesFilter (\name -> nameModule nameCoreHnd /= nameModule name) inlines - inlineDefs penv (2*(optInlineMax flags)) inlinesX + inlineDefs penv (2*(optInlineMax flags)) (inlinesFilter vmInlineFilter inlinesX) -- checkCoreDefs "inlined" simplifyDupN @@ -129,7 +130,7 @@ coreOptimize flags newtypes gamma inlines coreProgram -- now inline primitive definitions (like yield-bind) let inlinesX = inlinesFilter isPrimitiveName inlines -- trace ("inlines2: " ++ show (map Core.inlineName (inlinesToList inlinesX))) $ - inlineDefs penv (2*optInlineMax flags) inlinesX -- (loadedInlines loaded) + inlineDefs penv (2*optInlineMax flags) (inlinesFilter vmInlineFilter inlinesX) -- (loadedInlines loaded) -- remove remaining open calls; this may change effect types simplifyDefs penv True {-unsafe-} ndebug (simplify flags) 0 -- remove remaining .open From 6b972556294abc59f461444448383920945ac1c5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 21 Jun 2024 17:16:32 +0200 Subject: [PATCH 45/48] use top instead of ptr in some positions --- lib/std/core/hnd.kk | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/std/core/hnd.kk b/lib/std/core/hnd.kk index 1d131b9a8..6017f5bcd 100644 --- a/lib/std/core/hnd.kk +++ b/lib/std/core/hnd.kk @@ -322,7 +322,7 @@ noinline extern yield-to-prim( m : marker, clause : (resume-result -> js "$std_core_hnd._yield_to" extern @yield-to-prim-vm( m : marker, clause : (b -> e1 r) -> e1 r ) : e b - vm "!sexp:(debugWrap \"yield-to-prim\" (shift:top ($arg0:ptr 0) ($resume:ptr) ($arg1:ptr (lambda ($val:top) (debugWrap \"Resuming\" (resume $resume:ptr $val:top) ) )))) )" + vm "!sexp:(debugWrap \"yield-to-prim\" (shift:top ($arg0:ptr 0) ($resume:top) ($arg1:ptr (lambda ($val:top) (debugWrap \"Resuming\" (resume $resume:ptr $val:top) ) )))) )" c inline "kk_box_null()" js inline "undefined" @@ -608,7 +608,7 @@ abstract value type clause1V,e::E,r::V> inline extern cast-clause0( f : (marker,ev) -> e1 b) : e ((marker,ev) -> e b) inline "#1" - vm "!sexp:(debugWrap \"cast-clause0\" $arg0:ptr)" + vm "!sexp:(debugWrap \"cast-clause0\" $arg0:top)" inline extern cast-clause1( f : (marker,ev,a) -> e1 b) : e ((marker,ev,a) -> e b) inline "#1" From 70b8a83ecf310aacc11d49585eb6a99a9f8cd631 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Wed, 24 Jul 2024 11:20:33 +0200 Subject: [PATCH 46/48] vm: implement evvSwapDelete --- lib/std/core/hnd.kk | 1 + lib/std/core/inline/hnd.mcore.sexp | 19 +++++++++++++++++++ 2 files changed, 20 insertions(+) diff --git a/lib/std/core/hnd.kk b/lib/std/core/hnd.kk index 6017f5bcd..9f35b76b4 100644 --- a/lib/std/core/hnd.kk +++ b/lib/std/core/hnd.kk @@ -257,6 +257,7 @@ inline extern evv-swap( w : evv ) : e evv extern evv-swap-delete( i : ev-index, behind : bool ) : e1 evv c "kk_evv_swap_delete" js "_evv_swap_delete" + vm "!sexp:($evvSwapDelete:(fun Effectful (int int) ptr) $arg0:int $arg1:int)" // Swap the current evidence vector with an empty vector. // (this is used in open calls to switch to a total context) diff --git a/lib/std/core/inline/hnd.mcore.sexp b/lib/std/core/inline/hnd.mcore.sexp index 9d92fb06f..cb70c8774 100644 --- a/lib/std/core/inline/hnd.mcore.sexp +++ b/lib/std/core/inline/hnd.mcore.sexp @@ -30,9 +30,28 @@ ($setCurrentEvv:(fun Effectful (ptr) unit) $next:ptr) $cur:ptr))) :export-as ("evvSwapCreate0")) +(define $evvSwapDelete:(fun Effectful (int int) ptr) (lambda ($i:int $behind:int) + (letrec ((define $cur:ptr ($getCurrentEvv:(fun Effectful () ptr))) + (define $next:ptr ($evvDelete:(fun Pure (int ptr) ptr) ("infixAdd(Int, Int): Int" $i:int $behind:int) $cur:ptr))) + (begin + ($setCurrentEvv:(fun Effectful (ptr) unit) $next:ptr) + $cur:ptr))) + :export-as ("evvSwapDelete")) (define $evHtag:(fun Pure (ptr) str) (lambda ($ev:ptr) (project (project $ev:ptr $std/core/hnd/ev $std/core/hnd/Ev 0) $std/core/hnd/htag $std/core/hnd/Htag 0))) + +;; make primitive? +(define $evvDelete:(fun Pure (int int ptr) ptr) (lambda ($i:int $evv:ptr) + (match ($evv:ptr $evv) + ($cons ($hd:ptr $tl:ptr) + (switch $i:int + (0 $tl:ptr) + (_ (make $evv $cons ( + $hd:ptr + ($evvDelete:(fun Pure (int int ptr) ptr) ("infixSub(Int, Int): Int" $i:int 1) $tl:ptr)))))) + (_ () ("panic(String): Bottom" "Out of bounds index into evidence vector")))) + :export-as ("evvDelete")) (define $evvInsert:(fun Pure (ptr ptr) ptr) (lambda ($evv:ptr $ev:ptr) (match ($evv:ptr $evv) ($cons ($fst:ptr $rst:ptr) From 033bea37848d63442224e2c281f8683eb07204a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Wed, 24 Jul 2024 11:21:20 +0200 Subject: [PATCH 47/48] vm: test target --- test/Spec.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test/Spec.hs b/test/Spec.hs index 68e53cbca..b8c68e356 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -211,6 +211,8 @@ processOptions arg (options,hargs) then (options{target="js"}, hargs) else if (arg == "--target-c64c") then (options{target="c64c"}, hargs) + else if (arg == "--target-vm") + then (options{ target="vm" }, hargs) else if (arg == "--seq") then (options{par=False}, hargs) else (options, arg : hargs) From 20dc2e9c3890a07fb60415906e264849fadd6f8b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcial=20Gai=C3=9Fert?= Date: Fri, 26 Jul 2024 11:45:09 +0200 Subject: [PATCH 48/48] Remove debug output for rpyeffect-asm by default --- src/Compile/CodeGen.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Compile/CodeGen.hs b/src/Compile/CodeGen.hs index 908f86036..09fd8ccae 100644 --- a/src/Compile/CodeGen.hs +++ b/src/Compile/CodeGen.hs @@ -280,7 +280,7 @@ codeGenVM term flags sequential entry outBase core when (showAsmVM flags) (termInfo term vm) -- FIXME: for now, use debug flags - runCommand term flags [rpyeffectAsm flags, "--debug", "--check-contracts", "--from", "mcore-json", outmcore, outrpy] + runCommand term flags [rpyeffectAsm flags,"--from", "mcore-json", outmcore, outrpy] -- for debugging: "--debug", "--check-contracts", case mbEntry of Nothing -> return noLink