diff --git a/compiler/app/Main.hs b/compiler/app/Main.hs index fd007e2b..f90799d2 100644 --- a/compiler/app/Main.hs +++ b/compiler/app/Main.hs @@ -2,7 +2,7 @@ module Main (main) where -import qualified AtomFolding as AF +import qualified SynVarFolding as SF import Parser import qualified Core as Core import RetDFCPS @@ -107,7 +107,7 @@ process flags fname input = do putStrLn (showIndent 2 prog) -------------------------------------------------- - prog' <- case runExcept (C.trans compileMode (AF.visitProg prog)) of + prog' <- case runExcept (C.trans compileMode (SF.visitProg prog)) of Right p -> return p Left s -> die s when verbose $ do printSep "PATTERN MATCH ELIMINATION" diff --git a/compiler/src/AddAmbientMethods.hs b/compiler/src/AddAmbientMethods.hs index a88d67ac..dd347be2 100644 --- a/compiler/src/AddAmbientMethods.hs +++ b/compiler/src/AddAmbientMethods.hs @@ -21,14 +21,14 @@ printDecl :: FunDecl printDecl = FunDecl "print" [Lambda [VarPattern "x"] $ Let [ValDecl (VarPattern "out") (App (Var "getStdout") [Var "authority"]) NoPos] - (App (Var "fprintln") [Tuple [Var "out", Var "x"]]) + (App (Var "fprintln") [Tuple [Var "out", Var "x"] False]) ] NoPos printWithLabelsDecl :: FunDecl printWithLabelsDecl = FunDecl "printWithLabels" [Lambda [VarPattern "x"] $ Let [ValDecl (VarPattern "out") (App (Var "getStdout") [Var "authority"]) NoPos] - (App (Var "fprintlnWithLabels") [Tuple [Var "out", Var "x"]]) + (App (Var "fprintlnWithLabels") [Tuple [Var "out", Var "x"] False]) ] NoPos @@ -36,7 +36,7 @@ printStringDecl :: FunDecl printStringDecl = FunDecl "printString" [Lambda [VarPattern "x"] $ Let [ValDecl (VarPattern "out") (App (Var "getStdout") [Var "authority"]) NoPos] - (App (Var "fwrite") [Tuple [Var "out", Bin Concat (Var "x") (Lit (LString "\\n"))]]) + (App (Var "fwrite") [Tuple [Var "out", Bin Concat (Var "x") (Lit (LString "\\n"))] False]) ] NoPos @@ -44,4 +44,4 @@ printStringDecl = FunDecl "printString" addAmbientMethods :: Prog -> Prog addAmbientMethods (Prog imports atoms t) = let t' = Let [FunDecs [printDecl,printWithLabelsDecl,printStringDecl]] t - in Prog imports atoms t' \ No newline at end of file + in Prog imports atoms t' diff --git a/compiler/src/AtomFolding.hs b/compiler/src/AtomFolding.hs deleted file mode 100644 index 1aad7ba8..00000000 --- a/compiler/src/AtomFolding.hs +++ /dev/null @@ -1,83 +0,0 @@ -module AtomFolding ( visitProg ) -where -import Basics -import Direct -import Data.Maybe -import Control.Monad - -visitProg :: Prog -> Prog -visitProg (Prog imports (Atoms atms) tm) = - Prog imports (Atoms atms) (visitTerm atms tm) - -visitTerm :: [AtomName] -> Term -> Term -visitTerm atms (Lit lit) = Lit lit -visitTerm atms (Var nm) = - if (elem nm atms) - then Lit (LAtom nm) - else Var nm -visitTerm atms (Abs lam) = - Abs (visitLambda atms lam) -visitTerm atms (Hnd (Handler pat maybePat maybeTerm term)) = - Hnd (Handler (visitPattern atms pat) - (liftM (visitPattern atms) maybePat) - (liftM (visitTerm atms) maybeTerm) - (visitTerm atms term)) -visitTerm atms (App t1 ts) = - App (visitTerm atms t1) (map (visitTerm atms) ts) -visitTerm atms (Let decls term) = - Let (map visitDecl decls) (visitTerm atms term) - where - visitDecl (ValDecl pat t pos) = ValDecl (visitPattern atms pat) (visitTerm atms t) pos - visitDecl (FunDecs decs) = - FunDecs (map (\(FunDecl nm lams pos) -> (FunDecl nm (map (visitLambda atms) lams) pos)) decs) -visitTerm atms (Case t declTermList p) = - Case (visitTerm atms t) - (map (\(pat, term) -> ((visitPattern atms pat), (visitTerm atms term))) declTermList) - p -visitTerm atms (If t1 t2 t3) = - If (visitTerm atms t1) (visitTerm atms t2) (visitTerm atms t3) -visitTerm atms (Tuple terms) = - Tuple (map (visitTerm atms) terms) -visitTerm atms (Record fields) = Record (visitFields atms fields) -visitTerm atms (WithRecord e fields) = - WithRecord (visitTerm atms e) (visitFields atms fields) -visitTerm atms (ProjField t f) = - ProjField (visitTerm atms t) f -visitTerm atms (ProjIdx t idx) = - ProjIdx (visitTerm atms t) idx -visitTerm atms (List terms) = - List (map (visitTerm atms) terms) -visitTerm atms (ListCons t1 t2) = - ListCons (visitTerm atms t1) (visitTerm atms t2) -visitTerm atms (Bin op t1 t2) = - Bin op (visitTerm atms t1) (visitTerm atms t2) -visitTerm atms (Un op t) = - Un op (visitTerm atms t) -visitTerm atms (Seq ts) = - Seq $ map (visitTerm atms) ts -visitTerm atms (Error t) = - Error (visitTerm atms t) - - -visitFields atms fs = map visitField fs - where visitField (f, Nothing) = (f, Nothing) - visitField (f, Just t) = (f, Just (visitTerm atms t)) - -visitPattern :: [AtomName] -> DeclPattern -> DeclPattern -visitPattern atms pat@(VarPattern nm) = - if (elem nm atms) - then ValPattern (LAtom nm) - else pat -visitPattern _ pat@(ValPattern _) = pat -visitPattern atms (AtPattern p l) = AtPattern (visitPattern atms p) l -visitPattern _ pat@Wildcard = pat -visitPattern atms (TuplePattern pats) = TuplePattern (map (visitPattern atms) pats) -visitPattern atms (ConsPattern p1 p2) = ConsPattern (visitPattern atms p1) (visitPattern atms p2) -visitPattern atms (ListPattern pats) = ListPattern (map (visitPattern atms) pats) -visitPattern atms (RecordPattern fields mode) = RecordPattern (map visitField fields) mode - where visitField pat@(_, Nothing) = pat - visitField (f, Just p) = (f, Just (visitPattern atms p)) - -visitLambda :: [AtomName] -> Lambda -> Lambda -visitLambda atms (Lambda pats term) = - (Lambda (map (visitPattern atms) pats) (visitTerm atms term)) diff --git a/compiler/src/Basics.hs b/compiler/src/Basics.hs index 622e31a0..d917c651 100644 --- a/compiler/src/Basics.hs +++ b/compiler/src/Basics.hs @@ -9,8 +9,12 @@ import GHC.Generics(Generic) import Data.Serialize (Serialize) type VarName = String -type AtomName = String +type SyntacticVariantName = String +type SyntacticVariantConstructorName = String +type SyntacticVariantConstructor = (SyntacticVariantConstructorName, [VarName]) +type SyntacticVariantDef = (SyntacticVariantName, [SyntacticVariantConstructor]) type FieldName = String +type SynVariantTag = Bool -- | Eq and Neq: deep equality check on the two parameters, including the types (any type inequality results in false being returned). data BinOp = Plus | Minus | Mult | Div | Mod | Eq | Neq | Le | Lt | Ge | Gt | And | Or | RaisedTo | FlowsTo | Concat| IntDiv | BinAnd | BinOr | BinXor | BinShiftLeft | BinShiftRight | BinZeroShiftRight | HasField | LatticeJoin | LatticeMeet diff --git a/compiler/src/CPSOpt.hs b/compiler/src/CPSOpt.hs index de68c0d8..99677231 100644 --- a/compiler/src/CPSOpt.hs +++ b/compiler/src/CPSOpt.hs @@ -77,8 +77,8 @@ instance Substitutable SimpleTerm where case simpleTerm of Bin op v1 v2 -> Bin op (fwd v1) (fwd v2) Un op v -> Un op (fwd v) - Tuple vs -> Tuple (map fwd vs) - Record fields -> Record $ fwdFields fields + Tuple vs tag -> Tuple (map fwd vs) tag + Record fields -> Record (fwdFields fields) WithRecord x fields -> WithRecord (fwd x) $ fwdFields fields ProjField x f -> ProjField (fwd x) f ProjIdx x idx -> ProjIdx (fwd x) idx @@ -145,7 +145,7 @@ instance CensusCollectible SimpleTerm where Bin _ v1 v2 -> updateCensus [v1,v2] Un _ v -> updateCensus v ValSimpleTerm sv -> updateCensus sv - Tuple vs -> updateCensus vs + Tuple vs _ -> updateCensus vs Record fs -> let (_,vs) = unzip fs in updateCensus vs WithRecord v fs -> updateCensus v >> (let (_,vs) = unzip fs in updateCensus vs ) ProjField v _ -> updateCensus v @@ -326,17 +326,17 @@ simplifySimpleTerm t = v <- look operand -- TODO should write out all cases case (op,v) of - (Basics.IsTuple, St (Tuple _)) -> _ret __trueLit - (Basics.IsTuple, St (Record _)) -> _ret __falseLit + (Basics.IsTuple, St (Tuple _ _)) -> _ret __trueLit + (Basics.IsTuple, St (Record _)) -> _ret __falseLit (Basics.IsTuple, St (WithRecord _ _)) -> _ret __falseLit (Basics.IsTuple, St (List _)) -> _ret __falseLit (Basics.IsTuple, St (ListCons _ _)) -> _ret __falseLit (Basics.IsTuple, St (ValSimpleTerm _)) -> _ret __falseLit - (Basics.IsRecord, St (Record _)) -> _ret __trueLit + (Basics.IsRecord, St (Record _)) -> _ret __trueLit (Basics.IsRecord, St (WithRecord _ _)) -> _ret __trueLit - (Basics.IsRecord, St (Tuple _)) -> _ret __falseLit + (Basics.IsRecord, St (Tuple _ _)) -> _ret __falseLit (Basics.IsRecord, St (List _)) -> _ret __falseLit (Basics.IsRecord, St (ListCons _ _)) -> _ret __falseLit (Basics.IsRecord, St (ValSimpleTerm _)) -> _ret __falseLit @@ -344,12 +344,12 @@ simplifySimpleTerm t = (Basics.IsList, St (List _)) -> _ret __trueLit (Basics.IsList, St (ListCons _ _)) -> _ret __trueLit - (Basics.IsList, St (Record _)) -> _ret __falseLit + (Basics.IsList, St (Record _)) -> _ret __falseLit (Basics.IsList, St (WithRecord _ _)) -> _ret __falseLit - (Basics.IsList, St (Tuple _)) -> _ret __falseLit + (Basics.IsList, St (Tuple _ _)) -> _ret __falseLit (Basics.IsList, St (ValSimpleTerm _)) -> _ret __falseLit - (Basics.TupleLength, St (Tuple xs)) -> + (Basics.TupleLength, St (Tuple xs _)) -> _ret $ lit (C.LInt (fromIntegral (length xs)) NoPos) -- 2023-08 Revision: Added this case (Basics.ListLength, St (List xs)) -> @@ -366,7 +366,7 @@ simplifySimpleTerm t = ProjIdx x idx -> do t <- look x case t of - St (Tuple vs) | fromIntegral (length vs) > idx -> + St (Tuple vs _) | fromIntegral (length vs) > idx -> _subst (vs !! fromIntegral idx) _ -> _nochange @@ -409,7 +409,7 @@ failFree st = case st of Bin op _ _ -> op `elem` [Basics.Eq, Basics.Neq] -- Equality comparisons are safe (return boolean) Un _ _ -> False -- Unary operations can fail (e.g., head on empty list, arithmetic on non-numbers) ValSimpleTerm _ -> True - Tuple _ -> True + Tuple _ _ -> True Record _ -> True WithRecord _ _ -> True ProjField _ _ -> False -- Field projection can fail if field doesn't exist @@ -545,5 +545,5 @@ iter kt = iter kt' rewrite :: Prog -> Prog -rewrite (Prog atoms kterm) = - Prog atoms (iter kterm) \ No newline at end of file +rewrite (Prog kterm) = + Prog (iter kterm) diff --git a/compiler/src/CaseElimination.hs b/compiler/src/CaseElimination.hs index a50c1547..42c3f50d 100644 --- a/compiler/src/CaseElimination.hs +++ b/compiler/src/CaseElimination.hs @@ -27,12 +27,12 @@ trans mode (S.Prog imports atms tm) = do S.Let [ S.ValDecl (S.VarPattern "authority") (S.Var "$$authorityarg") _srcRT ] tm Export -> tm - atms' <- transAtoms atms + atms' <- transSynVars atms tm'' <- transTerm tm' return (T.Prog imports atms' tm'') -transAtoms :: S.Atoms -> Trans T.Atoms -transAtoms (S.Atoms atms) = return (T.Atoms atms) +transSynVars :: S.SyntacticVariants -> Trans T.SyntacticVariants +transSynVars (S.SyntacticVariants atms) = return (T.SyntacticVariants atms) transLit :: S.Lit -> T.Lit transLit (S.LInt n pi) = T.LInt n pi @@ -41,7 +41,7 @@ transLit (S.LLabel s) = T.LLabel s transLit (S.LDCLabel dc) = T.LDCLabel dc transLit (S.LUnit) = T.LUnit transLit (S.LBool b) = T.LBool b -transLit (S.LAtom a) = T.LAtom a +transLit (S.LSyntacticVariant a) = T.LSyntacticVariant a transLambda_aux :: S.Lambda -> ReaderT T.Term Trans Lambda @@ -95,8 +95,8 @@ transHandler (S.Handler pat1 mbpat2 guard body) = do Just pat2 -> pat2 Nothing -> S.Wildcard lambdaPats = [S.VarPattern argInput] - callFailure = S.Tuple [S.Lit (S.LInt 1 _srcRT), S.Lit S.LUnit ] - body' = S.Tuple[ S.Lit (S.LInt 0 _srcRT), S.Abs ( S.Lambda [S.Wildcard] body ) ] + callFailure = S.Tuple [S.Lit (S.LInt 1 _srcRT), S.Lit S.LUnit ] False + body' = S.Tuple[ S.Lit (S.LInt 0 _srcRT), S.Abs ( S.Lambda [S.Wildcard] body ) ] False guardCheck = case guard of Nothing -> body' Just g -> S.If g body' callFailure @@ -188,7 +188,8 @@ compilePattern succ (v, S.RecordPattern fieldPatterns mode) = do compileField succ (f, Nothing) = do ifHasField f $ compilePattern succ (T.ProjField v f, S.VarPattern f) - +compilePattern _ (_, (S.SyntacticVariantPattern nm _)) = + lift $ throwError $ "Unexpected syntactic variant pattern: \"" ++ nm ++ "\"" -- | Tranform a declaration, compiling patterns into terms. @@ -211,7 +212,7 @@ transDecl (S.FunDecs fundecs) succ = do let lams' = map (transLambda_aux . (\(S.Lambda args e) -> S.Lambda [S.TuplePattern args] e)) lams names = map (((f ++ "_pat") ++) . show) [1..(length lams)] args = map (((f ++ "_arg") ++) . show) [1..(argLength lams)] - args' = Tuple (map Var args) + args' = Tuple (map Var args) False errorMsg = Error (Lit (LString $ "pattern match failure in function " ++ f)) pos (fst, decls) <- foldr (\(n, l) acc -> do (fail, decls) <- acc @@ -257,9 +258,9 @@ transTerm (S.If t1 t2 t3) = do t2' <- transTerm t2 t3' <- transTerm t3 return (If t1' t2' t3') -transTerm (S.Tuple tms) = do +transTerm (S.Tuple tms tag) = do tms' <- mapM transTerm tms - return (T.Tuple tms') + return (T.Tuple tms' tag) transTerm (S.Record fields) = do fields' <- transFields fields return (T.Record fields') @@ -302,4 +303,4 @@ transFields = mapM $ \case (f, Nothing) -> return (f, T.Var f) (f, Just t) -> do t' <- transTerm t - return (f, t') \ No newline at end of file + return (f, t') diff --git a/compiler/src/ClosureConv.hs b/compiler/src/ClosureConv.hs index d92d4024..6312b788 100644 --- a/compiler/src/ClosureConv.hs +++ b/compiler/src/ClosureConv.hs @@ -20,7 +20,7 @@ import Control.Monad.Reader import Data.List import CompileMode -import Control.Monad.Except +import Control.Monad.Except import IR as CCIR import Control.Monad.Identity @@ -45,7 +45,7 @@ type CC = RWS FreshCounter -- state: the counter for fresh name generation -type CCEnv = (CompileMode, C.Atoms, NestingLevel, Map VarName VarLevel, Maybe VarName) +type CCEnv = (CompileMode, NestingLevel, Map VarName VarLevel, Maybe VarName) type Frees = [(VarName, NestingLevel)] type FunDefs = [CCIR.FunDef] type ConstEntry = (VarName, C.Lit) @@ -59,9 +59,8 @@ consBB:: CCIR.IRInst -> CCIR.IRBBTree -> CCIR.IRBBTree consBB i (BB insts t) = BB (i:insts) t insVar :: VarName -> CCEnv -> CCEnv -insVar vn (compileMode, atms, lev, vmap, fname) = +insVar vn (compileMode, lev, vmap, fname) = ( compileMode - , atms , lev , Map.insert vn (VarNested lev) vmap , fname @@ -73,12 +72,12 @@ insVars vars ccenv = askLev = do - (_, _, lev, _, _) <- ask + (_, lev, _, _) <- ask return lev -incLev fname (compileMode, atms, lev, vmap, _) = - (compileMode, atms, lev + 1, vmap, (Just fname)) +incLev fname (compileMode, lev, vmap, _) = + (compileMode, lev + 1, vmap, (Just fname)) -- this helper function looks up the variable name @@ -87,7 +86,7 @@ incLev fname (compileMode, atms, lev, vmap, _) = transVar :: VarName -> CC VarAccess transVar v@(VN vname) = do - (_, C.Atoms atms, lev, vmap, maybe_fname) <- ask + (_, lev, vmap, maybe_fname) <- ask case maybe_fname of Just fname | fname == v -> return $ VarFunSelfRef _ -> @@ -99,10 +98,7 @@ transVar v@(VN vname) = do return $ VarEnv v else return $ VarLocal v - Nothing -> - if vname `elem` atms - then return $ VarLocal v - else error $ "undeclared variable: " ++ (show v) + Nothing -> error $ "undeclared variable: " ++ (show v) transVars = mapM transVar @@ -162,9 +158,9 @@ cpsToIR (CPS.LetSimple vname@(VN ident) st kt) = do CPS.Un unop v -> do v' <- transVar v _assign (Un unop v') - CPS.Tuple lst -> do + CPS.Tuple lst tag -> do lst' <- transVars lst - _assign (Tuple lst') + _assign (Tuple lst' tag) CPS.Record fields -> do fields' <- transFields fields _assign (Record fields') @@ -221,7 +217,7 @@ cpsToIR (CPS.LetFun fdefs kt) = do -- Special Halt continuation, for exiting program cpsToIR (CPS.Halt v) = do v' <- transVar v - (compileMode,_ , _ , _, _ ) <- ask + (compileMode, _ , _, _ ) <- ask let constructor = case compileMode of Normal -> CCIR.Ret @@ -263,10 +259,8 @@ cpsToIR (CPS.Error v p) = do ------------------------------------------------------------ closureConvert :: CompileMode -> CPS.Prog -> Except String CCIR.IRProgram -closureConvert compileMode (CPS.Prog (C.Atoms atms) t) = - let atms' = C.Atoms atms - initEnv = ( compileMode - , atms' +closureConvert compileMode (CPS.Prog t) = + let initEnv = ( compileMode , 0 -- initial nesting counter , Map.empty , Nothing -- top level code has no function name @@ -282,7 +276,7 @@ closureConvert compileMode (CPS.Prog (C.Atoms atms) t) = consts = (fst.unzip) consts_wo_levs main = FunDef (HFN toplevel) (VN argumentName) consts bb - irProg = CCIR.IRProgram (C.Atoms atms) $ fdefs++[main] + irProg = CCIR.IRProgram $ fdefs++[main] in do CCIR.wfIRProg irProg return irProg -- then irProg diff --git a/compiler/src/Core.hs b/compiler/src/Core.hs index 72af085f..03bbad1b 100644 --- a/compiler/src/Core.hs +++ b/compiler/src/Core.hs @@ -7,8 +7,6 @@ module Core ( Lambda (..) , Decl (..) , FunDecl (..) , Lit(..) - , AtomName - , Atoms(..) , Prog(..) , VarAccess(..) , lowerProg @@ -34,6 +32,7 @@ import ShowIndent import TroupePositionInfo import DCLabels +import Data.List (find) -------------------------------------------------- -- AST is the same as Direct, but lambda are unary (or nullary) @@ -57,7 +56,6 @@ data Lit | LDCLabel DCLabelExp | LUnit | LBool Bool - | LAtom AtomName deriving (Show, Generic) instance Serialize Lit instance Eq Lit where @@ -66,7 +64,6 @@ instance Eq Lit where (LLabel l) == (LLabel l') = l == l' LUnit == LUnit = True (LBool x) == (LBool y) = x == y - (LAtom x) == (LAtom y) = x == y (LDCLabel dc) == (LDCLabel dc') = dc == dc' _ == _ = False instance Ord Lit where @@ -75,15 +72,12 @@ instance Ord Lit where (LLabel x) <= (LLabel y) = x <=y (LUnit) <= (LUnit) = True (LBool x) <= (LBool y) = x <=y - (LAtom x) <= (LAtom y) = x <=y (LDCLabel x) <= (LDCLabel y) = x <= y (LInt _ _) <= (LString _) = True (LString _) <= (LLabel _) = True (LLabel _) <= (LUnit) = True (LUnit) <= (LBool _) = True - (LBool _) <= (LAtom _) = True - (LAtom _) <= (LDCLabel _) = True - _ <= _ = False + _ <= _ = False instance GetPosInfo Lit where posInfo (LInt _ p) = p @@ -107,8 +101,8 @@ data Term | Let Decl Term | If Term Term Term | AssertElseError Term Term Term PosInf - | Tuple [Term] - | Record Fields + | Tuple [Term] SynVariantTag + | Record Fields | WithRecord Term Fields | ProjField Term FieldName | ProjIdx Term Word @@ -120,12 +114,7 @@ data Term deriving (Eq) -data Atoms = Atoms [AtomName] - deriving (Eq, Show, Generic) -instance Serialize Atoms - - -data Prog = Prog Imports Atoms Term +data Prog = Prog Imports Term deriving (Eq, Show) @@ -151,15 +140,12 @@ The module also contains pretty printing for the Core representation. -- 1. Lowering -------------------------------------------------- -lowerProg (D.Prog imports atms term) = Prog imports (trans atms) (lower term) +lowerProg (D.Prog imports _ term) = Prog imports (lower term) -- the rest of the declarations in this part are not exported -trans :: D.Atoms -> Atoms -trans (D.Atoms atms) = Atoms atms - lowerLam (D.Lambda vs t) = case vs of [] -> Unary "$unit" (lower t) @@ -172,7 +158,7 @@ lowerLit (D.LLabel s) = LLabel s lowerLit (D.LDCLabel dc) = LDCLabel dc lowerLit D.LUnit = LUnit lowerLit (D.LBool b) = LBool b -lowerLit (D.LAtom n) = LAtom n +lowerLit (D.LSyntacticVariant n) = error $ "Unexpected syntactic variant: \"" ++ n ++ "\"" lower :: D.Term -> Core.Term lower (D.Lit l) = Lit (lowerLit l) @@ -198,7 +184,7 @@ lower (D.Let decls e) = -- lower (D.Case t patTermLst) = Case (lower t) (map (\(p,t) -> (lowerDeclPat p, lower t)) patTermLst) lower (D.If e1 e2 e3) = If (lower e1) (lower e2) (lower e3) lower (D.AssertElseError e1 e2 e3 p) = AssertElseError (lower e1 ) (lower e2) (lower e3) p -lower (D.Tuple terms) = Tuple (map lower terms) +lower (D.Tuple terms tag) = Tuple (map lower terms) tag lower (D.Record fields) = Record (map (\(f, t) -> (f, lower t)) fields) lower (D.WithRecord e fields) = WithRecord (lower e) (map (\(f, t) -> (f, lower t)) fields) lower (D.ProjField t f) = ProjField (lower t) f @@ -221,13 +207,12 @@ lower (D.Un op e) = Un op (lower e) -- This is the only function that is exported here renameProg :: Prog -> Prog -renameProg (Prog imports (Atoms atms) term) = - let alist = map (\ a -> (a, a)) atms - initEnv = Map.fromList alist +renameProg (Prog imports term) = + let initEnv = Map.empty initReader = mapFromImports imports initState = 0 (term', _) = evalRWS (rename term initEnv) initReader initState - in Prog imports (Atoms atms) term' + in Prog imports term' -- The rest of the declarations here are not exported @@ -330,8 +315,8 @@ rename (AssertElseError t1 t2 t3 p) m = do return $ AssertElseError t1' t2' t3' p -rename (Tuple terms) m = - Tuple <$> mapM (flip rename m) terms +rename (Tuple terms tag) m = + (\x -> Tuple x tag) <$> mapM (flip rename m) terms rename (Record fields) m = Record <$> mapM renameField fields @@ -413,15 +398,9 @@ instance ShowIndent Prog where ppProg :: Prog -> PP.Doc -ppProg (Prog (Imports imports) (Atoms atoms) term) = - let ppAtoms = - if null atoms - then PP.empty - else (text "datatype Atoms = ") <+> - (hsep $ PP.punctuate (text " |") (map text atoms)) - - ppImports = if null imports then PP.empty else text "<>\n" - in ppImports $$ ppAtoms $$ ppTerm 0 term +ppProg (Prog (Imports imports) term) = + let ppImports = if null imports then PP.empty else text "<>\n" + in ppImports $$ ppTerm 0 term ppTerm :: Precedence -> Term -> PP.Doc @@ -438,10 +417,14 @@ ppTerm' (Lit literal) = ppLit literal ppTerm' (Error t _) = text "error " PP.<> ppTerm' t -ppTerm' (Tuple ts) = +ppTerm' (Tuple ts False) = PP.parens $ PP.hcat $ PP.punctuate (text ",") (map (ppTerm 0) ts) +ppTerm' (Tuple ts True) = + case ts of [Lit (LString nm)] -> text nm + [Lit (LString nm), t] -> text nm PP.<> PP.space PP.<> ppTerm 0 t + otherwise -> text "error: Missing syntactic variant" ppTerm' (List ts) = PP.brackets $ @@ -549,19 +532,18 @@ ppDecl (FunDecs fs) = ppFuns fs ppLit :: Lit -> PP.Doc -ppLit (LInt i _) = PP.integer i +ppLit (LInt i _) = PP.integer i ppLit (LString s) = PP.doubleQuotes (text s) ppLit (LLabel s) = PP.braces (text s) ppLit LUnit = text "()" ppLit (LBool True) = text "true" ppLit (LBool False) = text "false" -ppLit (LAtom a) = text a ppLit (LDCLabel dc) = ppDCLabelExpLit dc termPrec :: Term -> Precedence termPrec (Lit _) = maxPrec -termPrec (Tuple _) = maxPrec +termPrec (Tuple _ _) = maxPrec termPrec (List _ ) = maxPrec termPrec (Var _) = maxPrec termPrec (App _ _) = appPrec diff --git a/compiler/src/Direct.hs b/compiler/src/Direct.hs index 6df77c46..d4cb5d8b 100644 --- a/compiler/src/Direct.hs +++ b/compiler/src/Direct.hs @@ -5,8 +5,9 @@ module Direct ( Lambda (..) , Lit(..) , DeclPattern(..) , RecordPatternMode(..) - , AtomName - , Atoms(..) + , SyntacticVariantName + , SyntacticVariantConstructor + , SyntacticVariants(..) , Prog(..) , Handler(..) , FieldName @@ -21,6 +22,7 @@ import Text.PrettyPrint.HughesPJ ( (<+>), ($$), text, hsep, vcat, nest) import ShowIndent import TroupePositionInfo +import Data.List (find) data PrimType @@ -48,7 +50,6 @@ type Guard = Maybe Term data Handler = Handler DeclPattern (Maybe DeclPattern) Guard Term deriving (Eq) - data DeclPattern = VarPattern VarName --SrcPosInf | ValPattern Lit @@ -58,6 +59,7 @@ data DeclPattern | ConsPattern DeclPattern DeclPattern --SrcPosInf | ListPattern [DeclPattern] --SrcPosInf | RecordPattern [(FieldName, Maybe DeclPattern)] RecordPatternMode + | SyntacticVariantPattern SyntacticVariantConstructorName DeclPattern deriving (Eq) data RecordPatternMode = ExactMatch | WildcardMatch @@ -78,7 +80,7 @@ data Lit | LString String --SrcPosInf | LLabel String --SrcPosInf | LDCLabel DCLabelExp - | LAtom AtomName --SrcPosInf + | LSyntacticVariant SyntacticVariantConstructorName --SrcPosInf deriving (Eq, Show) @@ -93,8 +95,8 @@ data Term | Let [Decl] Term | Case Term [(DeclPattern, Term)] PosInf | If Term Term Term - | Tuple [Term] - | Record Fields + | Tuple [Term] SynVariantTag + | Record Fields | WithRecord Term Fields | ProjField Term FieldName | ProjIdx Term Word @@ -106,11 +108,11 @@ data Term | Error Term deriving (Eq) -data Atoms = Atoms [AtomName] +data SyntacticVariants = SyntacticVariants [SyntacticVariantDef] deriving (Eq, Show) -data Prog = Prog Imports Atoms Term +data Prog = Prog Imports SyntacticVariants Term deriving (Eq, Show) @@ -130,13 +132,16 @@ instance ShowIndent Prog where ppProg :: Prog -> PP.Doc -ppProg (Prog (Imports imports) (Atoms atoms) term) = - let ppAtoms = - if null atoms - then PP.empty - else (text "datatype Atoms = ") <+> - (hsep $ PP.punctuate (text " |") (map text atoms)) - +ppProg (Prog (Imports imports) (SyntacticVariants datatypes) term) = + let ppSyntacticVariants = + if null datatypes + then PP.empty + else vcat $ flip map datatypes (\dt -> (text "datatype ") <+> + (text $ fst dt) <+> + (hsep $ PP.punctuate (text " |") (map ppConstructor $ snd dt))) + where ppConstructor (s, []) = text s + ppConstructor (s, x:[]) = text s <+> text " of " <+> text x + ppConstructor (s, xs) = text s <+> text " of " <+> PP.parens (hsep $ PP.punctuate (text " *") (map text xs)) ppImports = if null imports then PP.empty else @@ -144,7 +149,7 @@ ppProg (Prog (Imports imports) (Atoms atoms) term) = in (vcat $ (map ppLibName imports)) $$ PP.text "" in vcat [ ppImports - , ppAtoms + , ppSyntacticVariants , ppTerm 0 term ] @@ -162,13 +167,16 @@ ppTerm' (Lit literal) = ppLit literal ppTerm' (Error t) = text "error " PP.<> ppTerm' t -ppTerm' (Tuple ts) = +ppTerm' (Tuple ts False) = PP.parens $ PP.hcat $ PP.punctuate (text ",") (map (ppTerm 0) ts) +ppTerm' (Tuple ts True) = + case ts of [Lit (LString nm)] -> text nm + [Lit (LString nm), t] -> text nm PP.<> PP.space PP.<> ppTerm 0 t + otherwise -> text "error: Missing syntactiv variant" -ppTerm' (Record fs) = - PP.braces $ qqFields fs +ppTerm' (Record fs) = PP.braces $ qqFields fs ppTerm' (WithRecord t fs) = PP.braces $ PP.hsep [ppTerm 0 t, text "with", qqFields fs] @@ -337,6 +345,10 @@ ppDeclPattern (RecordPattern fields mode) = wildcard = case mode of ExactMatch -> [] WildcardMatch -> [text ".."] +ppDeclPattern (SyntacticVariantPattern nm pat) = + text nm PP.<> PP.space PP.<> + case pat of SyntacticVariantPattern _ _ -> PP.parens $ ppDeclPattern pat + otherwise -> ppDeclPattern pat ppLit :: Lit -> PP.Doc ppLit (LInt i _ ) = PP.integer i @@ -346,12 +358,12 @@ ppLit (LUnit ) = text "()" ppLit (LBool True ) = text "true" ppLit (LBool False) = text "false" ppLit (LLabel s ) = PP.braces (text s) -ppLit (LAtom s) = text s +ppLit (LSyntacticVariant s) = text s termPrec :: Term -> Precedence termPrec (Lit _) = maxPrec -termPrec (Tuple _) = maxPrec +termPrec (Tuple _ _) = maxPrec termPrec (List _ ) = maxPrec termPrec (Var _) = maxPrec termPrec (App _ _) = appPrec diff --git a/compiler/src/DirectWOPats.hs b/compiler/src/DirectWOPats.hs index 3fd5e022..99d78702 100644 --- a/compiler/src/DirectWOPats.hs +++ b/compiler/src/DirectWOPats.hs @@ -3,8 +3,9 @@ module DirectWOPats ( Lambda (..) , Decl (..) , FunDecl (..) , Lit(..) - , AtomName - , Atoms(..) + , SyntacticVariantName + , SyntacticVariantConstructor + , SyntacticVariants(..) , Prog(..) ) where @@ -16,6 +17,7 @@ import Text.PrettyPrint.HughesPJ ( import ShowIndent import DCLabels import TroupePositionInfo +import Data.List (find) data Decl = ValDecl VarName Term @@ -32,7 +34,7 @@ data Lit | LDCLabel DCLabelExp | LUnit | LBool Bool - | LAtom AtomName + | LSyntacticVariant SyntacticVariantName deriving (Eq, Show) @@ -50,8 +52,8 @@ data Term | Let [Decl] Term | If Term Term Term | AssertElseError Term Term Term PosInf - | Tuple [Term] - | Record Fields + | Tuple [Term] SynVariantTag + | Record Fields | WithRecord Term Fields | ProjField Term FieldName | ProjIdx Term Word @@ -62,17 +64,13 @@ data Term | Error Term PosInf deriving (Eq) -data Atoms = Atoms [AtomName] +data SyntacticVariants = SyntacticVariants [SyntacticVariantDef] deriving (Eq, Show) -data Prog = Prog Imports Atoms Term +data Prog = Prog Imports SyntacticVariants Term deriving (Eq, Show) - - - - -------------------------------------------------- -- show is defined via pretty printing instance Show Term @@ -88,14 +86,18 @@ instance ShowIndent Prog where ppProg :: Prog -> PP.Doc -ppProg (Prog (Imports imports) (Atoms atoms) term) = - let ppAtoms = - if null atoms - then PP.empty - else (text "datatype Atoms = ") <+> - (hsep $ PP.punctuate (text " |") (map text atoms)) +ppProg (Prog (Imports imports) (SyntacticVariants datatypes) term) = + let ppSyntacticVariants = + if null datatypes + then PP.empty + else vcat $ flip map datatypes (\dt -> (text "datatype ") <+> + (text $ fst dt) <+> + (hsep $ PP.punctuate (text " |") (map ppConstructor $ snd dt))) + where ppConstructor (s, []) = text s + ppConstructor (s, x:[]) = text s <+> text " of " <+> text x + ppConstructor (s, xs) = text s <+> text " of " <+> PP.parens (hsep $ PP.punctuate (text " *") (map text xs)) ppImports = if null imports then PP.empty else text "<>\n" - in ppImports $$ ppAtoms $$ ppTerm 0 term + in ppImports $$ ppSyntacticVariants $$ ppTerm 0 term ppTerm :: Precedence -> Term -> PP.Doc @@ -112,13 +114,16 @@ ppTerm' (Lit literal) = ppLit literal ppTerm' (Error t _) = text "error " PP.<> ppTerm' t -ppTerm' (Tuple ts) = +ppTerm' (Tuple ts False) = PP.parens $ PP.hcat $ PP.punctuate (text ",") (map (ppTerm 0) ts) +ppTerm' (Tuple ts True) = + case ts of [Lit (LString nm)] -> text nm + [Lit (LString nm), t] -> text nm PP.<> PP.space PP.<> ppTerm 0 t + otherwise -> text "error: Missing syntactiv variant" -ppTerm' (Record fs) = - PP.braces $ qqFields fs +ppTerm' (Record fs) = PP.braces $ qqFields fs ppTerm' (WithRecord e fs) = PP.braces $ PP.hsep [ ppTerm 0 e, text "with", qqFields fs ] @@ -223,14 +228,12 @@ ppLit (LDCLabel dc) = ppDCLabelExpLit dc ppLit LUnit = text "()" ppLit (LBool True) = text "true" ppLit (LBool False) = text "false" -ppLit (LAtom a) = text a - - +ppLit (LSyntacticVariant a) = text a termPrec :: Term -> Precedence termPrec (Lit _) = maxPrec -termPrec (Tuple _) = maxPrec +termPrec (Tuple _ _) = maxPrec termPrec (List _ ) = maxPrec termPrec (Var _) = maxPrec termPrec (App _ _) = appPrec diff --git a/compiler/src/Exports.hs b/compiler/src/Exports.hs index 0f9bd610..47a4f546 100644 --- a/compiler/src/Exports.hs +++ b/compiler/src/Exports.hs @@ -33,5 +33,5 @@ reify = mapM checkOne checkOne :: Term -> Except String String -checkOne (Tuple [Lit (LString s), Var vn]) = return s +checkOne (Tuple [Lit (LString s), Var vn] _) = return s checkOne _ = throwError errorMessage diff --git a/compiler/src/IR.hs b/compiler/src/IR.hs index 8621c088..412bc5e0 100644 --- a/compiler/src/IR.hs +++ b/compiler/src/IR.hs @@ -52,7 +52,7 @@ type Fields = [(Basics.FieldName, VarAccess)] data IRExpr = Bin Basics.BinOp VarAccess VarAccess | Un Basics.UnaryOp VarAccess - | Tuple [VarAccess] + | Tuple [VarAccess] Basics.SynVariantTag | Record Fields | WithRecord VarAccess Fields | ProjField VarAccess Basics.FieldName @@ -118,7 +118,7 @@ data FunDef = FunDef -- An IR program is just a collection of atoms declarations -- and function definitions -data IRProgram = IRProgram C.Atoms [FunDef] deriving (Generic) +data IRProgram = IRProgram [FunDef] deriving (Generic) ----------------------------------------------------------- -- Dependency calculation @@ -127,16 +127,13 @@ data IRProgram = IRProgram C.Atoms [FunDef] deriving (Generic) -- For dependencies, we only need the function dependencies class ComputesDependencies a where - dependencies :: a -> Writer ([HFN], [Basics.LibName], [Basics.AtomName]) () + dependencies :: a -> Writer ([HFN], [Basics.LibName], [Basics.SyntacticVariantName]) () instance ComputesDependencies IRInst where dependencies (MkFunClosures _ fdefs) = mapM_ (\(_, hfn) -> tell ([hfn],[],[])) fdefs dependencies (Assign _ (Lib libname _)) = - tell ([], [libname],[]) - dependencies (Assign _ (Const (C.LAtom a))) = - tell ([], [], [a]) - + tell ([], [libname],[]) dependencies _ = return () instance ComputesDependencies IRBBTree where @@ -182,7 +179,6 @@ instance Serialize IRBBTree ----------------------------------------------------------- data SerializationUnit = FunSerialization FunDef - | AtomsSerialization C.Atoms | ProgramSerialization IRProgram deriving (Generic) @@ -192,12 +188,6 @@ instance Serialize SerializationUnit serializeFunDef :: FunDef -> BS.ByteString serializeFunDef fdef = Serialize.runPut ( Serialize.put (FunSerialization fdef) ) -serializeAtoms :: C.Atoms -> BS.ByteString -serializeAtoms atoms = Serialize.runPut (Serialize.put (AtomsSerialization atoms)) - -deserializeAtoms :: BS.ByteString -> Either String C.Atoms -deserializeAtoms bs = Serialize.runGet (Serialize.get) bs - deserialize :: BS.ByteString -> Either String SerializationUnit deserialize bs = case Serialize.runGet (Serialize.get) bs of @@ -355,7 +345,7 @@ instance WellFormedIRCheck IRExpr where -- they may need to be checked too... wfIRProg :: IRProgram -> Except String () -wfIRProg (IRProgram _ funs) = mapM_ wfFun funs +wfIRProg (IRProgram funs) = mapM_ wfFun funs wfFun :: FunDef -> Except String () wfFun (FunDef (HFN fn) (VN arg) consts bb) = @@ -381,7 +371,7 @@ checkFromBB initState bb = -- PRETTY PRINTING ----------------------------------------------------------- -ppProg (IRProgram atoms funs) = +ppProg (IRProgram funs) = vcat $ (map ppFunDef funs) instance Show IRProgram where @@ -404,7 +394,7 @@ ppIRExpr (Bin binop va1 va2) = ppId va1 <+> text (show binop) <+> ppId va2 ppIRExpr (Un op v) = text (show op) <> PP.parens (ppId v) -ppIRExpr (Tuple vars) = +ppIRExpr (Tuple vars _) = PP.parens $ PP.hsep $ PP.punctuate (text ",") (map ppId vars) ppIRExpr (List vars) = PP.brackets $ PP.hsep $ PP.punctuate (text ",") (map ppId vars) @@ -498,7 +488,7 @@ instance Identifier HFN where instance Identifier Basics.LibName where ppId (Basics.LibName s) = text s -instance Identifier Basics.AtomName where +instance Identifier Basics.SyntacticVariantName where ppId = text diff --git a/compiler/src/IR2Raw.hs b/compiler/src/IR2Raw.hs index 7f663c17..0d08eb83 100644 --- a/compiler/src/IR2Raw.hs +++ b/compiler/src/IR2Raw.hs @@ -416,9 +416,9 @@ expr2rawComp = \case -- The following constructor operations take labelled values as arguments, -- but these labels do not affect the labels of the resulting compound value. - IR.Tuple vs -> + IR.Tuple vs tag -> return SimpleRawComp - { cVal = RExpr $ Tuple vs + { cVal = RExpr $ Tuple vs tag , cValLbl = PC , cTyLbl = PC } @@ -777,12 +777,11 @@ fun2raw irfdef@(IR.FunDef hfn vname consts (IR.BB irInsts irTr)) = -- Revision 2023-08: unchanged ir2raw :: IR.SerializationUnit -> RawUnit ir2raw (IR.FunSerialization f) = FunRawUnit (fun2raw f) -ir2raw (IR.AtomsSerialization c) = AtomRawUnit c ir2raw (IR.ProgramSerialization prog) = ProgramRawUnit (prog2raw prog) -- Revision 2023-08: unchanged prog2raw :: IR.IRProgram -> RawProgram -prog2raw (IR.IRProgram atoms funs) = - RawProgram atoms (map fun2raw funs) +prog2raw (IR.IRProgram funs) = + RawProgram (map fun2raw funs) diff --git a/compiler/src/IROpt.hs b/compiler/src/IROpt.hs index 610c1f24..b1bd25ec 100644 --- a/compiler/src/IROpt.hs +++ b/compiler/src/IROpt.hs @@ -37,7 +37,7 @@ instance Substitutable IRExpr where case e of Bin op x y -> Bin op (apply subst x) (apply subst y) Un op x -> Un op (apply subst x) - Tuple xs -> Tuple (map (apply subst) xs) + Tuple xs tag -> Tuple (map (apply subst) xs) tag Record fields -> Record (_ff fields) WithRecord x fields -> WithRecord (apply subst x) (_ff fields) ProjField x f -> ProjField (apply subst x) f @@ -193,7 +193,7 @@ canFailOrHasEffects expr = case expr of Lib _ _ -> True -- These are generally safe - Tuple _ -> False + Tuple _ _ -> False Record _ -> False WithRecord _ _ -> False -- Assuming the base is a record List _ -> False @@ -295,8 +295,8 @@ irExprPeval e = markUsed' x markUsed' y def_ - Record fields -> do mapM pevalField fields - r_ (RecordVal fields, e) + Record fields -> do mapM pevalField fields + r_ (RecordVal fields, e) -- def_ where pevalField (_, x) = markUsed' x WithRecord r fields -> do @@ -394,7 +394,7 @@ irExprPeval e = r_ (Unknown, e) - (Tuple xs) -> do + (Tuple xs _) -> do mapM_ markUsed' xs r_ (TupleVal xs, e) @@ -535,4 +535,4 @@ funopt (FunDef hfn argname consts bb) = iropt::IRProgram -> IRProgram -iropt (IRProgram atoms fdefs) = IRProgram atoms (map funopt fdefs) +iropt (IRProgram fdefs) = IRProgram (map funopt fdefs) diff --git a/compiler/src/Lexer.x b/compiler/src/Lexer.x index 5a205744..318ab1e4 100644 --- a/compiler/src/Lexer.x +++ b/compiler/src/Lexer.x @@ -102,7 +102,6 @@ tokens:- <0> andb { mkL TokenBinAnd } <0> orb { mkL TokenBinOr } <0> xorb { mkL TokenBinXor } -<0> Atoms { mkL TokenAtoms } <0> "#true" { mkL TokenDCTrue } <0> "#false" { mkL TokenDCFalse } "#root-confidentiality" { mkL TokenDCRootConf } @@ -196,7 +195,6 @@ data Token | TokenWhen | TokenWith | TokenDatatype - | TokenAtoms | TokenIntDiv | TokenMod | TokenFn diff --git a/compiler/src/Parser.y b/compiler/src/Parser.y index 3d67eb45..3cb69657 100644 --- a/compiler/src/Parser.y +++ b/compiler/src/Parser.y @@ -41,7 +41,6 @@ import Control.Monad.Except of { L _ TokenOf } import { L _ TokenImport } datatype { L _ TokenDatatype } - Atoms { L _ TokenAtoms } fn { L _ TokenFn } hn { L _ TokenHn } pini { L _ TokenPini } @@ -134,18 +133,27 @@ import Control.Monad.Except -Prog : ImportDecl AtomsDecl Expr { Prog (Imports $1) (Atoms $2) $3 } +Prog : ImportDecl SyntacticVariantDecl Expr { Prog (Imports $1) (SyntacticVariants $2) $3 } ImportDecl: import VAR ImportDecl { ((LibName (varTok $2), Nothing)): $3 } | { [] } -AtomsDecl : datatype Atoms '=' VAR AtomsList { (varTok $4):$5 } +SyntacticVariantDecl : datatype VAR '=' + SyntacticVariantConstructor + SyntacticVariantList + SyntacticVariantDecl { (varTok $2, $4:$5):$6 } | {[]} + +SyntacticVariantList : { [] } + | '|' SyntacticVariantConstructor SyntacticVariantList { $2: $3 } -AtomsList : { [] } - | '|' VAR AtomsList { (varTok $2): $3 } +SyntacticVariantConstructor : VAR { (varTok $1, []) } + | VAR of SyntacticVariantConstructorArgs { (varTok $1, $3) } +SyntacticVariantConstructorArgs : VAR { (varTok $1):[] } + | VAR '*' SyntacticVariantConstructorArgs { (varTok $1):$3 } + | '(' SyntacticVariantConstructorArgs ')' { $2 } Expr: Form { $1 } | let pini Expr Decs in Expr end { Let (piniDecl $3 $4) $6 } @@ -155,7 +163,7 @@ Expr: Form { $1 } | hn Pattern '=>' Expr { Hnd (Handler $2 Nothing Nothing $4)} | hn Pattern '|' Pattern '=>' Expr { Hnd (Handler $2 (Just $4) Nothing $6) } | hn Pattern when Expr '=>' Expr { Hnd (Handler $2 Nothing (Just $4) $6)} - | hn Pattern '|' Pattern when Expr '=>' Expr { Hnd (Handler $2 (Just $4) (Just $6) $8)} + | hn Pattern '|' Pattern when Expr '=>' Expr { Hnd (Handler $2 (Just $4) (Just $6) $8)} | case Expr of Match { Case $2 $4 (pos $1) } | Expr ';' Expr { mkSeq $1 $3 } | Expr '-' Expr { Bin Minus $1 $3 } @@ -163,8 +171,8 @@ Expr: Form { $1 } | Expr '>=' Expr { Bin Ge $1 $3 } | Expr '*' Expr { Bin Mult $1 $3 } | Expr '/' Expr { Bin Div $1 $3 } - | Expr div Expr { Bin IntDiv $1 $3} - | Expr mod Expr { Bin Mod $1 $3} + | Expr div Expr { Bin IntDiv $1 $3} + | Expr mod Expr { Bin Mod $1 $3} | Expr '^' Expr { Bin Concat $1 $3 } | Expr '=' Expr { Bin Eq $1 $3 } | Expr '<=' Expr { Bin Le $1 $3 } @@ -184,16 +192,18 @@ Expr: Form { $1 } | Expr '::' Expr { ListCons $1 $3 } | Expr 'raisedTo' Expr { Bin RaisedTo $1 $3 } | 'isTuple' Expr { Un IsTuple $2 } - | 'isList' Expr { Un IsList $2 } - | 'isRecord' Expr { Un IsRecord $2 } + | 'isList' Expr { Un IsList $2 } + | 'isRecord' Expr { Un IsRecord $2 } -Match : Pattern '=>' Expr { [($1,$3)] } - | Pattern '=>' Expr '|' Match { ($1,$3):$5 } +Match : Pattern '=>' Expr { [($1,$3)] } + | Pattern '=>' Expr '|' Match { ($1,$3):$5 } + | SyntacticVariantPattern '=>' Expr { [($1,$3)] } + | SyntacticVariantPattern '=>' Expr '|' Match { ($1,$3):$5 } Form :: { Term } -Form : '-' Form { Un UnMinus $2 } +Form : '-' Form { Un UnMinus $2 } | Fact { fromFact $1 } @@ -218,9 +228,9 @@ IntLabelExp : { Right LabelTrue } | LabelExp { Left $1 } DCLabelExp: - ConfLabelExp ';' IntLabelExp { DCLabelExp ($1, $3) } + ConfLabelExp ';' IntLabelExp { DCLabelExp ($1, $3) } -Lit: NUM { LInt (numTok $1) (pos $1) } +Lit: NUM { LInt (numTok $1) (pos $1) } | STRING { LString (strTok $1) } | true { LBool True } | false { LBool False } @@ -233,7 +243,7 @@ Atom : '(' Expr ')' { $2 } | Lit { Lit $1 } | VAR { Var (varTok $1) } | '(' ')' { Lit LUnit } - | '(' CSExpr Expr ')' { Tuple (reverse ($3:$2)) } + | '(' CSExpr Expr ')' { Tuple (reverse ($3:$2)) False } | '{' '}' { Record [] } | RecordExpr { $1 } | ListExpr { $1 } @@ -265,6 +275,8 @@ ListExpr : '[' ']' { List [] } CSExpr : Expr ',' { [$1] } | CSExpr Expr ',' { ($2:$1) } +SyntacticVariantPattern : VAR Pattern { SyntacticVariantPattern (varTok $1) $2 } + | VAR '(' SyntacticVariantPattern ')' { SyntacticVariantPattern (varTok $1) $3 } Pattern : VAR { VarPattern (varTok $1) } | '(' Pattern ')' { $2 } @@ -274,8 +286,7 @@ Pattern : VAR { VarPattern (varTok $1) } | Lit { ValPattern $1 } | '(' CSPattern Pattern ')' { TuplePattern (reverse ($3:$2)) } | FieldPattern { $1 } - | ListPattern { $1} - + | ListPattern { $1 } FieldPattern : '{' '}' { RecordPattern [] ExactMatch } @@ -305,7 +316,7 @@ CSPattern : Pattern ',' { [$1] } | CSPattern Pattern ',' { ($2:$1) } -Dec : val Pattern '=' Expr { ValDecl $2 $4 (pos $1 )} +Dec : val Pattern '=' Expr { ValDecl $2 $4 (pos $1 )} | FunDecs { FunDecs $1 } Decs : Dec { [$1] } @@ -334,8 +345,10 @@ OtherFunOption : '|' VAR FunArgs '=' Expr { Lambda $3 $5} FunDecl : fun VAR FunOptions { FunDecl (varTok $2) $3 (pos $2) } AndFunDecl : and VAR FunOptions { FunDecl (varTok $2) $3 (pos $2) } -FunArgs : Pattern { [$1] } - | Pattern FunArgs { $1 : $2} +FunArgs : Pattern { [$1] } + | Pattern FunArgs { $1 : $2} + | '(' SyntacticVariantPattern ')' { [$2] } + | '(' SyntacticVariantPattern ')' FunArgs { $2 : $4 } { diff --git a/compiler/src/Raw.hs b/compiler/src/Raw.hs index a9a17046..03d52168 100644 --- a/compiler/src/Raw.hs +++ b/compiler/src/Raw.hs @@ -103,7 +103,7 @@ data RawExpr | Un Basics.UnaryOp RawVar | ProjectLVal VarAccess LValField | ProjectState MonComponent - | Tuple [VarAccess] + | Tuple [VarAccess] Basics.SynVariantTag | Record Fields | WithRecord RawVar Fields | ProjField RawVar Basics.FieldName @@ -200,7 +200,7 @@ data FunDef = FunDef -- An IR program is just a collection of atoms declarations -- and function definitions -data RawProgram = RawProgram C.Atoms [FunDef] +data RawProgram = RawProgram [FunDef] ----------------------------------------------------------- @@ -208,7 +208,6 @@ data RawProgram = RawProgram C.Atoms [FunDef] ----------------------------------------------------------- data RawUnit = FunRawUnit FunDef - | AtomRawUnit C.Atoms | ProgramRawUnit RawProgram @@ -263,7 +262,7 @@ instructionType i = case i of -- PRETTY PRINTING ----------------------------------------------------------- -ppProg (RawProgram atoms funs) = +ppProg (RawProgram funs) = vcat $ (map ppFunDef funs) instance Show RawProgram where @@ -282,7 +281,7 @@ ppRawExpr (Bin binop _ va1 va2) = -- TODO: 2025-07-31; also print the fast flag ppId va1 <+> text (show binop) <+> ppId va2 ppRawExpr (Un op v) = text (show op) <> PP.parens (ppId v) -ppRawExpr (Tuple vars) = +ppRawExpr (Tuple vars _) = PP.parens $ PP.hsep $ PP.punctuate (text ",") (map ppId vars) ppRawExpr (List vars) = PP.brackets $ PP.hsep $ PP.punctuate (text ",") (map ppId vars) diff --git a/compiler/src/Raw2Stack.hs b/compiler/src/Raw2Stack.hs index caf87c3b..12a277a6 100644 --- a/compiler/src/Raw2Stack.hs +++ b/compiler/src/Raw2Stack.hs @@ -10,7 +10,7 @@ where import IR (SerializationUnit(..), HFN(..) , ppId, ppFunCall, ppArgs, Fields (..), Ident , serializeFunDef - , serializeAtoms ) + ) import qualified IR import qualified Raw import qualified Stack @@ -46,6 +46,7 @@ import IR ( Identifier(..) ) import RawDefUse +import qualified GHC.Stack.Types as GHC.Stack data TEnv = TEnv { defsUses :: DefUse, offsets :: OffsetMap, localCallDepth :: Int, __consts :: Raw.ConstMap } type BlockNumber = Int @@ -55,7 +56,6 @@ type Tr = RWS TEnv () BlockNumber getBlockNumber :: Tr BlockNumber getBlockNumber = get - setBlockNumber :: BlockNumber -> Tr () setBlockNumber = put @@ -236,8 +236,8 @@ trFun fdef@(Raw.FunDef hfn consts bb ir) = rawProg2Stack :: Raw.RawProgram -> Stack.StackProgram -rawProg2Stack (Raw.RawProgram atms fdefs) = - Stack.StackProgram atms (map trFun fdefs) +rawProg2Stack (Raw.RawProgram fdefs) = + Stack.StackProgram (map trFun fdefs) rawFun2Stack = trFun @@ -245,5 +245,4 @@ rawFun2Stack = trFun raw2Stack :: Raw.RawUnit -> Stack.StackUnit raw2Stack r = case r of Raw.FunRawUnit f -> Stack.FunStackUnit (trFun f) - Raw.AtomRawUnit c -> Stack.AtomStackUnit c - Raw.ProgramRawUnit p -> Stack.ProgramStackUnit (rawProg2Stack p) \ No newline at end of file + Raw.ProgramRawUnit p -> Stack.ProgramStackUnit (rawProg2Stack p) diff --git a/compiler/src/RawDefUse.hs b/compiler/src/RawDefUse.hs index c6b7314f..ece9c329 100644 --- a/compiler/src/RawDefUse.hs +++ b/compiler/src/RawDefUse.hs @@ -16,7 +16,7 @@ import Raw import IR (SerializationUnit(..), HFN(..) , ppId, ppFunCall, ppArgs, Fields (..), Ident , serializeFunDef - , serializeAtoms ) + ) import qualified IR import qualified Stack import qualified Data.Maybe as Maybe @@ -196,7 +196,7 @@ instance Usable RawExpr b where Raw.Un _ x -> use x Raw.ProjectLVal x _ -> use x Raw.ProjectState _ -> return () - Raw.Tuple xs -> use xs + Raw.Tuple xs _ -> use xs Raw.Record fields -> use (snd (unzip fields)) Raw.WithRecord x fields -> do use x diff --git a/compiler/src/RawOpt.hs b/compiler/src/RawOpt.hs index 937dc8be..a0c0db9e 100644 --- a/compiler/src/RawOpt.hs +++ b/compiler/src/RawOpt.hs @@ -146,7 +146,7 @@ instance MarkUsed RawExpr where Un _ x -> markUsed x ProjectLVal x _ -> markUsed x ProjectState _ -> return () - Tuple xs -> markUsed xs + Tuple xs _ -> markUsed xs Record fields -> markUsed (snd (unzip fields)) WithRecord x fields -> do markUsed x @@ -189,7 +189,6 @@ typeOfLit lit = Core.LString _ -> Just RawString Core.LLabel _ -> Just RawLevel Core.LBool _ -> Just RawBoolean - Core.LAtom _ -> Nothing Core.LDCLabel _ -> Just RawDCLabel @@ -241,7 +240,7 @@ guessType = \case Basics.Tail -> Nothing Basics.LevelOf -> Just RawLevel - Tuple _ -> Just RawTuple + Tuple _ _ -> Just RawTuple List _ -> Just RawList ListCons _ _ -> Just RawList Record _ -> Just RawRecord @@ -590,16 +589,12 @@ class RawOptable a where instance RawOptable RawProgram where - rawopt (RawProgram atoms fdefs) = - RawProgram (rawopt atoms) (map rawopt fdefs) + rawopt (RawProgram fdefs) = + RawProgram (map rawopt fdefs) instance RawOptable FunDef where rawopt = funopt -instance RawOptable Core.Atoms where - rawopt = id - instance RawOptable RawUnit where rawopt (FunRawUnit f) = FunRawUnit (rawopt f) - rawopt (AtomRawUnit c) = AtomRawUnit (rawopt c) rawopt (ProgramRawUnit p) = ProgramRawUnit (rawopt p) diff --git a/compiler/src/RetCPS.hs b/compiler/src/RetCPS.hs index 15cec1e4..8d25d7bf 100644 --- a/compiler/src/RetCPS.hs +++ b/compiler/src/RetCPS.hs @@ -60,7 +60,7 @@ data SimpleTerm = Bin BinOp VarName VarName | Un UnaryOp VarName | ValSimpleTerm SVal - | Tuple [VarName] + | Tuple [VarName] Basics.SynVariantTag | Record Fields | WithRecord VarName Fields | ProjField VarName Basics.FieldName @@ -86,7 +86,7 @@ data KTerm deriving (Eq, Ord) -data Prog = Prog C.Atoms KTerm +data Prog = Prog KTerm deriving (Eq, Show) -------------------------------------------------- @@ -103,13 +103,7 @@ instance ShowIndent Prog where -- ppProg :: Prog -> PP.Doc -ppProg (Prog (C.Atoms atoms) kterm) = - let ppAtoms = - if null atoms - then PP.empty - else (text "datatype Atoms = ") <+> - (hsep $ PP.punctuate (text " |") (map text atoms)) - in ppAtoms $$ ppKTerm 0 kterm +ppProg (Prog kterm) = ppKTerm 0 kterm ppKTerm :: Precedence -> KTerm -> PP.Doc @@ -117,9 +111,6 @@ ppKTerm parentPrec t = let thisTermPrec = 1000 in PP.maybeParens (thisTermPrec < parentPrec ) $ ppKTerm' t - -- uncomment to pretty print explicitly; 2017-10-14: AA - -- in PP.maybeParens (thisTermPrec < 10000) $ ppTerm' Core.LAtom _ -> Nothingt - -- ppLit :: C.Lit -> PP.Doc -- ppLit = C.ppLit -- ppLit (C.LInt i pi) = PP.integer i @@ -141,7 +132,7 @@ ppSimpleTerm (ValSimpleTerm (Lit lit)) = ppLit lit ppSimpleTerm (ValSimpleTerm (KAbs klam)) = ppKLambda klam -ppSimpleTerm (Tuple vars) = +ppSimpleTerm (Tuple vars _) = PP.parens $ PP.hsep $ PP.punctuate (text ",") (map textv vars) ppSimpleTerm (List vars) = PP.brackets $ PP.hsep $ PP.punctuate (text ",") (map textv vars) @@ -149,7 +140,7 @@ ppSimpleTerm (ListCons v1 v2) = PP.parens $ textv v1 PP.<> text "::" PP.<> textv v2 ppSimpleTerm (Base b) = text b PP.<> text "$base" ppSimpleTerm (Lib (Basics.LibName lib) v) = text lib <+> text "." <+> text v -ppSimpleTerm (Record fields) = PP.braces $ qqFields fields +ppSimpleTerm (Record fields) = PP.braces $ qqFields fields ppSimpleTerm (WithRecord x fields) = PP.braces $ PP.hsep [textv x, text "with", qqFields fields] @@ -264,4 +255,4 @@ termPrec (LetFun _ _) = 0 --termPrec (Case _ _) = 0 termPrec (LetRet _ _) = 0 termPrec (AssertElseError _ _ _ _) = 0 -termPrec (Error _ _) = 0 \ No newline at end of file +termPrec (Error _ _) = 0 diff --git a/compiler/src/RetDFCPS.hs b/compiler/src/RetDFCPS.hs index b7b6e64f..081d3b0b 100644 --- a/compiler/src/RetDFCPS.hs +++ b/compiler/src/RetDFCPS.hs @@ -32,8 +32,8 @@ transFunDecl (Core.FunDecl fname (Core.Nullary e)) = do return $ CPS.Fun (VN fname) (CPS.Nullary e') transProg :: Core.Prog -> CPS.Prog -transProg (Core.Prog imports atoms t) = - Prog atoms $ evalState (trans t (\z -> return $ Halt z)) 1 +transProg (Core.Prog imports t) = + Prog $ evalState (trans t (\z -> return $ Halt z)) 1 transFields k fields context = @@ -124,13 +124,13 @@ transExplicit (Core.AssertElseError e0 e1 e2 p) = do return $ AssertElseError v0 e1' v2 p)) -transExplicit (Core.Tuple ts) = +transExplicit (Core.Tuple ts tag) = transTuple ts [] where transTuple :: [Core.Term] -> [CPS.VarName] -> S KTerm transTuple [] acc = do v <- freshV - return $ LetSimple v (Tuple (reverse acc)) (KontReturn v) + return $ LetSimple v (Tuple (reverse acc) tag) (KontReturn v) transTuple (t:ts) acc = trans t (\v -> transTuple ts (v:acc) ) @@ -258,13 +258,13 @@ trans (Core.AssertElseError e0 e1 e2 p) context = do -trans (Core.Tuple ts) context = +trans (Core.Tuple ts tag) context = transTuple ts [] context where transTuple [] acc context = do v <- freshV e' <- context v - return $ LetSimple v (Tuple (reverse acc)) e' + return $ LetSimple v (Tuple (reverse acc) tag) e' transTuple (t:ts) acc context = trans t (\v -> transTuple ts (v:acc) context) diff --git a/compiler/src/RetFreeVars.hs b/compiler/src/RetFreeVars.hs index ff24c221..ba239668 100644 --- a/compiler/src/RetFreeVars.hs +++ b/compiler/src/RetFreeVars.hs @@ -38,7 +38,6 @@ instance FreeNames KLambda where instance FreeNames SVal where freeVars (KAbs klam) = freeVars klam - freeVars (Lit (C.LAtom nm)) = FreeVars (Set.singleton $ VN nm) freeVars _ = emptyFreeVars instance FreeNames ContDef where @@ -51,7 +50,7 @@ instance FreeNames SimpleTerm where freeVars (Bin _ v1 v2) = FreeVars (Set.fromList [v1, v2]) freeVars (Un _ v) = FreeVars (Set.singleton v) freeVars (ValSimpleTerm sval) = freeVars sval - freeVars (Tuple vs) = FreeVars (Set.fromList vs) + freeVars (Tuple vs _) = FreeVars (Set.fromList vs) freeVars (List vs) = FreeVars (Set.fromList vs) freeVars (ListCons v1 v2) = FreeVars (Set.fromList [v1, v2]) freeVars (Base _ ) = FreeVars $ Set.empty diff --git a/compiler/src/RetRewrite.hs b/compiler/src/RetRewrite.hs index cb18eb73..0f6161bc 100644 --- a/compiler/src/RetRewrite.hs +++ b/compiler/src/RetRewrite.hs @@ -65,8 +65,8 @@ instance Substitutable SimpleTerm where case simpleTerm of Bin op v1 v2 -> Bin op (fwd v1) (fwd v2) Un op v -> Un op (fwd v) - Tuple vs -> Tuple (map fwd vs) - Record fields -> Record $ fwdFields fields + Tuple vs tag -> Tuple (map fwd vs) tag + Record fields -> Record (fwdFields fields) WithRecord x fields -> WithRecord (fwd x) $ fwdFields fields ProjField x f -> ProjField (fwd x) f ProjIdx x idx -> ProjIdx (fwd x) idx @@ -376,4 +376,4 @@ ktWalkFix kt = else ktWalkFix kt' rewrite :: Prog -> Prog -rewrite (Prog atoms kterm) = Prog atoms (ktWalkFix kterm) +rewrite (Prog kterm) = Prog (ktWalkFix kterm) diff --git a/compiler/src/Stack.hs b/compiler/src/Stack.hs index 6427a452..2da207d6 100644 --- a/compiler/src/Stack.hs +++ b/compiler/src/Stack.hs @@ -85,18 +85,17 @@ data FunDef = FunDef -- An IR program is just a collection of atoms declarations -- and function definitions -data StackProgram = StackProgram C.Atoms [FunDef] +data StackProgram = StackProgram [FunDef] data StackUnit = FunStackUnit FunDef - | AtomStackUnit C.Atoms | ProgramStackUnit StackProgram ----------------------------------------------------------- -- PRETTY PRINTING ----------------------------------------------------------- -ppProg (StackProgram atoms funs) = +ppProg (StackProgram funs) = vcat $ (map ppFunDef funs) instance Show StackProgram where diff --git a/compiler/src/Stack2JS.hs b/compiler/src/Stack2JS.hs index 5717b99f..e3cce5a2 100644 --- a/compiler/src/Stack2JS.hs +++ b/compiler/src/Stack2JS.hs @@ -19,7 +19,7 @@ module Stack2JS where import IR (SerializationUnit(..), HFN(..) , ppFunCall, ppArgs, Fields (..), Ident , serializeFunDef - , serializeAtoms ) + ) import qualified Data.ByteString.Lazy.Char8 as BL import qualified IR import qualified Raw @@ -64,7 +64,6 @@ data LibAccess = LibAccess Basics.LibName Basics.VarName data JSOutput = JSOutput { libs :: [LibAccess] , fname:: Maybe String , code :: String - , atoms :: [Basics.AtomName] } deriving (Show, Generic) instance Aeson.ToJSON Basics.LibName @@ -104,7 +103,7 @@ data TheState = TheState { freshCounter :: Integer type RetKontText = PP.Doc -type W = RWS Bool ([LibAccess], [Basics.AtomName], [RetKontText]) TheState +type W = RWS Bool ([LibAccess], [RetKontText]) TheState initState = TheState { freshCounter = 0 @@ -134,7 +133,7 @@ instance Identifier HFN where instance Identifier Basics.LibName where ppId (Basics.LibName s) = text s -instance Identifier Basics.AtomName where +instance Identifier Basics.SyntacticVariantName where ppId = text instance Identifier RawVar where @@ -153,7 +152,7 @@ class ToJS a where irProg2JSString :: CompileMode -> Bool -> StackProgram -> String irProg2JSString compileMode debugOut ir = - let (fns, _, (_,_,konts)) = runRWS (toJS ir) debugOut initState + let (fns, _, (_,konts)) = runRWS (toJS ir) debugOut initState inner = vcat (fns:konts) outer = vcat $ stdlib @@ -173,7 +172,7 @@ irProg2JSString compileMode debugOut ir = stack2JSString :: StackUnit -> String stack2JSString x = - let (inner, _, (libs, atoms, konts)) = runRWS (toJS x) False initState + let (inner, _, (libs, konts)) = runRWS (toJS x) False initState in PP.render (addLibs libs $$ (vcat (inner:konts))) @@ -181,18 +180,15 @@ stack2JSString x = stack2JSON :: StackUnit -> ByteString stack2JSON (ProgramStackUnit _) = error "needs to be ported" stack2JSON x = - let (inner, _, (libs, atoms, konts)) = runRWS (toJS x) False initState + let (inner, _, (libs, konts)) = runRWS (toJS x) False initState in Aeson.encode $ JSOutput { libs = libs , fname = case x of FunStackUnit (FunDef (HFN n)_ _ _ _) -> Just n - _ -> Nothing - , atoms = atoms , code = PP.render (addLibs libs $$ (vcat (inner:konts))) } instance ToJS StackUnit where toJS (FunStackUnit fdecl) = toJS fdecl - toJS (AtomStackUnit ca) = toJS ca toJS (ProgramStackUnit p) = error "not implemented" instance ToJS IR.VarAccess where @@ -219,28 +215,14 @@ irProg2JsWrapped prog = do instance ToJS StackProgram where - toJS (StackProgram atoms funs) = do - jjA <- toJS atoms - (jjF, (libsF, atoms', _)) <- listen $ mapM toJS funs + toJS (StackProgram funs) = do + (jjF, (libsF, _)) <- listen $ mapM toJS funs return $ vcat $ [ jsLoadLibs , addLibs libsF - , jjA ] ++ jjF - - - -instance ToJS C.Atoms where - toJS catoms@(C.Atoms atoms) = return $ - vcat [ vcat $ (map (\a -> hsep ["const" - , text a - , "= new rt.Atom" - , (PP.parens ( (PP.doubleQuotes.text) a))]) atoms) - , text "this.serializedatoms =" <+> (pickle.serializeAtoms) catoms] - - jsonValueToString :: Value -> String jsonValueToString val = BL.unpack (Aeson.encode val) @@ -488,7 +470,7 @@ tr2js (Call bb bb2) = do ] - tell ([], [], [jsKont] ) + tell ([], [jsKont] ) return $ vcat [ "_SP_OLD = _SP; ", -- 2021-04-23; hack ! ;AA "_SP = _SP + " <+> text (show (_frameSize + 5)) <+> ";", @@ -589,12 +571,16 @@ instance ToJS RawExpr where then hsep [ ppId va1, text', ppId va2 ] else jsFunCall text' [ppId va1, ppId va2] Un op v -> return $ text (unaryOpToJS op) <> PP.parens (ppId v) - Tuple vars -> return $ - text "rt.mkTuple" <> PP.parens (PP.brackets $ PP.hsep $ PP.punctuate (text ",") (map ppVarName vars)) + Tuple vars tag -> return $ + text "rt.mkTuple" <> PP.parens ((PP.brackets $ PP.hsep $ PP.punctuate (text ",") (map ppVarName vars)) <> text "," <> tagToJS tag) + where tagToJS True = text "true" + tagToJS False = text "false" Record fields -> do jsFields <- fieldsToJS fields return $ - PP.parens $ text "rt.mkRecord" <> PP.parens (PP.brackets $ PP.hsep $ jsFields ) + PP.parens $ text "rt.mkRecord" <> PP.parens (PP.hsep [PP.brackets $ PP.hsep $ jsFields]) + where tagToJS True = text "true" + tagToJS False = text "false" WithRecord r fields -> do jsFields <- fieldsToJS fields return $ @@ -611,13 +597,9 @@ instance ToJS RawExpr where Const C.LUnit -> return $ text "rt.__unitbase" Const (C.LLabel s) -> return $ text "rt.mkV1Label" <> (PP.parens . PP.doubleQuotes) (text s) - Const lit -> do - case lit of - C.LAtom atom -> tell ([], [atom], []) - _ -> return () - return $ ppLit lit + Const lit -> return $ ppLit lit Lib lib'@(Basics.LibName libname) varname -> do - tell ([LibAccess lib' varname], [], []) + tell ([LibAccess lib' varname], []) return $ text "rt.loadLib" <> PP.parens ((PP.doubleQuotes.text) libname <> text ", " <> (PP.doubleQuotes.text) varname <> text ", this") ConstructLVal r1 r2 r3 -> return $ diff --git a/compiler/src/SynVarFolding.hs b/compiler/src/SynVarFolding.hs new file mode 100644 index 00000000..53ff58ef --- /dev/null +++ b/compiler/src/SynVarFolding.hs @@ -0,0 +1,95 @@ +module SynVarFolding (visitProg) where + +import Basics +import Control.Monad +import Data.List (any, find) +import Direct + +-- | 'visitProg' takes a 'Prog' and converts syntactic variants to a tuple representation. +visitProg :: Prog -> Prog +visitProg (Prog imports (SyntacticVariants datatypes) tm) = + let tcs = concat $ map snd datatypes + in Prog imports (SyntacticVariants datatypes) (visitTerm tcs tm) + +visitTerm :: [SyntacticVariantConstructor] -> Term -> Term +visitTerm svs (Lit lit) = Lit lit +visitTerm svs (Var nm) = + case find ((==) nm . fst) svs of + Nothing -> Var nm + Just (_tag, []) -> Tuple [Lit (LString nm)] True -- Convert atom into a tuple + Just (_tag, _) -> + let var = "v" + in Abs (Lambda [VarPattern var] (Tuple [ Lit (LString nm) + , Var var + ] True)) +visitTerm svs (Abs lam) = + Abs (visitLambda svs lam) +visitTerm svs (Hnd (Handler pat maybePat maybeTerm term)) = + Hnd (Handler (visitPattern svs pat) + (liftM (visitPattern svs) maybePat) + (liftM (visitTerm svs) maybeTerm) + (visitTerm svs term)) +visitTerm svs (App t1 ts) = + App (visitTerm svs t1) (map (visitTerm svs) ts) +visitTerm svs (Let decls term) = + Let (map visitDecl decls) (visitTerm svs term) + where + visitDecl (ValDecl pat t pos) = ValDecl (visitPattern svs pat) (visitTerm svs t) pos + visitDecl (FunDecs decs) = + FunDecs (map (\(FunDecl nm lams pos) -> (FunDecl nm (map (visitLambda svs) lams) pos)) decs) +visitTerm svs (Case t declTermList p) = + Case (visitTerm svs t) + (map (\(pat, term) -> ((visitPattern svs pat), (visitTerm svs term))) declTermList) + p +visitTerm svs (If t1 t2 t3) = + If (visitTerm svs t1) (visitTerm svs t2) (visitTerm svs t3) +visitTerm svs (Tuple terms tag) = + Tuple (map (visitTerm svs) terms) tag +visitTerm svs (Record fields) = Record (visitFields svs fields) +visitTerm svs (WithRecord e fields) = + WithRecord (visitTerm svs e) (visitFields svs fields) +visitTerm svs (ProjField t f) = + ProjField (visitTerm svs t) f +visitTerm svs (ProjIdx t idx) = + ProjIdx (visitTerm svs t) idx +visitTerm svs (List terms) = + List (map (visitTerm svs) terms) +visitTerm svs (ListCons t1 t2) = + ListCons (visitTerm svs t1) (visitTerm svs t2) +visitTerm svs (Bin op t1 t2) = + Bin op (visitTerm svs t1) (visitTerm svs t2) +visitTerm svs (Un op t) = + Un op (visitTerm svs t) +visitTerm svs (Seq ts) = + Seq $ map (visitTerm svs) ts +visitTerm svs (Error t) = + Error (visitTerm svs t) + +visitFields :: [SyntacticVariantConstructor] + -> [(FieldName, Maybe Term)] + -> [(FieldName, Maybe Term)] +visitFields svs fs = map visitField fs + where visitField (f, Nothing) = (f, Nothing) + visitField (f, Just t) = (f, Just (visitTerm svs t)) + +visitPattern :: [SyntacticVariantConstructor] -> DeclPattern -> DeclPattern +visitPattern svs pat@(VarPattern nm) = + if any ((==) (nm, [])) svs + then TuplePattern [ValPattern (LString nm)] -- Convert atom match into a tuple match + else pat +visitPattern _ pat@(ValPattern _) = pat +visitPattern svs (AtPattern p l) = AtPattern (visitPattern svs p) l +visitPattern _ pat@Wildcard = pat +visitPattern svs (TuplePattern pats) = TuplePattern (map (visitPattern svs) pats) +visitPattern svs (ConsPattern p1 p2) = ConsPattern (visitPattern svs p1) (visitPattern svs p2) +visitPattern svs (ListPattern pats) = ListPattern (map (visitPattern svs) pats) +visitPattern svs (RecordPattern fields mode) = RecordPattern (map visitField fields) mode + where visitField pat@(_, Nothing) = pat + visitField (f, Just p) = (f, Just (visitPattern svs p)) +visitPattern svs (SyntacticVariantPattern nm pat) = + TuplePattern [ ValPattern (LString nm), visitPattern svs pat ] + +visitLambda :: [SyntacticVariantConstructor] -> Lambda -> Lambda +visitLambda svs (Lambda pats term) = + (Lambda (map (visitPattern svs) pats) (visitTerm svs term)) + diff --git a/compiler/test/ir2raw-test/testcases/Expr.hs b/compiler/test/ir2raw-test/testcases/Expr.hs index 1cc519ae..c15738f5 100644 --- a/compiler/test/ir2raw-test/testcases/Expr.hs +++ b/compiler/test/ir2raw-test/testcases/Expr.hs @@ -14,7 +14,7 @@ import Basics mkP :: IRExpr -> IRProgram -mkP e = IRProgram (Core.Atoms []) [FunDef (HFN "main") (VN "arg") [] body] +mkP e = IRProgram [FunDef (HFN "main") (VN "arg") [] body] where body = BB [Assign (VN "r") e] (LibExport (mkV "r")) -- need to use assigned variable so that it is not optimized away tcs :: [(String, IRProgram)] @@ -24,9 +24,9 @@ tcs = map (second mkP) $ [ ("Const", Const (Core.LString "testlit")) , ("Base (authorityarg)", Base "$$authorityarg") , ("Base (general)", Base "somevar") - , ("Tuple0", Tuple []) - , ("Tuple1", Tuple [mkV "v"]) - , ("Tuple2", Tuple [mkV "v1", mkV "v2"]) + , ("Tuple0", Tuple [] False) + , ("Tuple1", Tuple [mkV "v"] False) + , ("Tuple2", Tuple [mkV "v1", mkV "v2"] False) , ("List0", List []) , ("List1", List [mkV "v"]) , ("List2", List [mkV "v1", mkV "v2"]) diff --git a/compiler/test/ir2raw-test/testcases/Inst.hs b/compiler/test/ir2raw-test/testcases/Inst.hs index 9336d1a1..952e255e 100644 --- a/compiler/test/ir2raw-test/testcases/Inst.hs +++ b/compiler/test/ir2raw-test/testcases/Inst.hs @@ -10,7 +10,7 @@ import qualified Basics mkP :: IRInst -> IRProgram -mkP inst = IRProgram (Core.Atoms []) [FunDef (HFN "main") (VN "arg") [] body] +mkP inst = IRProgram [FunDef (HFN "main") (VN "arg") [] body] where body = BB [inst] (LibExport (mkV "r")) tcs :: [(String, IRProgram)] diff --git a/compiler/test/ir2raw-test/testcases/TR.hs b/compiler/test/ir2raw-test/testcases/TR.hs index 4800b478..7dddff75 100644 --- a/compiler/test/ir2raw-test/testcases/TR.hs +++ b/compiler/test/ir2raw-test/testcases/TR.hs @@ -9,7 +9,7 @@ import TroupePositionInfo mkP :: IRTerminator -> IRProgram -mkP tr = IRProgram (Core.Atoms []) [FunDef (HFN "main") (VN "arg") [] body] +mkP tr = IRProgram [FunDef (HFN "main") (VN "arg") [] body] where body = BB [] tr tcs :: [(String, IRProgram)] diff --git a/compiler/test/ir2raw-test/testcases/Tree.hs b/compiler/test/ir2raw-test/testcases/Tree.hs index d57f0a4a..a245377a 100644 --- a/compiler/test/ir2raw-test/testcases/Tree.hs +++ b/compiler/test/ir2raw-test/testcases/Tree.hs @@ -11,7 +11,7 @@ import qualified Basics mkP :: IRBBTree -> IRProgram -mkP tree = IRProgram (Core.Atoms []) [FunDef (HFN "main") (VN "arg") [] tree] +mkP tree = IRProgram [FunDef (HFN "main") (VN "arg") [] tree] tcs :: [(String, IRProgram)] tcs = map (second mkP) @@ -20,6 +20,6 @@ tcs = map (second mkP) ) , ( "TreeAssign" - , BB [Assign (VN "r") (Tuple [])] (Ret (mkV "r")) + , BB [Assign (VN "r") (Tuple [] False)] (Ret (mkV "r")) ) ] diff --git a/docs/description/adt-translation-potential-issues.md b/docs/description/adt-translation-potential-issues.md new file mode 100644 index 00000000..1d877f65 --- /dev/null +++ b/docs/description/adt-translation-potential-issues.md @@ -0,0 +1,337 @@ +# ADT Translation Error Message Quality Issues + +*This is a machine-generated document analyzing PR #53's ADT implementation.* + +## Overview + +PR #53 introduces Algebraic Data Types (ADTs) to Troupe as syntactic sugar over tagged records. The implementation successfully provides ergonomic ADT syntax, though error messages could be more informative since the transformation to records occurs early in the compilation pipeline, resulting in loss of ADT-specific information that could enhance error reporting. + +## The Current Limitation + +When ADTs are transformed to tagged records during the `AtomFolding` phase (immediately after parsing), certain semantic information is not preserved: +- Which constructors belong to which datatypes +- Constructor names and their expected arities +- The complete set of constructors for exhaustiveness checking + +The `ADTTag` boolean flag (which becomes `_isADT` in the runtime) is preserved, indicating that a record originated from ADT syntax. This flag is currently used only for display formatting rather than error reporting. Subsequent compilation phases and runtime process regular records, producing generic error messages that reveal implementation details rather than ADT-level abstractions. + +## Concrete Examples + +*Note: In the examples below, "Suggested Improvement" sections represent subjective proposals for how error messages could be more informative and user-friendly. These are not objective requirements but rather ideas for potential enhancements.* + +### Example 1: Non-exhaustive Pattern Match + +#### User Code (ADT Syntax) +```sml +datatype option = NONE | SOME of a + +let val myOption = SOME 42 +in case myOption of NONE => print "was none" +end +``` + +#### Internal Transformation +```sml +(* SOME 42 becomes: *) +{tag="SOME", value=42} (* with _isADT=true *) + +(* Pattern match becomes: *) +case {tag="SOME", value=42} of + {tag="NONE"} => print "was none" +``` + +#### Actual Error Message +``` +pattern match failed +``` + +#### Suggested Improvement +``` +pattern match failed: SOME 42 did not match any case +``` +or potentially even better: +``` +Non-exhaustive pattern match in case expression: + Missing constructor: SOME + Value: SOME 42 +``` +*Note: These are subjective suggestions for how error messages could be more helpful, not requirements or expectations.* + +### Example 2: Missing Pattern Cases + +#### User Code +```sml +datatype result = OK of a | ERROR of string | PENDING + +fun processResult (OK v) = v + | processResult (ERROR msg) = raise Fail msg +(* Missing PENDING case *) + +let val r = PENDING +in processResult r +end +``` + +#### Internal Transformation +The function `processResult` lacks a case for the `PENDING` constructor, which becomes a record containing only `{tag="PENDING"}`. + +#### Actual Error Message +``` +pattern match failure in function processResult +``` + +#### Suggested Improvement +``` +pattern match failure in function processResult + Unhandled constructor: PENDING + Value: PENDING +``` + +### Example 3: Type Mismatch in Pattern + +#### User Code +```sml +datatype result = OK of a | ERROR of string + +let val r = ERROR "failed" +in case r of OK v => v + 1 (* ERROR constructor, but matching OK *) +end +``` + +#### Internal Transformation +```sml +case {tag="ERROR", value="failed"} of + {tag="OK", value=v} => v + 1 +``` + +#### Actual Error Message +``` +pattern match failed +``` + +#### Suggested Improvement +``` +Pattern match failed: + Expected constructor: OK + Actual constructor: ERROR with value "failed" +``` + +### Example 4: Alternative Pattern Structure + +#### User Code +```sml +datatype expr = NUM of int | ADD of expr * expr + +(* User might expect to destructure the tuple *) +let val e = ADD (NUM 1, NUM 2) +in case e of NUM n => n + | ADD x => 0 (* Pattern binds entire tuple to x *) +end +``` + +#### Internal Transformation +The pattern `ADD x` transforms to `{tag="ADD", value=x}` where `x` matches the entire tuple `(NUM 1, NUM 2)` rather than decomposing it. + +#### Actual Behavior +The code compiles and runs with `x` bound to the tuple, potentially causing type errors later if used incorrectly. + +#### Suggested Improvement (with more ADT awareness) +``` +Warning: Constructor ADD expects a tuple pattern + Found: ADD x + Suggested: ADD (e1, e2) +``` + + +## Root Cause Analysis + +### Transformation Pipeline + +1. **Parser** (`Parser.y`) + - Parses ADT syntax into AST with `DataTypeDecl`, `DataTypePattern` nodes + - Maintains constructor information temporarily + +2. **AtomFolding** (`AtomFolding.hs`) - **WHERE INFORMATION IS LOST** + ```haskell + -- Nullary constructor becomes: + Record [("tag", Just (Lit (LString nm)))] True + + -- Non-nullary constructor becomes: + Abs (Lambda [VarPattern var] + (Record [("tag", Just (Lit (LString nm))), + ("value", Just (Var var))] True)) + ``` + After this phase, ADTs become records with `ADTTag=True`. This flag persists through compilation and becomes `_isADT` in the runtime + +3. **CaseElimination** (`CaseElimination.hs`) + - Generates generic error messages: + ```haskell + Error (Lit (LString "pattern match failed")) + Error (Lit (LString $ "pattern match failure in function " ++ f)) + ``` + - Lacks awareness that records originated from ADTs + +4. **Runtime** (`Record.mts`) + - Receives `_isADT` flag indicating ADT origin + - Uses this flag only for display formatting in `stringRep()` + - Error handling code does not leverage the `_isADT` flag for enhanced error messages + +### Why Information Is Lost + +The transformation occurs at the `AtomFolding` stage because it: +1. Simplifies implementation through syntax tree rewriting +2. Avoids threading ADT information through compilation phases +3. Reuses existing record pattern matching machinery + +Consequently: +- **Constructor metadata** is not preserved beyond AtomFolding (except the boolean ADT flag) +- **Error messages cannot reference** constructor names or datatypes (despite runtime awareness via `_isADT`) +- **Compile-time validation** of constructor usage is unavailable +- **Exhaustiveness checking** is not possible +- **The `_isADT` flag alone is insufficient** for generating detailed error messages + +### Specific Code Locations + +#### Current Error Generation Approach + +1. **CaseElimination.hs:61** +```haskell +transLambdaWithError lam (Error (Lit (LString "pattern match failed") ) NoPos) +``` + +2. **CaseElimination.hs:202** +```haskell +Error (Lit (LString "pattern match failure in let declaration")) pos +``` + +3. **CaseElimination.hs:215** +```haskell +Error (Lit (LString $ "pattern match failure in function " ++ f)) pos +``` + +These hardcoded strings become the generic error messages users see. + +## Impact on Users + +### Developer Experience Considerations + +1. **Debugging Complexity** + - Users must mentally translate record errors to ADT terms + - Error messages display internal representation rather than surface syntax + - Implementation details appear in error messages + +2. **Differences from ML-family Languages** + - Lacks compile-time checking of constructor names + - Lacks exhaustiveness warnings + - Typos in constructor names produce runtime errors + +3. **Generic Error Messages** + - Pattern match failures omit specific constructor information + - Displays tuple destructuring errors instead of ADT-specific messages + - Uses identical "pattern match failed" message for different failure modes + +4. **Learning Curve** + - Users familiar with ML-family languages may expect different error behavior + - The relationship between ADT syntax and record implementation requires explanation + +## Potential Improvements + +### Improvement 1: Enhanced Error Messages in Compiler (Minimal Change) + +Enhance error messages during compilation without modifying core transformation: + +1. **In CaseElimination.hs**, detect patterns involving ADT records: + ```haskell + -- Instead of: + Error (Lit (LString "pattern match failed")) pos + + -- Generate more informative errors when ADTTag is true: + Error (Lit (LString "pattern match failed on ADT value")) pos + ``` + +2. **In AtomFolding.hs**, preserve constructor names in error paths: + ```haskell + -- Add constructor name to error message during pattern compilation + case findConstructor nm atms of + Just (cons, _) -> + -- Include constructor name in generated error literals + Error (Lit (LString $ "pattern match failed: constructor " ++ nm)) + ``` + +3. **Thread ADT information through pattern compilation** + - Modify `compilePattern` in CaseElimination to track ADT-originated patterns + - Generate distinct error messages for ADT versus regular record patterns + +### Improvement 2: Include Value in Error Messages (Better Debugging) + +Modify error generation to include the failing value: + +1. **Change error generation in CaseElimination.hs**: + ```haskell + -- Instead of static error messages: + transLambdaWithError lam (Error (Lit (LString "pattern match failed"))) + + -- Generate code that includes the value: + transLambdaWithError lam errorWithValue + where errorWithValue = + -- Generate code to construct error message with value + App (Base "raiseMatchError") (Var scrutineeVar) + ``` + +2. **Add built-in function for enhanced error reporting**: + ```haskell + -- In IR.hs, add to built-ins: + "raiseMatchError" -- Function that formats match errors with values + ``` + +### Improvement 3: Preserve Constructor Metadata (More Complete) + +Retain constructor information further through the compilation pipeline: + +1. **Extend Record representation** in intermediate phases: + ```haskell + -- In Direct.hs or Core.hs: + data Term = ... + | Record Fields ADTTag (Maybe (DataTypeName, ConstructorName)) + ``` + +2. **Preserve metadata through transformations**: + ```haskell + -- In AtomFolding.hs: + visitTerm atms (DataTypeConstructor nm args) = + Record fields True (Just (datatypeName, nm)) + ``` + +3. **Use metadata for error messages**: + ```haskell + -- In CaseElimination.hs: + case term of + Record _ True (Just (dt, cons)) -> + Error (Lit (LString $ "Constructor " ++ cons ++ + " of type " ++ dt ++ " did not match")) + ``` + +## Recommendations + +### Short Term (Minimal Effort) +1. Improve error literals in `CaseElimination.hs` to include position information +2. Add source position to all pattern match errors +3. Document the limitation in user guides + +### Medium Term (Moderate Effort) +1. Implement Improvement 1 - preserve minimal ADT context for errors +2. Add compile-time warnings for obvious issues (undefined constructors) +3. Enhance runtime `stringRep` to show ADT values in errors + +### Long Term (If More ADT Features Are Desired) +1. Consider Improvement 2 or 3 for additional ADT capabilities +2. Potentially add exhaustiveness checking +3. Consider constructor arity validation at compile time + +## Conclusion + +The current ADT implementation achieves its goal of providing syntactic sugar with zero runtime cost, adhering to the design principle of maintaining runtime simplicity. The trade-off involves generic rather than ADT-specific error messages. The transformation in the AtomFolding phase results in ADT-specific information being unavailable for error reporting in subsequent phases. + +The design successfully delivers ADT functionality with minimal runtime modifications. Should more informative error messages become a priority, the suggested improvements offer approaches ranging from minimal adjustments to comprehensive enhancements, providing flexibility based on available resources and user requirements. + +The central observation is that enhanced error messages would necessitate preserving additional semantic information about ADT origins throughout the compilation pipeline, introducing complexity to the current straightforward transformation approach. \ No newline at end of file diff --git a/rt/src/Asserts.mts b/rt/src/Asserts.mts index 88ed0081..d1fc5763 100644 --- a/rt/src/Asserts.mts +++ b/rt/src/Asserts.mts @@ -34,12 +34,6 @@ function __stringRep (v) { } let err = x => _thread().threadError(x) -export function assertIsAtom (x: any) { - _thread().raiseBlockingThreadLev(x.tlev) - if (x.val._troupeType != TroupeType.ATOM ) { - err ("value " + __stringRep(x) + " is not an atom") - } -} export function rawAssertIsNumber (x) { if (typeof x != 'number') { diff --git a/rt/src/Atom.mts b/rt/src/Atom.mts deleted file mode 100644 index 45623b9e..00000000 --- a/rt/src/Atom.mts +++ /dev/null @@ -1,22 +0,0 @@ -import runId from "./runId.mjs" -import { TroupeType } from "./TroupeTypes.mjs" -import { TroupeRawValue } from "./TroupeRawValue.mjs"; -import * as levels from './Level.mjs' - -let rt_uuid = runId - -export class Atom implements TroupeRawValue { - atom: string - creation_uuid: any; - _troupeType = TroupeType.ATOM - dataLevel = levels.BOT - - constructor (name:string, creation_uuid = rt_uuid) { - this.atom = name; - this.creation_uuid = creation_uuid - } - - stringRep (_omitLevels = false) { - return this.atom - } -} diff --git a/rt/src/MailboxProcessor.mts b/rt/src/MailboxProcessor.mts index 8c7bd239..46b969c0 100644 --- a/rt/src/MailboxProcessor.mts +++ b/rt/src/MailboxProcessor.mts @@ -22,7 +22,7 @@ import { Thread } from "./Thread.mjs"; function createMessage(msg, fromNodeId, pc) { - let tuple:any = mkTuple ([msg, fromNodeId]); + let tuple:any = mkTuple ([msg, fromNodeId], false); // tuple.isTuple = true; // hack! 2018-10-19: AA // tuple._troupeType = TroupeType.TUPLE // tuple.dataLevel = lub (msg.dataLevel, pc) diff --git a/rt/src/RawTuple.mts b/rt/src/RawTuple.mts index 1469b6a7..a75b612b 100644 --- a/rt/src/RawTuple.mts +++ b/rt/src/RawTuple.mts @@ -9,11 +9,23 @@ export class RawTuple extends Array implements TroupeAggregateRawValue { _troupeType = TroupeType.TUPLE; isTuple = true; stringRep = null; + _isSynVariant: boolean; - constructor(x: LVal[]) { + constructor(x: LVal[], isSynVariant: boolean) { super(...x) + this._isSynVariant = isSynVariant; this.stringRep = function (omitLevels = false, taintRef = null) { - return ("(" + listStringRep(x, omitLevels, taintRef) + ")"); + if (this._isSynVariant) { + if (this.length === 2) { + let tag = this[0].val.toString() + let val = this[1].stringRep(omitLevels, taintRef) + return "(" + tag + " " + val + ")" + } else { + return this[0].val.toString() + } + } else { + return ("(" + listStringRep(x, omitLevels, taintRef) + ")"); + } }; let dataLevels = x.map(lv => lv.dataLevel); diff --git a/rt/src/Record.mts b/rt/src/Record.mts index 5d688e1a..45dd2341 100644 --- a/rt/src/Record.mts +++ b/rt/src/Record.mts @@ -12,15 +12,14 @@ export class Record implements TroupeAggregateRawValue { __obj : Map stringRep (omitLevels?: boolean, taintRef?: any) { - // return ("{" + listStringRep(this.toArray(), omitLevels, taintRef) + "}") let s = "{" let spaceOrComma = "" for (let [k,v] of this.__obj.entries()) { - s += spaceOrComma + k + "=" + v.stringRep(omitLevels, taintRef) - spaceOrComma = ", " + s += spaceOrComma + k + "=" + v.stringRep(omitLevels, taintRef) + spaceOrComma = ", " } s += "}" - return s + return s } constructor(fields: Iterable) { diff --git a/rt/src/Scheduler.mts b/rt/src/Scheduler.mts index e580e714..568c4f0d 100644 --- a/rt/src/Scheduler.mts +++ b/rt/src/Scheduler.mts @@ -108,8 +108,8 @@ export class Scheduler implements SchedulerInterface { let thisPid = this.__currentThread.tid; let statusVal = this.__currentThread.mkVal ( status ) ; let reason = TerminationStatus.OK == status ? statusVal : - mkTuple ( [statusVal, mkVal (errstr)] ); - let message = mkVal (mkTuple ([ mkVal("DONE"), refUUID, thisPid, reason])) + mkTuple ( [statusVal, mkVal (errstr)], false ); + let message = mkVal (mkTuple ([ mkVal("DONE"), refUUID, thisPid, reason], false)) this.rtObj.sendMessageNoChecks ( toPid, message , false) // false flag means no need to return in the process } } diff --git a/rt/src/ValuesUtil.mts b/rt/src/ValuesUtil.mts index 9fc5d0fc..fce0f21e 100644 --- a/rt/src/ValuesUtil.mts +++ b/rt/src/ValuesUtil.mts @@ -13,8 +13,8 @@ export function isTupleFlagSet (x:any) { /** * Takes an array of labelled values and makes a new Troupe tuple object out of it. */ -export function mkTuple(x: LVal[]) { - return new RawTuple(x) +export function mkTuple(x: LVal[], isSynVariant: boolean) { + return new RawTuple(x, isSynVariant) } diff --git a/rt/src/builtins/UserRuntimeZero.mts b/rt/src/builtins/UserRuntimeZero.mts index 1f34839c..bc5a362e 100644 --- a/rt/src/builtins/UserRuntimeZero.mts +++ b/rt/src/builtins/UserRuntimeZero.mts @@ -6,7 +6,6 @@ import { Nil, Cons, RawList } from '../RawList.mjs' import { loadLibsAsync } from '../loadLibsAsync.mjs'; import * as levels from '../Level.mjs' import { BaseFunctionWithExplicitArg, ServiceFunction } from '../BaseFunction.mjs' -import { Atom } from '../Atom.mjs' import { __unit } from '../UnitVal.mjs' import { RuntimeInterface } from '../RuntimeInterface.mjs'; import { Record } from '../Record.mjs' @@ -82,7 +81,6 @@ export class UserRuntimeZero { mkValPos : (x:any, pos:string) => LVal = this.default_mkValPos __unit = __unit __unitbase = __unitbase - Atom = Atom constructor(runtime:RuntimeInterface) { this.runtime = runtime diff --git a/rt/src/builtins/listToTuple.mts b/rt/src/builtins/listToTuple.mts index d5ed005e..f2074b67 100644 --- a/rt/src/builtins/listToTuple.mts +++ b/rt/src/builtins/listToTuple.mts @@ -21,7 +21,7 @@ export function BuiltinListToTuple>(B } // Create the tuple from the array - let tuple = mkTuple(arr); + let tuple = mkTuple(arr, false); // Return the tuple with the combined security level return this.runtime.ret(new LVal(tuple, combinedLevel)); diff --git a/rt/src/builtins/receive.mts b/rt/src/builtins/receive.mts index 0bbbc459..6eb5e7ff 100644 --- a/rt/src/builtins/receive.mts +++ b/rt/src/builtins/receive.mts @@ -1,5 +1,5 @@ import { UserRuntimeZero, Constructor, mkBase, mkService } from './UserRuntimeZero.mjs' -import { assertNormalState, assertIsNTuple, assertIsLevel, assertIsList, assertIsAtom, assertIsNumber, assertIsUnit, assertIsFunction } from '../Asserts.mjs' +import { assertNormalState, assertIsNTuple, assertIsLevel, assertIsList, assertIsNumber, assertIsUnit, assertIsFunction } from '../Asserts.mjs' import { flowsTo, lub, glb, BOT } from '../Level.mjs'; import { RuntimeInterface } from '../RuntimeInterface.mjs'; import { ReceiveTaintAction } from '../ReceiveTaintAction.mjs'; @@ -9,46 +9,6 @@ import { __unit } from '../UnitVal.mjs'; import SandboxStatus from '../SandboxStatus.mjs'; import { Thread } from '../Thread.mjs'; import { debug } from 'console'; - - - -/* -// this function must only be called from -// one of the checked functions -function _receiveFromMailbox ($r:RuntimeInterface, lowb, highb, handlers) { - let mclear = $r.$t.mailbox.mclear - - let is_sufficient_clearance = - flowsTo( lub (highb.val, $r.$t.pc) - , lub (lowb.val, mclear.boost_level )) - - if (!is_sufficient_clearance) { - let errorMessage = - "Not enough mailbox clearance for this receive\n" + - ` | receive lower bound: ${lowb.val.stringRep()}\n` + - ` | receive upper bound: ${highb.val.stringRep()}\n` + - ` | pc level : ${$r.$t.pc.stringRep()}\n` + - ` | mailbox clearance : ${mclear.boost_level.stringRep()}` - $r.$t.threadError (errorMessage); - } - - let is_clearance_a_leak = flowsTo( mclear.pc_at_creation, glb ($r.$t.pc, lowb.val)) - - if (!is_clearance_a_leak) { - let errorMessage = - "PC level at the time of raising the mailbox clearance is too sensitive for this receive\n" + - ` | receive lower bound: ${lowb.val.stringRep()}\n` + - ` | pc level at the time of receive: ${$r.$t.pc.stringRep()}\n` + - ` | pc level at the time of raise: ${mclear.pc_at_creation.stringRep()}` // we need better terminology for these - $r.$t.threadError (errorMessage); - } - - - return $r.__mbox.rcv(lowb.val, highb.val, handlers, mclear.boost_level) - -} -*/ - /** Receiving functionality; 2020-02-12; AA * @@ -72,9 +32,6 @@ function _receiveFromMailbox ($r:RuntimeInterface, lowb, highb, handlers) { * */ - - - export function BuiltinReceive>(Base: TBase) { return class extends Base { peek = mkBase (arg => { @@ -142,7 +99,6 @@ export function BuiltinReceive>(Base: return this.runtime.ret ( new LVal (this.runtime.$t.pc, this.runtime.$t.pc, BOT)) }) - guard = mkBase (arg => { assertIsNTuple(arg, 3) diff --git a/rt/src/builtins/sandbox.mts b/rt/src/builtins/sandbox.mts index 5c52f2d7..71fae605 100644 --- a/rt/src/builtins/sandbox.mts +++ b/rt/src/builtins/sandbox.mts @@ -57,7 +57,7 @@ function setupSandbox($r:RuntimeInterface, delay, resumeState = null) { function mk_tupleVal(x) { - return theThread.mkVal(mkTuple(x)); + return theThread.mkVal(mkTuple(x, false)); } function ok(x, l) { diff --git a/rt/src/deserialize.mts b/rt/src/deserialize.mts index 2c194875..7f766a07 100644 --- a/rt/src/deserialize.mts +++ b/rt/src/deserialize.mts @@ -6,7 +6,6 @@ import { LVal } from './Lval.mjs'; import { mkTuple, mkList } from './ValuesUtil.mjs'; import { ProcessID } from './process.mjs'; import { Authority } from './Authority.mjs'; -import { Atom } from './Atom.mjs'; import { __unitbase }from './UnitBase.mjs' import { glb, mkLevel } from './Level.mjs'; import { RuntimeInterface } from './RuntimeInterface.mjs'; @@ -92,8 +91,6 @@ function unindent() { indentcounter--; } - - function deserializationError() { console.log("DESERIALIZATION ERROR HANDLING IS NOT IMPLEMENTED") process.exit(1); @@ -121,17 +118,6 @@ function constructCurrent(compilerOutput: string) { let ns = serobj.namespaces[i] let nsFun = HEADER - let atomSet = new Set() - - // nsFun += "this.libSet = new Set () \n" - // nsFun += "this.libs = [] \n" - // nsFun += "this.addLib = function (lib, decl) " + - // " { if (!this.libSet.has (lib +'.'+decl)) { " + - // " this.libSet.add (lib +'.'+decl); " + - // " this.libs.push ({lib:lib, decl:decl})} } \n" - // nsFun += "this.loadlibs = function (cb) { rt.linkLibs (this.libs, this, cb) } \n" - - for (let j = 0; j < ns.length; j++) { if (j > 0) { nsFun += "\n\n" // looks neater this way @@ -140,30 +126,16 @@ function constructCurrent(compilerOutput: string) { // console.log (snippetJson.libs); // console.log (snippetJson.fname); nsFun += snippetJson.code; - - for (let atom of snippetJson.atoms) { - atomSet.add(atom) - } - // console.log (snippetJson.atoms) } - let argNames = Array.from(atomSet); - let argValues = argNames.map( argName => {return new Atom(argName)}) - argNames.unshift('rt') - argNames.push(nsFun) + // Observe that there is some serious level of // reflection going on in here - // Arguments to Function are - // 'rt', ATOM1, ..., ATOMk, nsFun - // - // - let NS: any = Reflect.construct (Function, argNames) - + // Arguments to Function are 'rt', nsFun + let NS: any = Reflect.construct (Function, ['rt', nsFun]) + // We now construct an instance of the newly constructed object - // that takes the runtime object + atoms as its arguments - - // console.log (NS.toString()); // debugging - argValues.unshift(__rtObj) - ctxt.namespaces[i] = Reflect.construct (NS, argValues) + // that takes the runtime object as its argument + ctxt.namespaces[i] = Reflect.construct (NS, [__rtObj]) } @@ -243,14 +215,14 @@ function constructCurrent(compilerOutput: string) { case Ty.TroupeType.RECORD: // for reords, the serialization format is [[key, value_json], ...] let a = []; - for (let i = 0; i < obj.length; i++) { - a.push ([ obj[i][0], mkValue(obj[i][1]) ]) + for (let i = 0; i < obj.fields.length; i++) { + a.push ([ obj.fields[i][0], mkValue(obj.fields[i][1]) ]) } return Record.mkRecord(a); case Ty.TroupeType.LIST: return mkList(deserializeArray(obj)) case Ty.TroupeType.TUPLE: - return mkTuple(deserializeArray(obj)) + return mkTuple(deserializeArray(obj.vals), obj.isSynVariant) case Ty.TroupeType.CLOSURE: return mkClosure(obj.ClosureID) case Ty.TroupeType.NUMBER: @@ -266,8 +238,6 @@ function constructCurrent(compilerOutput: string) { return mkLevel(obj.lev) case Ty.TroupeType.LVAL: return mkValue(obj) - case Ty.TroupeType.ATOM: - return new Atom(obj.atom, obj.creation_uuid) case Ty.TroupeType.UNIT: return __unitbase default: diff --git a/rt/src/serialize.mts b/rt/src/serialize.mts index 75c9ee77..3e8e9c35 100644 --- a/rt/src/serialize.mts +++ b/rt/src/serialize.mts @@ -72,9 +72,9 @@ export function serialize(w:LVal, pclev:Level) { switch (_tt) { case Ty.TroupeType.RECORD: - jsonObj = []; + jsonObj = { fields: [] }; for (let [k,v] of x.__obj.entries()) { - jsonObj.push ([k, walk(v)]) + jsonObj.fields.push ([k, walk(v)]) } break; case Ty.TroupeType.LIST: @@ -86,9 +86,9 @@ export function serialize(w:LVal, pclev:Level) { } break; case Ty.TroupeType.TUPLE: - jsonObj = []; + jsonObj = { vals: [], isSynVariant: x._isSynVariant }; for (let i = 0; i < x.length; i++) { - jsonObj.push(walk(x[i])); + jsonObj.vals.push(walk(x[i])); } break; case Ty.TroupeType.CLOSURE: diff --git a/tests/cmp/synvar1.golden b/tests/cmp/synvar1.golden new file mode 100644 index 00000000..1819e6c5 --- /dev/null +++ b/tests/cmp/synvar1.golden @@ -0,0 +1,2 @@ +Parse Error: +1:14 unexpected token TokenNum 22 diff --git a/tests/cmp/synvar1.trp b/tests/cmp/synvar1.trp new file mode 100644 index 00000000..b82a8dfe --- /dev/null +++ b/tests/cmp/synvar1.trp @@ -0,0 +1 @@ +case 0 of 11 22 => 0 diff --git a/tests/rt/pos/core/adt-arith.golden b/tests/rt/pos/core/adt-arith.golden new file mode 100644 index 00000000..bbb82cb6 --- /dev/null +++ b/tests/rt/pos/core/adt-arith.golden @@ -0,0 +1,2 @@ +2025-08-13T10:05:00.321Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: 16@{}%{} diff --git a/tests/rt/pos/core/adt-arith.trp b/tests/rt/pos/core/adt-arith.trp new file mode 100644 index 00000000..75363b29 --- /dev/null +++ b/tests/rt/pos/core/adt-arith.trp @@ -0,0 +1,17 @@ +datatype binop = ADD | SUB | MUL | DIV +datatype expr = LIT of int | BINOP of binop * expr * expr + +let fun eval (LIT i) = i + | eval (BINOP (oper, e1, e2)) = + let val v1 = eval e1 + val v2 = eval e2 + in case oper of ADD => v1 + v2 + | SUB => v1 - v2 + | MUL => v1 * v2 + | DIV => v1 div v2 + end +in eval (BINOP (ADD, + (BINOP (SUB, LIT 8, LIT 4)), + (BINOP (MUL, LIT 6, + (BINOP (DIV, LIT 6, LIT 3)))))) +end diff --git a/tests/rt/pos/core/adt-atom-day1.golden b/tests/rt/pos/core/adt-atom-day1.golden new file mode 100644 index 00000000..a46cb9b7 --- /dev/null +++ b/tests/rt/pos/core/adt-atom-day1.golden @@ -0,0 +1,4 @@ +2025-08-08T15:27:52.050Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +"friday" +"tuesday" +>>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/core/adt-atom-day1.trp b/tests/rt/pos/core/adt-atom-day1.trp new file mode 100644 index 00000000..34eb6263 --- /dev/null +++ b/tests/rt/pos/core/adt-atom-day1.trp @@ -0,0 +1,18 @@ +datatype Day = MONDAY + | TUESDAY + | WEDNESDAY + | THURSDAY + | FRIDAY + | SATURDAY + | SUNDAY + +let fun print_day MONDAY = print "monday" + | print_day TUESDAY = print "tuesday" + | print_day WEDNESDAY = print "wednesday" + | print_day THURSDAY = print "thursday" + | print_day FRIDAY = print "friday" + | print_day SATURDAY = print "saturday" + | print_day SUNDAY = print "sunday" +in print_day FRIDAY; + print_day TUESDAY +end diff --git a/tests/rt/pos/core/adt-atom-day2.golden b/tests/rt/pos/core/adt-atom-day2.golden new file mode 100644 index 00000000..82110025 --- /dev/null +++ b/tests/rt/pos/core/adt-atom-day2.golden @@ -0,0 +1,2 @@ +2025-08-08T15:27:54.468Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: WEDNESDAY@{}%{} diff --git a/tests/rt/pos/core/adt-atom-day2.trp b/tests/rt/pos/core/adt-atom-day2.trp new file mode 100644 index 00000000..4d015f94 --- /dev/null +++ b/tests/rt/pos/core/adt-atom-day2.trp @@ -0,0 +1,17 @@ +datatype Day = MONDAY + | TUESDAY + | WEDNESDAY + | THURSDAY + | FRIDAY + | SATURDAY + | SUNDAY + +let fun next_day MONDAY = TUESDAY + | next_day TUESDAY = WEDNESDAY + | next_day WEDNESDAY = THURSDAY + | next_day THURSDAY = FRIDAY + | next_day FRIDAY = SATURDAY + | next_day SATURDAY = SUNDAY + | next_day SUNDAY = MONDAY +in next_day TUESDAY +end diff --git a/tests/rt/pos/core/adt-atom-multiple-declarations.golden b/tests/rt/pos/core/adt-atom-multiple-declarations.golden new file mode 100644 index 00000000..0f59f148 --- /dev/null +++ b/tests/rt/pos/core/adt-atom-multiple-declarations.golden @@ -0,0 +1,4 @@ +2025-08-08T15:27:27.445Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +COLD +HOT +>>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/core/adt-atom-multiple-declarations.trp b/tests/rt/pos/core/adt-atom-multiple-declarations.trp new file mode 100644 index 00000000..43585101 --- /dev/null +++ b/tests/rt/pos/core/adt-atom-multiple-declarations.trp @@ -0,0 +1,8 @@ +datatype Temperature = HOT | COLD +datatype Food = SOUP | ICECREAM + +let fun serving_temperature SOUP = HOT + | serving_temperature ICECREAM = COLD +in print (serving_temperature ICECREAM); + print (serving_temperature SOUP) +end diff --git a/tests/rt/pos/core/adt-option1.golden b/tests/rt/pos/core/adt-option1.golden new file mode 100644 index 00000000..74c9b378 --- /dev/null +++ b/tests/rt/pos/core/adt-option1.golden @@ -0,0 +1,2 @@ +2025-08-13T09:50:43.426Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: 5@{}%{} diff --git a/tests/rt/pos/core/adt-option1.trp b/tests/rt/pos/core/adt-option1.trp new file mode 100644 index 00000000..ab01c20e --- /dev/null +++ b/tests/rt/pos/core/adt-option1.trp @@ -0,0 +1,6 @@ +datatype option = NONE | SOME of a +let fun sum_of_some_tuple (SOME (a, b)) = SOME (a + b) + | sum_of_some_tuple NONE = NONE + fun get_with_default (SOME a) _ = a + | get_with_default NONE d = d +in get_with_default (sum_of_some_tuple (SOME (2,3))) 0 end diff --git a/tests/rt/pos/core/adt-option2.golden b/tests/rt/pos/core/adt-option2.golden new file mode 100644 index 00000000..92dbfd2e --- /dev/null +++ b/tests/rt/pos/core/adt-option2.golden @@ -0,0 +1,2 @@ +2025-08-13T15:29:59.928Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: (NONE@{}%{}, (SOME 28@{}%{})@{}%{})@{}%{} diff --git a/tests/rt/pos/core/adt-option2.trp b/tests/rt/pos/core/adt-option2.trp new file mode 100644 index 00000000..9eefe9fe --- /dev/null +++ b/tests/rt/pos/core/adt-option2.trp @@ -0,0 +1,2 @@ +datatype option = NONE | SOME of a +(NONE, SOME 28)