From c15e9761a0c86b106c175c346548c2c895c8765e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Thu, 7 Aug 2025 18:08:17 +0200 Subject: [PATCH 01/30] Atoms are now converted to tagged records in AtomFolding.hs --- compiler/src/AtomFolding.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/compiler/src/AtomFolding.hs b/compiler/src/AtomFolding.hs index 1aad7ba8..31dc59c2 100644 --- a/compiler/src/AtomFolding.hs +++ b/compiler/src/AtomFolding.hs @@ -13,7 +13,7 @@ visitTerm :: [AtomName] -> Term -> Term visitTerm atms (Lit lit) = Lit lit visitTerm atms (Var nm) = if (elem nm atms) - then Lit (LAtom nm) + then Record [("tag", Just (Lit (LString nm)))] -- Convert atom into a tagged record else Var nm visitTerm atms (Abs lam) = Abs (visitLambda atms lam) @@ -66,7 +66,7 @@ visitFields atms fs = map visitField fs visitPattern :: [AtomName] -> DeclPattern -> DeclPattern visitPattern atms pat@(VarPattern nm) = if (elem nm atms) - then ValPattern (LAtom nm) + then RecordPattern [("tag", Just (ValPattern (LString nm)))] ExactMatch -- Convert atom match into a record match else pat visitPattern _ pat@(ValPattern _) = pat visitPattern atms (AtPattern p l) = AtPattern (visitPattern atms p) l @@ -81,3 +81,4 @@ visitPattern atms (RecordPattern fields mode) = RecordPattern (map visitField fi visitLambda :: [AtomName] -> Lambda -> Lambda visitLambda atms (Lambda pats term) = (Lambda (map (visitPattern atms) pats) (visitTerm atms term)) + From d2ea71ff26d09375b4f80e742d084b44dcc875d0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Fri, 8 Aug 2025 13:13:09 +0200 Subject: [PATCH 02/30] added ADTTag to records in the compiler --- compiler/src/AtomFolding.hs | 5 ++--- compiler/src/Basics.hs | 1 + compiler/src/CPSOpt.hs | 18 +++++++++--------- compiler/src/CaseElimination.hs | 6 +++--- compiler/src/ClosureConv.hs | 4 ++-- compiler/src/Core.hs | 16 +++++++++++----- compiler/src/Direct.hs | 14 ++++++++++---- compiler/src/DirectWOPats.hs | 10 ++++++++-- compiler/src/IR.hs | 4 ++-- compiler/src/IR2Raw.hs | 4 ++-- compiler/src/IROpt.hs | 8 ++++---- compiler/src/Parser.y | 4 ++-- compiler/src/Raw.hs | 4 ++-- compiler/src/RawDefUse.hs | 2 +- compiler/src/RawOpt.hs | 4 ++-- compiler/src/RetCPS.hs | 6 +++--- compiler/src/RetDFCPS.hs | 6 +++--- compiler/src/RetFreeVars.hs | 2 +- compiler/src/RetRewrite.hs | 2 +- compiler/src/Stack2JS.hs | 2 +- 20 files changed, 70 insertions(+), 52 deletions(-) diff --git a/compiler/src/AtomFolding.hs b/compiler/src/AtomFolding.hs index 31dc59c2..737ceee9 100644 --- a/compiler/src/AtomFolding.hs +++ b/compiler/src/AtomFolding.hs @@ -2,7 +2,6 @@ module AtomFolding ( visitProg ) where import Basics import Direct -import Data.Maybe import Control.Monad visitProg :: Prog -> Prog @@ -13,7 +12,7 @@ visitTerm :: [AtomName] -> Term -> Term visitTerm atms (Lit lit) = Lit lit visitTerm atms (Var nm) = if (elem nm atms) - then Record [("tag", Just (Lit (LString nm)))] -- Convert atom into a tagged record + then Record [("tag", Just (Lit (LString nm)))] True -- Convert atom into a tagged record else Var nm visitTerm atms (Abs lam) = Abs (visitLambda atms lam) @@ -38,7 +37,7 @@ 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 (Record fields tag) = Record (visitFields atms fields) tag visitTerm atms (WithRecord e fields) = WithRecord (visitTerm atms e) (visitFields atms fields) visitTerm atms (ProjField t f) = diff --git a/compiler/src/Basics.hs b/compiler/src/Basics.hs index 622e31a0..3b856a75 100644 --- a/compiler/src/Basics.hs +++ b/compiler/src/Basics.hs @@ -11,6 +11,7 @@ import Data.Serialize (Serialize) type VarName = String type AtomName = String type FieldName = String +type ADTTag = Bool -- ASL 2025-08-08: Boolean initially, could be changed for be the ADT identifier at a later stage. -- | 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..b7028ed3 100644 --- a/compiler/src/CPSOpt.hs +++ b/compiler/src/CPSOpt.hs @@ -78,7 +78,7 @@ instance Substitutable SimpleTerm where 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 + Record fields tag -> Record (fwdFields fields) tag WithRecord x fields -> WithRecord (fwd x) $ fwdFields fields ProjField x f -> ProjField (fwd x) f ProjIdx x idx -> ProjIdx (fwd x) idx @@ -146,7 +146,7 @@ instance CensusCollectible SimpleTerm where Un _ v -> updateCensus v ValSimpleTerm sv -> updateCensus sv Tuple vs -> updateCensus vs - Record fs -> let (_,vs) = unzip fs in 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 ProjIdx v _ -> updateCensus v @@ -256,14 +256,14 @@ censusInfo x = do fields x = do w <- look x case w of - St (Record xs) -> return xs + St (Record xs _) -> return xs St (WithRecord y ys) -> do xs <- fields y return $ xs ++ ys _ -> return [] -isRecordTerm (St (Record _)) = True +isRecordTerm (St (Record _ _)) = True isRecordTerm (St (WithRecord _ _ )) = True isRecordTerm _ = False @@ -327,14 +327,14 @@ simplifySimpleTerm t = -- 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 (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 (List _)) -> _ret __falseLit @@ -344,7 +344,7 @@ 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 (ValSimpleTerm _)) -> _ret __falseLit @@ -410,7 +410,7 @@ failFree st = case st of Un _ _ -> False -- Unary operations can fail (e.g., head on empty list, arithmetic on non-numbers) ValSimpleTerm _ -> True Tuple _ -> True - Record _ -> True + Record _ _ -> True WithRecord _ _ -> True ProjField _ _ -> False -- Field projection can fail if field doesn't exist ProjIdx _ _ -> False -- Index projection can fail if index out of bounds @@ -546,4 +546,4 @@ iter kt = rewrite :: Prog -> Prog rewrite (Prog atoms kterm) = - Prog atoms (iter kterm) \ No newline at end of file + Prog atoms (iter kterm) diff --git a/compiler/src/CaseElimination.hs b/compiler/src/CaseElimination.hs index a50c1547..6ade4a20 100644 --- a/compiler/src/CaseElimination.hs +++ b/compiler/src/CaseElimination.hs @@ -260,9 +260,9 @@ transTerm (S.If t1 t2 t3) = do transTerm (S.Tuple tms) = do tms' <- mapM transTerm tms return (T.Tuple tms') -transTerm (S.Record fields) = do +transTerm (S.Record fields tag) = do fields' <- transFields fields - return (T.Record fields') + return (T.Record fields' tag) transTerm (S.WithRecord e fields) = do e' <- transTerm e fields' <- transFields fields @@ -302,4 +302,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..ced98840 100644 --- a/compiler/src/ClosureConv.hs +++ b/compiler/src/ClosureConv.hs @@ -165,9 +165,9 @@ cpsToIR (CPS.LetSimple vname@(VN ident) st kt) = do CPS.Tuple lst -> do lst' <- transVars lst _assign (Tuple lst') - CPS.Record fields -> do + CPS.Record fields tag -> do fields' <- transFields fields - _assign (Record fields') + _assign (Record fields' tag) CPS.WithRecord x fields -> do x' <- transVar x fields' <- transFields fields diff --git a/compiler/src/Core.hs b/compiler/src/Core.hs index 72af085f..60c10e70 100644 --- a/compiler/src/Core.hs +++ b/compiler/src/Core.hs @@ -34,6 +34,7 @@ import ShowIndent import TroupePositionInfo import DCLabels +import Data.List (find) -------------------------------------------------- -- AST is the same as Direct, but lambda are unary (or nullary) @@ -108,7 +109,7 @@ data Term | If Term Term Term | AssertElseError Term Term Term PosInf | Tuple [Term] - | Record Fields + | Record Fields ADTTag | WithRecord Term Fields | ProjField Term FieldName | ProjIdx Term Word @@ -199,7 +200,7 @@ lower (D.Let decls e) = 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.Record fields) = Record (map (\(f, t) -> (f, lower t)) fields) +lower (D.Record fields tag) = Record (map (\(f, t) -> (f, lower t)) fields) tag lower (D.WithRecord e fields) = WithRecord (lower e) (map (\(f, t) -> (f, lower t)) fields) lower (D.ProjField t f) = ProjField (lower t) f lower (D.ProjIdx t idx) = ProjIdx (lower t) idx @@ -333,8 +334,8 @@ rename (AssertElseError t1 t2 t3 p) m = do rename (Tuple terms) m = Tuple <$> mapM (flip rename m) terms -rename (Record fields) m = - Record <$> mapM renameField fields +rename (Record fields tag) m = + (\x -> Record x tag) <$> mapM renameField fields where renameField (f, t) = do t' <- rename t m return (f, t') @@ -448,7 +449,12 @@ ppTerm' (List ts) = PP.hcat $ PP.punctuate (text ",") (map (ppTerm 0) ts) -ppTerm' (Record fs) = PP.braces $ qqFields fs +ppTerm' (Record fs False) = PP.braces $ qqFields fs +ppTerm' (Record fs True) = -- We should not be able to git the "MissingADT" cases - 2025-08-08: ASL + case find (\x -> fst x == "tag") fs of + Just (_, Lit (LString nm)) -> text nm + Just _ -> text "MissingADT" + Nothing -> text "MissingADT" ppTerm' (WithRecord e fs) = PP.braces $ PP.hsep [ ppTerm 0 e, text "with", qqFields fs] diff --git a/compiler/src/Direct.hs b/compiler/src/Direct.hs index 6df77c46..59ef49e7 100644 --- a/compiler/src/Direct.hs +++ b/compiler/src/Direct.hs @@ -21,6 +21,7 @@ import Text.PrettyPrint.HughesPJ ( (<+>), ($$), text, hsep, vcat, nest) import ShowIndent import TroupePositionInfo +import Data.List (find) data PrimType @@ -48,7 +49,6 @@ type Guard = Maybe Term data Handler = Handler DeclPattern (Maybe DeclPattern) Guard Term deriving (Eq) - data DeclPattern = VarPattern VarName --SrcPosInf | ValPattern Lit @@ -94,7 +94,7 @@ data Term | Case Term [(DeclPattern, Term)] PosInf | If Term Term Term | Tuple [Term] - | Record Fields + | Record Fields ADTTag | WithRecord Term Fields | ProjField Term FieldName | ProjIdx Term Word @@ -167,8 +167,14 @@ ppTerm' (Tuple ts) = PP.hcat $ PP.punctuate (text ",") (map (ppTerm 0) ts) -ppTerm' (Record fs) = - PP.braces $ qqFields fs +ppTerm' (Record fs False) = + PP.braces $ qqFields fs +ppTerm' (Record fs True) = -- We should not be able to git the "MissingADT" cases - 2025-08-08: ASL + case find (\x -> fst x == "tag") fs of + Just (_, Just (Lit (LString nm))) -> text nm + Just _ -> text "MissingADT" + Nothing -> text "MissingADT" + ppTerm' (WithRecord t fs) = PP.braces $ PP.hsep [ppTerm 0 t, text "with", qqFields fs] diff --git a/compiler/src/DirectWOPats.hs b/compiler/src/DirectWOPats.hs index 3fd5e022..56b5b336 100644 --- a/compiler/src/DirectWOPats.hs +++ b/compiler/src/DirectWOPats.hs @@ -16,6 +16,7 @@ import Text.PrettyPrint.HughesPJ ( import ShowIndent import DCLabels import TroupePositionInfo +import Data.List (find) data Decl = ValDecl VarName Term @@ -51,7 +52,7 @@ data Term | If Term Term Term | AssertElseError Term Term Term PosInf | Tuple [Term] - | Record Fields + | Record Fields ADTTag | WithRecord Term Fields | ProjField Term FieldName | ProjIdx Term Word @@ -117,8 +118,13 @@ ppTerm' (Tuple ts) = PP.hcat $ PP.punctuate (text ",") (map (ppTerm 0) ts) -ppTerm' (Record fs) = +ppTerm' (Record fs False) = PP.braces $ qqFields fs +ppTerm' (Record fs True) = -- We should not be able to git the "MissingADT" cases - 2025-08-08: ASL + case find (\x -> fst x == "tag") fs of + Just (_, Lit (LString nm)) -> text nm + Just _ -> text "MissingADT" + Nothing -> text "MissingADT" ppTerm' (WithRecord e fs) = PP.braces $ PP.hsep [ ppTerm 0 e, text "with", qqFields fs ] diff --git a/compiler/src/IR.hs b/compiler/src/IR.hs index 3a4f1a77..eb31c92b 100644 --- a/compiler/src/IR.hs +++ b/compiler/src/IR.hs @@ -53,7 +53,7 @@ data IRExpr = Bin Basics.BinOp VarAccess VarAccess | Un Basics.UnaryOp VarAccess | Tuple [VarAccess] - | Record Fields + | Record Fields Basics.ADTTag | WithRecord VarAccess Fields | ProjField VarAccess Basics.FieldName -- | Projection of a tuple field at the given index. The maximum allowed index @@ -416,7 +416,7 @@ ppIRExpr (Base v) = if v == "$$authorityarg" -- special casing; hack; 2018-10-18 then text v else text v <> text "$base" ppIRExpr (Lib (Basics.LibName l) v) = text l <> text "." <> text v -ppIRExpr (Record fields) = PP.braces $ qqFields fields +ppIRExpr (Record fields _) = PP.braces $ qqFields fields ppIRExpr (WithRecord x fields) = PP.braces $ PP.hsep[ ppId x, text "with", qqFields fields] ppIRExpr (ProjField x f) = (ppId x) PP.<> PP.text "." PP.<> PP.text f diff --git a/compiler/src/IR2Raw.hs b/compiler/src/IR2Raw.hs index 7f663c17..b5faf8bb 100644 --- a/compiler/src/IR2Raw.hs +++ b/compiler/src/IR2Raw.hs @@ -428,9 +428,9 @@ expr2rawComp = \case , cValLbl = PC , cTyLbl = PC } - IR.Record fs -> + IR.Record fs tag -> return SimpleRawComp - { cVal = RExpr $ Record fs + { cVal = RExpr $ Record fs tag , cValLbl = PC , cTyLbl = PC } diff --git a/compiler/src/IROpt.hs b/compiler/src/IROpt.hs index 610c1f24..f318b81b 100644 --- a/compiler/src/IROpt.hs +++ b/compiler/src/IROpt.hs @@ -38,7 +38,7 @@ instance Substitutable IRExpr where 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) - Record fields -> Record (_ff fields) + Record fields tag -> Record (_ff fields) tag WithRecord x fields -> WithRecord (apply subst x) (_ff fields) ProjField x f -> ProjField (apply subst x) f ProjIdx x idx -> ProjIdx (apply subst x) idx @@ -194,7 +194,7 @@ canFailOrHasEffects expr = case expr of -- These are generally safe Tuple _ -> False - Record _ -> False + Record _ _ -> False WithRecord _ _ -> False -- Assuming the base is a record List _ -> False Const _ -> False @@ -295,8 +295,8 @@ irExprPeval e = markUsed' x markUsed' y def_ - Record fields -> do mapM pevalField fields - r_ (RecordVal fields, e) + Record fields _tag -> do mapM pevalField fields + r_ (RecordVal fields, e) -- def_ where pevalField (_, x) = markUsed' x WithRecord r fields -> do diff --git a/compiler/src/Parser.y b/compiler/src/Parser.y index 3d67eb45..0cbfb90e 100644 --- a/compiler/src/Parser.y +++ b/compiler/src/Parser.y @@ -234,7 +234,7 @@ Atom : '(' Expr ')' { $2 } | VAR { Var (varTok $1) } | '(' ')' { Lit LUnit } | '(' CSExpr Expr ')' { Tuple (reverse ($3:$2)) } - | '{' '}' { Record [] } + | '{' '}' { Record [] False } | RecordExpr { $1 } | ListExpr { $1 } | Atom '.' VAR { ProjField $1 (varTok $3) } @@ -242,7 +242,7 @@ Atom : '(' Expr ')' { $2 } RecordExpr - : '{' RecordFields '}' { Record $2 } + : '{' RecordFields '}' { Record $2 False } | '{' Atom with RecordFields'}' { WithRecord $2 $4 } diff --git a/compiler/src/Raw.hs b/compiler/src/Raw.hs index 3992b02f..afd449f5 100644 --- a/compiler/src/Raw.hs +++ b/compiler/src/Raw.hs @@ -104,7 +104,7 @@ data RawExpr | ProjectLVal VarAccess LValField | ProjectState MonComponent | Tuple [VarAccess] - | Record Fields + | Record Fields Basics.ADTTag | WithRecord RawVar Fields | ProjField RawVar Basics.FieldName | ProjIdx RawVar Word @@ -290,7 +290,7 @@ ppRawExpr (Const lit) = ppLit lit -- then text v -- else text v <> text "$base" ppRawExpr (Lib (Basics.LibName l) v) = text l <> text "." <> text v -ppRawExpr (Record fields) = PP.braces $ qqFields fields +ppRawExpr (Record fields _) = PP.braces $ qqFields fields ppRawExpr (WithRecord x fields) = PP.braces $ PP.hsep[ ppId x, text "with", qqFields fields] ppRawExpr (ProjField x f) = PP.text "ProjField" PP.<+> (ppId x) PP.<+> PP.text f diff --git a/compiler/src/RawDefUse.hs b/compiler/src/RawDefUse.hs index c6b7314f..39845dc3 100644 --- a/compiler/src/RawDefUse.hs +++ b/compiler/src/RawDefUse.hs @@ -197,7 +197,7 @@ instance Usable RawExpr b where Raw.ProjectLVal x _ -> use x Raw.ProjectState _ -> return () Raw.Tuple xs -> use xs - Raw.Record fields -> use (snd (unzip fields)) + Raw.Record fields _ -> use (snd (unzip fields)) Raw.WithRecord x fields -> do use x use (snd (unzip fields)) diff --git a/compiler/src/RawOpt.hs b/compiler/src/RawOpt.hs index 937dc8be..372b05fb 100644 --- a/compiler/src/RawOpt.hs +++ b/compiler/src/RawOpt.hs @@ -147,7 +147,7 @@ instance MarkUsed RawExpr where ProjectLVal x _ -> markUsed x ProjectState _ -> return () Tuple xs -> markUsed xs - Record fields -> markUsed (snd (unzip fields)) + Record fields _ -> markUsed (snd (unzip fields)) WithRecord x fields -> do markUsed x markUsed (snd (unzip fields)) @@ -244,7 +244,7 @@ guessType = \case Tuple _ -> Just RawTuple List _ -> Just RawList ListCons _ _ -> Just RawList - Record _ -> Just RawRecord + Record _ _ -> Just RawRecord WithRecord _ _ -> Just RawRecord -- Revision 2023-08: Added missing cases ProjField _ _ -> Nothing diff --git a/compiler/src/RetCPS.hs b/compiler/src/RetCPS.hs index 15cec1e4..ab9c3736 100644 --- a/compiler/src/RetCPS.hs +++ b/compiler/src/RetCPS.hs @@ -61,7 +61,7 @@ data SimpleTerm | Un UnaryOp VarName | ValSimpleTerm SVal | Tuple [VarName] - | Record Fields + | Record Fields Basics.ADTTag | WithRecord VarName Fields | ProjField VarName Basics.FieldName | ProjIdx VarName Word @@ -149,7 +149,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 +264,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..5ff2c54f 100644 --- a/compiler/src/RetDFCPS.hs +++ b/compiler/src/RetDFCPS.hs @@ -134,8 +134,8 @@ transExplicit (Core.Tuple ts) = transTuple (t:ts) acc = trans t (\v -> transTuple ts (v:acc) ) -transExplicit (Core.Record fields) = - transFieldsExplicit Record fields +transExplicit (Core.Record fields tag) = + transFieldsExplicit (\fds -> Record fds tag) fields transExplicit (Core.WithRecord e fields) = trans e (\x -> transFieldsExplicit (WithRecord x) fields) @@ -268,7 +268,7 @@ trans (Core.Tuple ts) context = transTuple (t:ts) acc context = trans t (\v -> transTuple ts (v:acc) context) -trans (Core.Record fields) context = transFields Record fields context +trans (Core.Record fields tag) context = transFields (\fds -> Record fds tag) fields context trans (Core.WithRecord e fields) context = trans e (\ rr -> transFields (WithRecord rr) fields context ) diff --git a/compiler/src/RetFreeVars.hs b/compiler/src/RetFreeVars.hs index ff24c221..ade6ee4f 100644 --- a/compiler/src/RetFreeVars.hs +++ b/compiler/src/RetFreeVars.hs @@ -56,7 +56,7 @@ instance FreeNames SimpleTerm where freeVars (ListCons v1 v2) = FreeVars (Set.fromList [v1, v2]) freeVars (Base _ ) = FreeVars $ Set.empty freeVars (Lib _ _) = FreeVars $ Set.empty - freeVars (Record fields) = unionMany $ + freeVars (Record fields _) = unionMany $ map (\(f,x) -> FreeVars (if x == VN f then Set.empty else Set.singleton x)) fields freeVars (WithRecord x fields) = diff --git a/compiler/src/RetRewrite.hs b/compiler/src/RetRewrite.hs index cb18eb73..82d1e298 100644 --- a/compiler/src/RetRewrite.hs +++ b/compiler/src/RetRewrite.hs @@ -66,7 +66,7 @@ instance Substitutable SimpleTerm where 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 + Record fields tag -> Record (fwdFields fields) tag WithRecord x fields -> WithRecord (fwd x) $ fwdFields fields ProjField x f -> ProjField (fwd x) f ProjIdx x idx -> ProjIdx (fwd x) idx diff --git a/compiler/src/Stack2JS.hs b/compiler/src/Stack2JS.hs index 53647fa9..cb45a009 100644 --- a/compiler/src/Stack2JS.hs +++ b/compiler/src/Stack2JS.hs @@ -591,7 +591,7 @@ instance ToJS RawExpr where 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)) - Record fields -> do + Record fields _ -> do jsFields <- fieldsToJS fields return $ PP.parens $ text "rt.mkRecord" <> PP.parens (PP.brackets $ PP.hsep $ jsFields ) From 722c85c2cf12c49de59f2fdda35a74952513eb8e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Fri, 8 Aug 2025 14:15:22 +0200 Subject: [PATCH 03/30] Records now have tags of whether or not they are ADTs --- compiler/src/Stack2JS.hs | 6 ++++-- rt/src/Record.mts | 32 +++++++++++++++++++------------- rt/src/deserialize.mts | 6 +++--- rt/src/runtimeMonitored.mts | 2 +- rt/src/serialize.mts | 4 ++-- 5 files changed, 29 insertions(+), 21 deletions(-) diff --git a/compiler/src/Stack2JS.hs b/compiler/src/Stack2JS.hs index cb45a009..0dcf3789 100644 --- a/compiler/src/Stack2JS.hs +++ b/compiler/src/Stack2JS.hs @@ -591,10 +591,12 @@ instance ToJS RawExpr where 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)) - Record fields _ -> do + Record fields tag -> 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, text ",", tagToJS tag]) + where tagToJS True = text "true" + tagToJS False = text "false" WithRecord r fields -> do jsFields <- fieldsToJS fields return $ diff --git a/rt/src/Record.mts b/rt/src/Record.mts index 5d688e1a..97a27f32 100644 --- a/rt/src/Record.mts +++ b/rt/src/Record.mts @@ -10,21 +10,27 @@ export class Record implements TroupeAggregateRawValue { _troupeType = TroupeType.RECORD _dataLevel: Level = levels.TOP // TODO compute data level? __obj : Map + _isADT: boolean 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 += "}" - return s + if (this._isADT) { + return this.__obj.get("tag").val.toString() + } else { + // 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 += "}" + return s + } } - constructor(fields: Iterable) { + constructor(fields: Iterable, isADT: boolean) { this.__obj = new Map (fields) + this._isADT = isADT } hasField (fieldName:string):boolean { @@ -39,13 +45,13 @@ export class Record implements TroupeAggregateRawValue { return this._dataLevel } - static mkRecord(fields: Iterable): Record { - return new Record(fields) + static mkRecord(fields: Iterable, isADT): Record { + return new Record(fields, isADT) } static mkWithRecord(r: Record, fields: ConcatArray<[string, LVal]>): Record { let a = Array.from(r.__obj) let b = a.concat(fields) - return new Record(b) + return new Record(b, false) } } diff --git a/rt/src/deserialize.mts b/rt/src/deserialize.mts index 2c194875..78b57b2d 100644 --- a/rt/src/deserialize.mts +++ b/rt/src/deserialize.mts @@ -243,10 +243,10 @@ 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); + return Record.mkRecord(a, obj.isADT); // 2025-08-08 ASL: This is a place holder case Ty.TroupeType.LIST: return mkList(deserializeArray(obj)) case Ty.TroupeType.TUPLE: diff --git a/rt/src/runtimeMonitored.mts b/rt/src/runtimeMonitored.mts index 1c54578c..4a319a1e 100644 --- a/rt/src/runtimeMonitored.mts +++ b/rt/src/runtimeMonitored.mts @@ -510,7 +510,7 @@ export async function start(f) { if (__p2pRunning) { let service_arg = new LVal ( new Record([ ["authority", mainAuthority], - ["options", __unit]]), + ["options", __unit]], false), levels.BOT); __sched.scheduleNewThreadAtLevel(__service['service'] , service_arg diff --git a/rt/src/serialize.mts b/rt/src/serialize.mts index 75c9ee77..93725f53 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: [], isADT: x._isADT }; for (let [k,v] of x.__obj.entries()) { - jsonObj.push ([k, walk(v)]) + jsonObj.fields.push ([k, walk(v)]) } break; case Ty.TroupeType.LIST: From 84aef993f499fb13a2c853a54c344a6f0694460e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Fri, 8 Aug 2025 14:57:06 +0200 Subject: [PATCH 04/30] updated IR2Raw test to have the ADTTag --- compiler/test/ir2raw-test/testcases/Expr.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/compiler/test/ir2raw-test/testcases/Expr.hs b/compiler/test/ir2raw-test/testcases/Expr.hs index 1cc519ae..44e9a2b3 100644 --- a/compiler/test/ir2raw-test/testcases/Expr.hs +++ b/compiler/test/ir2raw-test/testcases/Expr.hs @@ -30,9 +30,9 @@ tcs = map (second mkP) $ , ("List0", List []) , ("List1", List [mkV "v"]) , ("List2", List [mkV "v1", mkV "v2"]) - , ("Record0", Record []) - , ("Record1", Record [("field1", mkV "v1")]) - , ("Record2", Record [("field1", mkV "v1"), ("field2", mkV "v2")]) + , ("Record0", Record [] False) + , ("Record1", Record [("field1", mkV "v1")] False) + , ("Record2", Record [("field1", mkV "v1"), ("field2", mkV "v2")] False) , ("ListCons", ListCons (mkV "x") (mkV "xs")) , ("WithRecord0", WithRecord (mkV "x") []) , ("WithRecord1", WithRecord (mkV "x") [("field1", mkV "v1")]) From b8b6623654b4d80260c739eb20882e6c331c295c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Fri, 8 Aug 2025 16:52:15 +0200 Subject: [PATCH 05/30] Added support for ADT naming --- compiler/src/AtomFolding.hs | 11 ++++++----- compiler/src/Basics.hs | 5 ++++- compiler/src/CaseElimination.hs | 6 +++--- compiler/src/Core.hs | 8 ++++---- compiler/src/Direct.hs | 29 ++++++++++++++-------------- compiler/src/DirectWOPats.hs | 34 +++++++++++++++------------------ compiler/src/Lexer.x | 1 - compiler/src/Parser.y | 9 ++++----- 8 files changed, 51 insertions(+), 52 deletions(-) diff --git a/compiler/src/AtomFolding.hs b/compiler/src/AtomFolding.hs index 737ceee9..070de656 100644 --- a/compiler/src/AtomFolding.hs +++ b/compiler/src/AtomFolding.hs @@ -5,10 +5,11 @@ import Direct import Control.Monad visitProg :: Prog -> Prog -visitProg (Prog imports (Atoms atms) tm) = - Prog imports (Atoms atms) (visitTerm atms tm) +visitProg (Prog imports (DataTypes datatypes) tm) = + let tcs = concat $ map snd datatypes + in Prog imports (DataTypes datatypes) (visitTerm tcs tm) -visitTerm :: [AtomName] -> Term -> Term +visitTerm :: [TypeConstructorName] -> Term -> Term visitTerm atms (Lit lit) = Lit lit visitTerm atms (Var nm) = if (elem nm atms) @@ -62,7 +63,7 @@ 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 :: [TypeConstructorName] -> DeclPattern -> DeclPattern visitPattern atms pat@(VarPattern nm) = if (elem nm atms) then RecordPattern [("tag", Just (ValPattern (LString nm)))] ExactMatch -- Convert atom match into a record match @@ -77,7 +78,7 @@ visitPattern atms (RecordPattern fields mode) = RecordPattern (map visitField fi where visitField pat@(_, Nothing) = pat visitField (f, Just p) = (f, Just (visitPattern atms p)) -visitLambda :: [AtomName] -> Lambda -> Lambda +visitLambda :: [TypeConstructorName] -> 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 3b856a75..92803226 100644 --- a/compiler/src/Basics.hs +++ b/compiler/src/Basics.hs @@ -10,8 +10,11 @@ import Data.Serialize (Serialize) type VarName = String type AtomName = String +type DataTypeName = String +type TypeConstructorName = String +type DataTypeDef = (DataTypeName, [TypeConstructorName]) type FieldName = String -type ADTTag = Bool -- ASL 2025-08-08: Boolean initially, could be changed for be the ADT identifier at a later stage. +type ADTTag = 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/CaseElimination.hs b/compiler/src/CaseElimination.hs index 6ade4a20..ecd753a9 100644 --- a/compiler/src/CaseElimination.hs +++ b/compiler/src/CaseElimination.hs @@ -31,8 +31,8 @@ trans mode (S.Prog imports atms tm) = do tm'' <- transTerm tm' return (T.Prog imports atms' tm'') -transAtoms :: S.Atoms -> Trans T.Atoms -transAtoms (S.Atoms atms) = return (T.Atoms atms) +transAtoms :: S.DataTypes -> Trans T.DataTypes +transAtoms (S.DataTypes atms) = return (T.DataTypes 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.LDataType a) = T.LDataType a transLambda_aux :: S.Lambda -> ReaderT T.Term Trans Lambda diff --git a/compiler/src/Core.hs b/compiler/src/Core.hs index 60c10e70..257dde2e 100644 --- a/compiler/src/Core.hs +++ b/compiler/src/Core.hs @@ -58,7 +58,7 @@ data Lit | LDCLabel DCLabelExp | LUnit | LBool Bool - | LAtom AtomName + | LAtom TypeConstructorName deriving (Show, Generic) instance Serialize Lit instance Eq Lit where @@ -158,8 +158,8 @@ lowerProg (D.Prog imports atms term) = Prog imports (trans atms) (lower term) -- the rest of the declarations in this part are not exported -trans :: D.Atoms -> Atoms -trans (D.Atoms atms) = Atoms atms +trans :: D.DataTypes -> Atoms +trans (D.DataTypes atms) = Atoms (concat $ map snd atms) lowerLam (D.Lambda vs t) = case vs of @@ -173,7 +173,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.LDataType n) = LAtom n lower :: D.Term -> Core.Term lower (D.Lit l) = Lit (lowerLit l) diff --git a/compiler/src/Direct.hs b/compiler/src/Direct.hs index 59ef49e7..028b477d 100644 --- a/compiler/src/Direct.hs +++ b/compiler/src/Direct.hs @@ -5,8 +5,9 @@ module Direct ( Lambda (..) , Lit(..) , DeclPattern(..) , RecordPatternMode(..) - , AtomName - , Atoms(..) + , DataTypeName + , TypeConstructorName + , DataTypes(..) , Prog(..) , Handler(..) , FieldName @@ -78,7 +79,7 @@ data Lit | LString String --SrcPosInf | LLabel String --SrcPosInf | LDCLabel DCLabelExp - | LAtom AtomName --SrcPosInf + | LDataType TypeConstructorName --SrcPosInf deriving (Eq, Show) @@ -106,11 +107,11 @@ data Term | Error Term deriving (Eq) -data Atoms = Atoms [AtomName] +data DataTypes = DataTypes [DataTypeDef] deriving (Eq, Show) -data Prog = Prog Imports Atoms Term +data Prog = Prog Imports DataTypes Term deriving (Eq, Show) @@ -130,13 +131,13 @@ 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) (DataTypes datatypes) term) = + let ppDataTypes = + if null datatypes + then PP.empty + else vcat $ flip map datatypes (\dt -> (text "datatype ") <+> + (text $ fst dt) <+> + (hsep $ PP.punctuate (text " |") (map text $ snd dt))) ppImports = if null imports then PP.empty else @@ -144,7 +145,7 @@ ppProg (Prog (Imports imports) (Atoms atoms) term) = in (vcat $ (map ppLibName imports)) $$ PP.text "" in vcat [ ppImports - , ppAtoms + , ppDataTypes , ppTerm 0 term ] @@ -352,7 +353,7 @@ 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 (LDataType s) = text s termPrec :: Term -> Precedence diff --git a/compiler/src/DirectWOPats.hs b/compiler/src/DirectWOPats.hs index 56b5b336..c9ced0be 100644 --- a/compiler/src/DirectWOPats.hs +++ b/compiler/src/DirectWOPats.hs @@ -3,8 +3,9 @@ module DirectWOPats ( Lambda (..) , Decl (..) , FunDecl (..) , Lit(..) - , AtomName - , Atoms(..) + , DataTypeName + , TypeConstructorName + , DataTypes(..) , Prog(..) ) where @@ -33,7 +34,7 @@ data Lit | LDCLabel DCLabelExp | LUnit | LBool Bool - | LAtom AtomName + | LDataType DataTypeName deriving (Eq, Show) @@ -63,17 +64,13 @@ data Term | Error Term PosInf deriving (Eq) -data Atoms = Atoms [AtomName] +data DataTypes = DataTypes [DataTypeDef] deriving (Eq, Show) -data Prog = Prog Imports Atoms Term +data Prog = Prog Imports DataTypes Term deriving (Eq, Show) - - - - -------------------------------------------------- -- show is defined via pretty printing instance Show Term @@ -89,14 +86,15 @@ 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) (DataTypes datatypes) term) = + let ppDataTypes = + if null datatypes + then PP.empty + else vcat $ flip map datatypes (\dt -> (text "datatype ") <+> + (text $ fst dt) <+> + (hsep $ PP.punctuate (text " |") (map text $ snd dt))) ppImports = if null imports then PP.empty else text "<>\n" - in ppImports $$ ppAtoms $$ ppTerm 0 term + in ppImports $$ ppDataTypes $$ ppTerm 0 term ppTerm :: Precedence -> Term -> PP.Doc @@ -229,9 +227,7 @@ ppLit (LDCLabel dc) = ppDCLabelExpLit dc ppLit LUnit = text "()" ppLit (LBool True) = text "true" ppLit (LBool False) = text "false" -ppLit (LAtom a) = text a - - +ppLit (LDataType a) = text a termPrec :: Term -> Precedence diff --git a/compiler/src/Lexer.x b/compiler/src/Lexer.x index 5a205744..71b33b46 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 } diff --git a/compiler/src/Parser.y b/compiler/src/Parser.y index 0cbfb90e..6b87f0c4 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,17 +133,17 @@ import Control.Monad.Except -Prog : ImportDecl AtomsDecl Expr { Prog (Imports $1) (Atoms $2) $3 } +Prog : ImportDecl DataTypeDecl Expr { Prog (Imports $1) (DataTypes $2) $3 } ImportDecl: import VAR ImportDecl { ((LibName (varTok $2), Nothing)): $3 } | { [] } -AtomsDecl : datatype Atoms '=' VAR AtomsList { (varTok $4):$5 } +DataTypeDecl : datatype VAR '=' VAR DataTypeList DataTypeDecl { (varTok $2, (varTok $4):$5):$6 } | {[]} -AtomsList : { [] } - | '|' VAR AtomsList { (varTok $2): $3 } +DataTypeList : { [] } + | '|' VAR DataTypeList { (varTok $2): $3 } Expr: Form { $1 } From 36f80583aa4ad0d3537ff98fcebf1fed9d1ad89b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Fri, 8 Aug 2025 17:21:08 +0200 Subject: [PATCH 06/30] Added tests for named datatypes --- compiler/src/Lexer.x | 1 - tests/rt/pos/core/adt-atom-day1.trp | 18 ++++++++++++++++++ tests/rt/pos/core/adt-atom-day2.trp | 17 +++++++++++++++++ 3 files changed, 35 insertions(+), 1 deletion(-) create mode 100644 tests/rt/pos/core/adt-atom-day1.trp create mode 100644 tests/rt/pos/core/adt-atom-day2.trp diff --git a/compiler/src/Lexer.x b/compiler/src/Lexer.x index 71b33b46..318ab1e4 100644 --- a/compiler/src/Lexer.x +++ b/compiler/src/Lexer.x @@ -195,7 +195,6 @@ data Token | TokenWhen | TokenWith | TokenDatatype - | TokenAtoms | TokenIntDiv | TokenMod | TokenFn 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.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 From 4c51524957a69975c4b1224acf0d5d6d9a95dde9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Fri, 8 Aug 2025 17:36:42 +0200 Subject: [PATCH 07/30] Added tests for custom named atomic datatypes --- tests/rt/pos/core/adt-atom-day1.golden | 4 ++++ tests/rt/pos/core/adt-atom-day2.golden | 2 ++ tests/rt/pos/core/adt-atom-multiple-declarations.golden | 4 ++++ tests/rt/pos/core/adt-atom-multiple-declarations.trp | 8 ++++++++ 4 files changed, 18 insertions(+) create mode 100644 tests/rt/pos/core/adt-atom-day1.golden create mode 100644 tests/rt/pos/core/adt-atom-day2.golden create mode 100644 tests/rt/pos/core/adt-atom-multiple-declarations.golden create mode 100644 tests/rt/pos/core/adt-atom-multiple-declarations.trp 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-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-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 From 739ca5f2af7f6d7685ffa58a2010e2ac7525e23e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Tue, 12 Aug 2025 18:20:04 +0200 Subject: [PATCH 08/30] Added support for datatypes with constructors --- compiler/src/AtomFolding.hs | 22 +++++++++++++++------- compiler/src/Basics.hs | 3 ++- compiler/src/Core.hs | 2 +- compiler/src/Direct.hs | 9 ++++++--- compiler/src/DirectWOPats.hs | 7 +++++-- compiler/src/Parser.y | 12 +++++++++--- 6 files changed, 38 insertions(+), 17 deletions(-) diff --git a/compiler/src/AtomFolding.hs b/compiler/src/AtomFolding.hs index 070de656..47013c30 100644 --- a/compiler/src/AtomFolding.hs +++ b/compiler/src/AtomFolding.hs @@ -3,18 +3,26 @@ where import Basics import Direct import Control.Monad +import Data.List (find, any) visitProg :: Prog -> Prog visitProg (Prog imports (DataTypes datatypes) tm) = let tcs = concat $ map snd datatypes in Prog imports (DataTypes datatypes) (visitTerm tcs tm) -visitTerm :: [TypeConstructorName] -> Term -> Term +visitTerm :: [TypeConstructor] -> Term -> Term visitTerm atms (Lit lit) = Lit lit visitTerm atms (Var nm) = - if (elem nm atms) - then Record [("tag", Just (Lit (LString nm)))] True -- Convert atom into a tagged record - else Var nm + let tag = "tag" + value = "value" + var = "v" + in case find (\x -> (fst x) == nm) atms of + Nothing -> Var nm + Just (t, []) -> Record [(tag, Just (Lit (LString nm)))] True -- Convert atom into a tagged record + Just (t, _) -> + Abs (Lambda [VarPattern var] (Record [(tag, Just (Lit (LString nm))) + , (value, Just (Var var)) + ] True)) visitTerm atms (Abs lam) = Abs (visitLambda atms lam) visitTerm atms (Hnd (Handler pat maybePat maybeTerm term)) = @@ -63,9 +71,9 @@ visitFields atms fs = map visitField fs where visitField (f, Nothing) = (f, Nothing) visitField (f, Just t) = (f, Just (visitTerm atms t)) -visitPattern :: [TypeConstructorName] -> DeclPattern -> DeclPattern +visitPattern :: [TypeConstructor] -> DeclPattern -> DeclPattern visitPattern atms pat@(VarPattern nm) = - if (elem nm atms) + if any (\x -> x == (nm, [])) atms then RecordPattern [("tag", Just (ValPattern (LString nm)))] ExactMatch -- Convert atom match into a record match else pat visitPattern _ pat@(ValPattern _) = pat @@ -78,7 +86,7 @@ visitPattern atms (RecordPattern fields mode) = RecordPattern (map visitField fi where visitField pat@(_, Nothing) = pat visitField (f, Just p) = (f, Just (visitPattern atms p)) -visitLambda :: [TypeConstructorName] -> Lambda -> Lambda +visitLambda :: [TypeConstructor] -> 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 92803226..067dee4c 100644 --- a/compiler/src/Basics.hs +++ b/compiler/src/Basics.hs @@ -12,7 +12,8 @@ type VarName = String type AtomName = String type DataTypeName = String type TypeConstructorName = String -type DataTypeDef = (DataTypeName, [TypeConstructorName]) +type TypeConstructor = (TypeConstructorName, [VarName]) +type DataTypeDef = (DataTypeName, [TypeConstructor]) type FieldName = String type ADTTag = Bool diff --git a/compiler/src/Core.hs b/compiler/src/Core.hs index 257dde2e..ef4b2a82 100644 --- a/compiler/src/Core.hs +++ b/compiler/src/Core.hs @@ -159,7 +159,7 @@ lowerProg (D.Prog imports atms term) = Prog imports (trans atms) (lower term) -- the rest of the declarations in this part are not exported trans :: D.DataTypes -> Atoms -trans (D.DataTypes atms) = Atoms (concat $ map snd atms) +trans (D.DataTypes atms) = Atoms [] -- (concat $ map snd atms) lowerLam (D.Lambda vs t) = case vs of diff --git a/compiler/src/Direct.hs b/compiler/src/Direct.hs index 028b477d..c308fb69 100644 --- a/compiler/src/Direct.hs +++ b/compiler/src/Direct.hs @@ -6,7 +6,7 @@ module Direct ( Lambda (..) , DeclPattern(..) , RecordPatternMode(..) , DataTypeName - , TypeConstructorName + , TypeConstructor , DataTypes(..) , Prog(..) , Handler(..) @@ -137,7 +137,10 @@ ppProg (Prog (Imports imports) (DataTypes datatypes) term) = then PP.empty else vcat $ flip map datatypes (\dt -> (text "datatype ") <+> (text $ fst dt) <+> - (hsep $ PP.punctuate (text " |") (map text $ snd 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 @@ -353,7 +356,7 @@ ppLit (LUnit ) = text "()" ppLit (LBool True ) = text "true" ppLit (LBool False) = text "false" ppLit (LLabel s ) = PP.braces (text s) -ppLit (LDataType s) = text s +ppLit (LDataType s) = text s termPrec :: Term -> Precedence diff --git a/compiler/src/DirectWOPats.hs b/compiler/src/DirectWOPats.hs index c9ced0be..3487e405 100644 --- a/compiler/src/DirectWOPats.hs +++ b/compiler/src/DirectWOPats.hs @@ -4,7 +4,7 @@ module DirectWOPats ( Lambda (..) , FunDecl (..) , Lit(..) , DataTypeName - , TypeConstructorName + , TypeConstructor , DataTypes(..) , Prog(..) ) @@ -92,7 +92,10 @@ ppProg (Prog (Imports imports) (DataTypes datatypes) term) = then PP.empty else vcat $ flip map datatypes (\dt -> (text "datatype ") <+> (text $ fst dt) <+> - (hsep $ PP.punctuate (text " |") (map text $ snd 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 $$ ppDataTypes $$ ppTerm 0 term diff --git a/compiler/src/Parser.y b/compiler/src/Parser.y index 6b87f0c4..c945b10b 100644 --- a/compiler/src/Parser.y +++ b/compiler/src/Parser.y @@ -139,12 +139,18 @@ ImportDecl: import VAR ImportDecl { ((LibName (varTok $2), Nothing)): $3 } | { [] } -DataTypeDecl : datatype VAR '=' VAR DataTypeList DataTypeDecl { (varTok $2, (varTok $4):$5):$6 } +DataTypeDecl : datatype VAR '=' DataTypeConstructor DataTypeList DataTypeDecl { (varTok $2, $4:$5):$6 } | {[]} - + DataTypeList : { [] } - | '|' VAR DataTypeList { (varTok $2): $3 } + | '|' DataTypeConstructor DataTypeList { $2: $3 } + +DataTypeConstructor : VAR { (varTok $1, []) } + | VAR of DataTypeConstructorArgs { (varTok $1, $3) } +DataTypeConstructorArgs : VAR { (varTok $1):[] } + | VAR '*' DataTypeConstructorArgs { (varTok $1):$3 } + | '(' DataTypeConstructorArgs ')' { $2 } Expr: Form { $1 } | let pini Expr Decs in Expr end { Let (piniDecl $3 $4) $6 } From eac4175adcb4c2a1374093f5495c36f7562cf974 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Wed, 13 Aug 2025 10:20:36 +0200 Subject: [PATCH 09/30] Added printing support for ADT representation --- rt/src/Record.mts | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/rt/src/Record.mts b/rt/src/Record.mts index 97a27f32..caa5d227 100644 --- a/rt/src/Record.mts +++ b/rt/src/Record.mts @@ -14,7 +14,12 @@ export class Record implements TroupeAggregateRawValue { stringRep (omitLevels?: boolean, taintRef?: any) { if (this._isADT) { - return this.__obj.get("tag").val.toString() + if (this.__obj.has("value")) { + return "(" + this.__obj.get("tag").val.toString() + " " + + "(" + this.__obj.get("value").stringRep(omitLevels, taintRef) + ")" + ")" + } else { + return this.__obj.get("tag").val.toString() + } } else { // return ("{" + listStringRep(this.toArray(), omitLevels, taintRef) + "}") let s = "{" From 3946cc103f480839e4b0b4d1fc6c65eaf44af7c8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Wed, 13 Aug 2025 10:27:05 +0200 Subject: [PATCH 10/30] Made the printing code for ADTs a tiny bit more readable --- rt/src/Record.mts | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/rt/src/Record.mts b/rt/src/Record.mts index caa5d227..51dae8df 100644 --- a/rt/src/Record.mts +++ b/rt/src/Record.mts @@ -15,8 +15,9 @@ export class Record implements TroupeAggregateRawValue { stringRep (omitLevels?: boolean, taintRef?: any) { if (this._isADT) { if (this.__obj.has("value")) { - return "(" + this.__obj.get("tag").val.toString() + " " - + "(" + this.__obj.get("value").stringRep(omitLevels, taintRef) + ")" + ")" + let tag = this.__obj.get("tag").val.toString() + let val = this.__obj.get("value").stringRep(omitLevels, taintRef) + return "(" + tag + " " + "(" + val + ")" + ")" } else { return this.__obj.get("tag").val.toString() } From d1a5c7548fbd830210213a01e38f0ed355616f31 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Wed, 13 Aug 2025 11:36:04 +0200 Subject: [PATCH 11/30] Matching added for type constructors --- compiler/src/AtomFolding.hs | 4 ++++ compiler/src/Direct.hs | 1 + compiler/src/Parser.y | 13 +++++++++---- 3 files changed, 14 insertions(+), 4 deletions(-) diff --git a/compiler/src/AtomFolding.hs b/compiler/src/AtomFolding.hs index 47013c30..ffe51a4c 100644 --- a/compiler/src/AtomFolding.hs +++ b/compiler/src/AtomFolding.hs @@ -85,6 +85,10 @@ 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)) +visitPattern atms (DataTypePattern nm pat) = + RecordPattern [("tag", Just (ValPattern (LString nm))) + ,("value", Just (visitPattern atms pat))] ExactMatch + visitLambda :: [TypeConstructor] -> Lambda -> Lambda visitLambda atms (Lambda pats term) = diff --git a/compiler/src/Direct.hs b/compiler/src/Direct.hs index c308fb69..c07b7949 100644 --- a/compiler/src/Direct.hs +++ b/compiler/src/Direct.hs @@ -59,6 +59,7 @@ data DeclPattern | ConsPattern DeclPattern DeclPattern --SrcPosInf | ListPattern [DeclPattern] --SrcPosInf | RecordPattern [(FieldName, Maybe DeclPattern)] RecordPatternMode + | DataTypePattern TypeConstructorName DeclPattern deriving (Eq) data RecordPatternMode = ExactMatch | WildcardMatch diff --git a/compiler/src/Parser.y b/compiler/src/Parser.y index c945b10b..4eb26071 100644 --- a/compiler/src/Parser.y +++ b/compiler/src/Parser.y @@ -195,6 +195,8 @@ Expr: Form { $1 } Match : Pattern '=>' Expr { [($1,$3)] } | Pattern '=>' Expr '|' Match { ($1,$3):$5 } + | DataTypePattern '=>' Expr { [($1,$3)] } + | DataTypePattern '=>' Expr '|' Match { ($1,$3):$5 } Form :: { Term } @@ -270,6 +272,8 @@ ListExpr : '[' ']' { List [] } CSExpr : Expr ',' { [$1] } | CSExpr Expr ',' { ($2:$1) } +DataTypePattern : VAR Pattern { DataTypePattern (varTok $1) $2 } + | VAR '(' DataTypePattern ')' { DataTypePattern (varTok $1) $3 } Pattern : VAR { VarPattern (varTok $1) } | '(' Pattern ')' { $2 } @@ -279,8 +283,7 @@ Pattern : VAR { VarPattern (varTok $1) } | Lit { ValPattern $1 } | '(' CSPattern Pattern ')' { TuplePattern (reverse ($3:$2)) } | FieldPattern { $1 } - | ListPattern { $1} - + | ListPattern { $1 } FieldPattern : '{' '}' { RecordPattern [] ExactMatch } @@ -339,8 +342,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} + | '(' DataTypePattern ')' { [$2] } + | '(' DataTypePattern ')' FunArgs { $2 : $4 } { From d454c79356107e35d78320515a193d0d427ea6a3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Wed, 13 Aug 2025 13:01:53 +0200 Subject: [PATCH 12/30] ADT constructors have been added --- tests/rt/pos/core/adt-arith.golden | 2 ++ tests/rt/pos/core/adt-arith.trp | 17 +++++++++++++++++ tests/rt/pos/core/adt-option1.golden | 2 ++ tests/rt/pos/core/adt-option1.trp | 6 ++++++ tests/rt/pos/core/adt-option2.golden | 2 ++ tests/rt/pos/core/adt-option2.trp | 2 ++ 6 files changed, 31 insertions(+) create mode 100644 tests/rt/pos/core/adt-arith.golden create mode 100644 tests/rt/pos/core/adt-arith.trp create mode 100644 tests/rt/pos/core/adt-option1.golden create mode 100644 tests/rt/pos/core/adt-option1.trp create mode 100644 tests/rt/pos/core/adt-option2.golden create mode 100644 tests/rt/pos/core/adt-option2.trp 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-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..5a69f863 --- /dev/null +++ b/tests/rt/pos/core/adt-option2.golden @@ -0,0 +1,2 @@ +2025-08-13T09:50:21.033Z [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) From c573aa3439592dd3a190eaa633038f640432abec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Wed, 13 Aug 2025 17:34:06 +0200 Subject: [PATCH 13/30] fixed some printing for adt constructors --- rt/src/Record.mts | 2 +- tests/rt/pos/core/adt-option2.golden | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/rt/src/Record.mts b/rt/src/Record.mts index 51dae8df..950b4183 100644 --- a/rt/src/Record.mts +++ b/rt/src/Record.mts @@ -17,7 +17,7 @@ export class Record implements TroupeAggregateRawValue { if (this.__obj.has("value")) { let tag = this.__obj.get("tag").val.toString() let val = this.__obj.get("value").stringRep(omitLevels, taintRef) - return "(" + tag + " " + "(" + val + ")" + ")" + return "(" + tag + " " + val + ")" } else { return this.__obj.get("tag").val.toString() } diff --git a/tests/rt/pos/core/adt-option2.golden b/tests/rt/pos/core/adt-option2.golden index 5a69f863..92dbfd2e 100644 --- a/tests/rt/pos/core/adt-option2.golden +++ b/tests/rt/pos/core/adt-option2.golden @@ -1,2 +1,2 @@ -2025-08-13T09:50:21.033Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. ->>> Main thread finished with value: (NONE@{}%{}, (SOME (28@{}%{}))@{}%{})@{}%{} +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@{}%{})@{}%{})@{}%{} From 4b1f2e0a4ffa6d445e858b984b3f000e96309d1c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Wed, 20 Aug 2025 15:03:33 +0200 Subject: [PATCH 14/30] Added missing case for pretty-printing in Direct.hs --- compiler/src/Direct.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/compiler/src/Direct.hs b/compiler/src/Direct.hs index c07b7949..3b864798 100644 --- a/compiler/src/Direct.hs +++ b/compiler/src/Direct.hs @@ -348,6 +348,10 @@ ppDeclPattern (RecordPattern fields mode) = wildcard = case mode of ExactMatch -> [] WildcardMatch -> [text ".."] +ppDeclPattern (DataTypePattern nm pat) = + text nm PP.<> PP.space PP.<> + case pat of DataTypePattern _ _ -> PP.parens $ ppDeclPattern pat + otherwise -> ppDeclPattern pat ppLit :: Lit -> PP.Doc ppLit (LInt i _ ) = PP.integer i From 9a51a78731b1096705f3378a059476a51efd06c5 Mon Sep 17 00:00:00 2001 From: Aslan Askarov Date: Sat, 20 Sep 2025 17:12:43 +0200 Subject: [PATCH 15/30] cc-based analysis --- .../adt-translation-potential-issues.md | 337 ++++++++++++++++++ 1 file changed, 337 insertions(+) create mode 100644 docs/description/adt-translation-potential-issues.md 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 From 8945a4aef5f3d238e2139a3a4f8e57894f2461cf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Fri, 19 Sep 2025 16:36:24 +0200 Subject: [PATCH 16/30] checkpoint --- compiler/src/AddAmbientMethods.hs | 8 ++++---- compiler/src/Core.hs | 31 +++++++++++++++---------------- compiler/src/Direct.hs | 21 +++++++++------------ compiler/src/DirectWOPats.hs | 4 ++-- compiler/src/Parser.y | 6 +++--- compiler/src/RetDFCPS.hs | 8 ++++---- 6 files changed, 37 insertions(+), 41 deletions(-) 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/Core.hs b/compiler/src/Core.hs index ef4b2a82..c0265ab8 100644 --- a/compiler/src/Core.hs +++ b/compiler/src/Core.hs @@ -108,8 +108,8 @@ data Term | Let Decl Term | If Term Term Term | AssertElseError Term Term Term PosInf - | Tuple [Term] - | Record Fields ADTTag + | Tuple [Term] ADTTag + | Record Fields | WithRecord Term Fields | ProjField Term FieldName | ProjIdx Term Word @@ -199,8 +199,8 @@ 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.Record fields tag) = Record (map (\(f, t) -> (f, lower t)) fields) tag +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 lower (D.ProjIdx t idx) = ProjIdx (lower t) idx @@ -331,11 +331,11 @@ 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 tag) m = - (\x -> Record x tag) <$> mapM renameField fields +rename (Record fields) m = + Record <$> mapM renameField fields where renameField (f, t) = do t' <- rename t m return (f, t') @@ -439,22 +439,21 @@ 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: MissingADT" ppTerm' (List ts) = PP.brackets $ PP.hcat $ PP.punctuate (text ",") (map (ppTerm 0) ts) -ppTerm' (Record fs False) = PP.braces $ qqFields fs -ppTerm' (Record fs True) = -- We should not be able to git the "MissingADT" cases - 2025-08-08: ASL - case find (\x -> fst x == "tag") fs of - Just (_, Lit (LString nm)) -> text nm - Just _ -> text "MissingADT" - Nothing -> text "MissingADT" +ppTerm' (Record fs) = PP.braces $ qqFields fs ppTerm' (WithRecord e fs) = PP.braces $ PP.hsep [ ppTerm 0 e, text "with", qqFields fs] @@ -567,7 +566,7 @@ 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 3b864798..d67f4fd3 100644 --- a/compiler/src/Direct.hs +++ b/compiler/src/Direct.hs @@ -95,8 +95,8 @@ data Term | Let [Decl] Term | Case Term [(DeclPattern, Term)] PosInf | If Term Term Term - | Tuple [Term] - | Record Fields ADTTag + | Tuple [Term] ADTTag + | Record Fields | WithRecord Term Fields | ProjField Term FieldName | ProjIdx Term Word @@ -167,19 +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: MissingADT" -ppTerm' (Record fs False) = - PP.braces $ qqFields fs -ppTerm' (Record fs True) = -- We should not be able to git the "MissingADT" cases - 2025-08-08: ASL - case find (\x -> fst x == "tag") fs of - Just (_, Just (Lit (LString nm))) -> text nm - Just _ -> text "MissingADT" - Nothing -> text "MissingADT" - +ppTerm' (Record fs) = PP.braces $ qqFields fs ppTerm' (WithRecord t fs) = PP.braces $ PP.hsep [ppTerm 0 t, text "with", qqFields fs] @@ -366,7 +363,7 @@ ppLit (LDataType 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 3487e405..837a627e 100644 --- a/compiler/src/DirectWOPats.hs +++ b/compiler/src/DirectWOPats.hs @@ -52,8 +52,8 @@ data Term | Let [Decl] Term | If Term Term Term | AssertElseError Term Term Term PosInf - | Tuple [Term] - | Record Fields ADTTag + | Tuple [Term] ADTTag + | Record Fields | WithRecord Term Fields | ProjField Term FieldName | ProjIdx Term Word diff --git a/compiler/src/Parser.y b/compiler/src/Parser.y index 4eb26071..b998a2d4 100644 --- a/compiler/src/Parser.y +++ b/compiler/src/Parser.y @@ -240,8 +240,8 @@ Atom : '(' Expr ')' { $2 } | Lit { Lit $1 } | VAR { Var (varTok $1) } | '(' ')' { Lit LUnit } - | '(' CSExpr Expr ')' { Tuple (reverse ($3:$2)) } - | '{' '}' { Record [] False } + | '(' CSExpr Expr ')' { Tuple (reverse ($3:$2)) False } + | '{' '}' { Record [] } | RecordExpr { $1 } | ListExpr { $1 } | Atom '.' VAR { ProjField $1 (varTok $3) } @@ -249,7 +249,7 @@ Atom : '(' Expr ')' { $2 } RecordExpr - : '{' RecordFields '}' { Record $2 False } + : '{' RecordFields '}' { Record $2 } | '{' Atom with RecordFields'}' { WithRecord $2 $4 } diff --git a/compiler/src/RetDFCPS.hs b/compiler/src/RetDFCPS.hs index 5ff2c54f..eccbfb37 100644 --- a/compiler/src/RetDFCPS.hs +++ b/compiler/src/RetDFCPS.hs @@ -124,18 +124,18 @@ 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) ) -transExplicit (Core.Record fields tag) = - transFieldsExplicit (\fds -> Record fds tag) fields +transExplicit (Core.Record fields) = + transFieldsExplicit Record fields transExplicit (Core.WithRecord e fields) = trans e (\x -> transFieldsExplicit (WithRecord x) fields) From 1ba80b86d71fcbd90d4de264d56f9e0c48507851 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Sun, 21 Sep 2025 19:09:34 +0200 Subject: [PATCH 17/30] Refactored implementation of ADTs to use tuples instead of records. --- compiler/src/AtomFolding.hs | 17 +++++----- compiler/src/CPSOpt.hs | 32 +++++++++--------- compiler/src/CaseElimination.hs | 14 ++++---- compiler/src/ClosureConv.hs | 8 ++--- compiler/src/DirectWOPats.hs | 16 ++++----- compiler/src/Exports.hs | 2 +- compiler/src/IR.hs | 8 ++--- compiler/src/IR2Raw.hs | 8 ++--- compiler/src/IROpt.hs | 14 ++++---- compiler/src/Raw.hs | 8 ++--- compiler/src/RawDefUse.hs | 4 +-- compiler/src/RawOpt.hs | 8 ++--- compiler/src/RetCPS.hs | 8 ++--- compiler/src/RetDFCPS.hs | 6 ++-- compiler/src/RetFreeVars.hs | 4 +-- compiler/src/RetRewrite.hs | 4 +-- compiler/src/Stack2JS.hs | 10 +++--- compiler/test/ir2raw-test/testcases/Expr.hs | 12 +++---- compiler/test/ir2raw-test/testcases/Tree.hs | 2 +- rt/src/MailboxProcessor.mts | 2 +- rt/src/RawTuple.mts | 16 +++++++-- rt/src/Record.mts | 37 +++++++-------------- rt/src/Scheduler.mts | 4 +-- rt/src/ValuesUtil.mts | 4 +-- rt/src/builtins/listToTuple.mts | 2 +- rt/src/builtins/sandbox.mts | 2 +- rt/src/deserialize.mts | 4 +-- rt/src/runtimeMonitored.mts | 2 +- rt/src/serialize.mts | 6 ++-- 29 files changed, 131 insertions(+), 133 deletions(-) diff --git a/compiler/src/AtomFolding.hs b/compiler/src/AtomFolding.hs index ffe51a4c..ef1ea94e 100644 --- a/compiler/src/AtomFolding.hs +++ b/compiler/src/AtomFolding.hs @@ -18,10 +18,10 @@ visitTerm atms (Var nm) = var = "v" in case find (\x -> (fst x) == nm) atms of Nothing -> Var nm - Just (t, []) -> Record [(tag, Just (Lit (LString nm)))] True -- Convert atom into a tagged record + Just (t, []) -> Tuple [Lit (LString nm)] True -- Convert atom into a tuple Just (t, _) -> - Abs (Lambda [VarPattern var] (Record [(tag, Just (Lit (LString nm))) - , (value, Just (Var var)) + Abs (Lambda [VarPattern var] (Tuple [ Lit (LString nm) + , Var var ] True)) visitTerm atms (Abs lam) = Abs (visitLambda atms lam) @@ -44,9 +44,9 @@ visitTerm atms (Case t declTermList p) = 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 tag) = Record (visitFields atms fields) tag +visitTerm atms (Tuple terms tag) = + Tuple (map (visitTerm atms) terms) tag +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) = @@ -74,7 +74,7 @@ visitFields atms fs = map visitField fs visitPattern :: [TypeConstructor] -> DeclPattern -> DeclPattern visitPattern atms pat@(VarPattern nm) = if any (\x -> x == (nm, [])) atms - then RecordPattern [("tag", Just (ValPattern (LString nm)))] ExactMatch -- Convert atom match into a record match + then TuplePattern [ValPattern (LString nm)] -- Convert atom match into a record match else pat visitPattern _ pat@(ValPattern _) = pat visitPattern atms (AtPattern p l) = AtPattern (visitPattern atms p) l @@ -86,8 +86,7 @@ visitPattern atms (RecordPattern fields mode) = RecordPattern (map visitField fi where visitField pat@(_, Nothing) = pat visitField (f, Just p) = (f, Just (visitPattern atms p)) visitPattern atms (DataTypePattern nm pat) = - RecordPattern [("tag", Just (ValPattern (LString nm))) - ,("value", Just (visitPattern atms pat))] ExactMatch + TuplePattern [ ValPattern (LString nm), visitPattern atms pat] visitLambda :: [TypeConstructor] -> Lambda -> Lambda diff --git a/compiler/src/CPSOpt.hs b/compiler/src/CPSOpt.hs index b7028ed3..ebe02fb1 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 tag -> Record (fwdFields fields) tag + 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,8 +145,8 @@ instance CensusCollectible SimpleTerm where Bin _ v1 v2 -> updateCensus [v1,v2] Un _ v -> updateCensus v ValSimpleTerm sv -> updateCensus sv - Tuple vs -> updateCensus vs - Record fs _ -> let (_,vs) = unzip fs in 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 ProjIdx v _ -> updateCensus v @@ -256,14 +256,14 @@ censusInfo x = do fields x = do w <- look x case w of - St (Record xs _) -> return xs + St (Record xs) -> return xs St (WithRecord y ys) -> do xs <- fields y return $ xs ++ ys _ -> return [] -isRecordTerm (St (Record _ _)) = True +isRecordTerm (St (Record _)) = True isRecordTerm (St (WithRecord _ _ )) = True isRecordTerm _ = False @@ -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,8 +409,8 @@ 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 - Record _ _ -> True + Tuple _ _ -> True + Record _ -> True WithRecord _ _ -> True ProjField _ _ -> False -- Field projection can fail if field doesn't exist ProjIdx _ _ -> False -- Index projection can fail if index out of bounds diff --git a/compiler/src/CaseElimination.hs b/compiler/src/CaseElimination.hs index ecd753a9..8e32df3e 100644 --- a/compiler/src/CaseElimination.hs +++ b/compiler/src/CaseElimination.hs @@ -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 @@ -211,7 +211,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,12 +257,12 @@ 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') -transTerm (S.Record fields tag) = do + return (T.Tuple tms' tag) +transTerm (S.Record fields) = do fields' <- transFields fields - return (T.Record fields' tag) + return (T.Record fields') transTerm (S.WithRecord e fields) = do e' <- transTerm e fields' <- transFields fields diff --git a/compiler/src/ClosureConv.hs b/compiler/src/ClosureConv.hs index ced98840..44543f9f 100644 --- a/compiler/src/ClosureConv.hs +++ b/compiler/src/ClosureConv.hs @@ -162,12 +162,12 @@ 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') - CPS.Record fields tag -> do + _assign (Tuple lst' tag) + CPS.Record fields -> do fields' <- transFields fields - _assign (Record fields' tag) + _assign (Record fields') CPS.WithRecord x fields -> do x' <- transVar x fields' <- transFields fields diff --git a/compiler/src/DirectWOPats.hs b/compiler/src/DirectWOPats.hs index 837a627e..990ffeda 100644 --- a/compiler/src/DirectWOPats.hs +++ b/compiler/src/DirectWOPats.hs @@ -114,18 +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: MissingADT" -ppTerm' (Record fs False) = - PP.braces $ qqFields fs -ppTerm' (Record fs True) = -- We should not be able to git the "MissingADT" cases - 2025-08-08: ASL - case find (\x -> fst x == "tag") fs of - Just (_, Lit (LString nm)) -> text nm - Just _ -> text "MissingADT" - Nothing -> text "MissingADT" +ppTerm' (Record fs) = PP.braces $ qqFields fs ppTerm' (WithRecord e fs) = PP.braces $ PP.hsep [ ppTerm 0 e, text "with", qqFields fs ] @@ -235,7 +233,7 @@ ppLit (LDataType 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 eb31c92b..0a4cf2de 100644 --- a/compiler/src/IR.hs +++ b/compiler/src/IR.hs @@ -52,8 +52,8 @@ type Fields = [(Basics.FieldName, VarAccess)] data IRExpr = Bin Basics.BinOp VarAccess VarAccess | Un Basics.UnaryOp VarAccess - | Tuple [VarAccess] - | Record Fields Basics.ADTTag + | Tuple [VarAccess] Basics.ADTTag + | Record Fields | WithRecord VarAccess Fields | ProjField VarAccess Basics.FieldName -- | Projection of a tuple field at the given index. The maximum allowed index @@ -404,7 +404,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) @@ -416,7 +416,7 @@ ppIRExpr (Base v) = if v == "$$authorityarg" -- special casing; hack; 2018-10-18 then text v else text v <> text "$base" ppIRExpr (Lib (Basics.LibName l) v) = text l <> text "." <> text v -ppIRExpr (Record fields _) = PP.braces $ qqFields fields +ppIRExpr (Record fields) = PP.braces $ qqFields fields ppIRExpr (WithRecord x fields) = PP.braces $ PP.hsep[ ppId x, text "with", qqFields fields] ppIRExpr (ProjField x f) = (ppId x) PP.<> PP.text "." PP.<> PP.text f diff --git a/compiler/src/IR2Raw.hs b/compiler/src/IR2Raw.hs index b5faf8bb..158c505f 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 } @@ -428,9 +428,9 @@ expr2rawComp = \case , cValLbl = PC , cTyLbl = PC } - IR.Record fs tag -> + IR.Record fs -> return SimpleRawComp - { cVal = RExpr $ Record fs tag + { cVal = RExpr $ Record fs , cValLbl = PC , cTyLbl = PC } diff --git a/compiler/src/IROpt.hs b/compiler/src/IROpt.hs index f318b81b..e2edff16 100644 --- a/compiler/src/IROpt.hs +++ b/compiler/src/IROpt.hs @@ -37,8 +37,8 @@ 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) - Record fields tag -> Record (_ff fields) tag + 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 ProjIdx x idx -> ProjIdx (apply subst x) idx @@ -193,8 +193,8 @@ canFailOrHasEffects expr = case expr of Lib _ _ -> True -- These are generally safe - Tuple _ -> False - Record _ _ -> False + Tuple _ _ -> False + Record _ -> False WithRecord _ _ -> False -- Assuming the base is a record List _ -> False Const _ -> False @@ -295,8 +295,8 @@ irExprPeval e = markUsed' x markUsed' y def_ - Record fields _tag -> 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) diff --git a/compiler/src/Raw.hs b/compiler/src/Raw.hs index afd449f5..1f223ed3 100644 --- a/compiler/src/Raw.hs +++ b/compiler/src/Raw.hs @@ -103,8 +103,8 @@ data RawExpr | Un Basics.UnaryOp RawVar | ProjectLVal VarAccess LValField | ProjectState MonComponent - | Tuple [VarAccess] - | Record Fields Basics.ADTTag + | Tuple [VarAccess] Basics.ADTTag + | Record Fields | WithRecord RawVar Fields | ProjField RawVar Basics.FieldName | ProjIdx RawVar Word @@ -278,7 +278,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) @@ -290,7 +290,7 @@ ppRawExpr (Const lit) = ppLit lit -- then text v -- else text v <> text "$base" ppRawExpr (Lib (Basics.LibName l) v) = text l <> text "." <> text v -ppRawExpr (Record fields _) = PP.braces $ qqFields fields +ppRawExpr (Record fields) = PP.braces $ qqFields fields ppRawExpr (WithRecord x fields) = PP.braces $ PP.hsep[ ppId x, text "with", qqFields fields] ppRawExpr (ProjField x f) = PP.text "ProjField" PP.<+> (ppId x) PP.<+> PP.text f diff --git a/compiler/src/RawDefUse.hs b/compiler/src/RawDefUse.hs index 39845dc3..c22128b7 100644 --- a/compiler/src/RawDefUse.hs +++ b/compiler/src/RawDefUse.hs @@ -196,8 +196,8 @@ instance Usable RawExpr b where Raw.Un _ x -> use x Raw.ProjectLVal x _ -> use x Raw.ProjectState _ -> return () - Raw.Tuple xs -> use xs - Raw.Record fields _ -> use (snd (unzip fields)) + Raw.Tuple xs _ -> use xs + Raw.Record fields -> use (snd (unzip fields)) Raw.WithRecord x fields -> do use x use (snd (unzip fields)) diff --git a/compiler/src/RawOpt.hs b/compiler/src/RawOpt.hs index 372b05fb..da7d146d 100644 --- a/compiler/src/RawOpt.hs +++ b/compiler/src/RawOpt.hs @@ -146,8 +146,8 @@ instance MarkUsed RawExpr where Un _ x -> markUsed x ProjectLVal x _ -> markUsed x ProjectState _ -> return () - Tuple xs -> markUsed xs - Record fields _ -> markUsed (snd (unzip fields)) + Tuple xs _ -> markUsed xs + Record fields -> markUsed (snd (unzip fields)) WithRecord x fields -> do markUsed x markUsed (snd (unzip fields)) @@ -241,10 +241,10 @@ guessType = \case Basics.Tail -> Nothing Basics.LevelOf -> Just RawLevel - Tuple _ -> Just RawTuple + Tuple _ _ -> Just RawTuple List _ -> Just RawList ListCons _ _ -> Just RawList - Record _ _ -> Just RawRecord + Record _ -> Just RawRecord WithRecord _ _ -> Just RawRecord -- Revision 2023-08: Added missing cases ProjField _ _ -> Nothing diff --git a/compiler/src/RetCPS.hs b/compiler/src/RetCPS.hs index ab9c3736..6af64d58 100644 --- a/compiler/src/RetCPS.hs +++ b/compiler/src/RetCPS.hs @@ -60,8 +60,8 @@ data SimpleTerm = Bin BinOp VarName VarName | Un UnaryOp VarName | ValSimpleTerm SVal - | Tuple [VarName] - | Record Fields Basics.ADTTag + | Tuple [VarName] Basics.ADTTag + | Record Fields | WithRecord VarName Fields | ProjField VarName Basics.FieldName | ProjIdx VarName Word @@ -141,7 +141,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 +149,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] diff --git a/compiler/src/RetDFCPS.hs b/compiler/src/RetDFCPS.hs index eccbfb37..26932ca2 100644 --- a/compiler/src/RetDFCPS.hs +++ b/compiler/src/RetDFCPS.hs @@ -258,17 +258,17 @@ 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) -trans (Core.Record fields tag) context = transFields (\fds -> Record fds tag) fields context +trans (Core.Record fields) context = transFields Record fields context trans (Core.WithRecord e fields) context = trans e (\ rr -> transFields (WithRecord rr) fields context ) diff --git a/compiler/src/RetFreeVars.hs b/compiler/src/RetFreeVars.hs index ade6ee4f..a938d539 100644 --- a/compiler/src/RetFreeVars.hs +++ b/compiler/src/RetFreeVars.hs @@ -51,12 +51,12 @@ 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 freeVars (Lib _ _) = FreeVars $ Set.empty - freeVars (Record fields _) = unionMany $ + freeVars (Record fields) = unionMany $ map (\(f,x) -> FreeVars (if x == VN f then Set.empty else Set.singleton x)) fields freeVars (WithRecord x fields) = diff --git a/compiler/src/RetRewrite.hs b/compiler/src/RetRewrite.hs index 82d1e298..8a01e22c 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 tag -> Record (fwdFields fields) tag + 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 diff --git a/compiler/src/Stack2JS.hs b/compiler/src/Stack2JS.hs index 0dcf3789..b30ade29 100644 --- a/compiler/src/Stack2JS.hs +++ b/compiler/src/Stack2JS.hs @@ -589,12 +589,14 @@ 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)) - Record fields tag -> do + 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.hsep [PP.brackets $ PP.hsep $ jsFields, text ",", tagToJS tag]) + 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 diff --git a/compiler/test/ir2raw-test/testcases/Expr.hs b/compiler/test/ir2raw-test/testcases/Expr.hs index 44e9a2b3..76f8d00a 100644 --- a/compiler/test/ir2raw-test/testcases/Expr.hs +++ b/compiler/test/ir2raw-test/testcases/Expr.hs @@ -24,15 +24,15 @@ 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"]) - , ("Record0", Record [] False) - , ("Record1", Record [("field1", mkV "v1")] False) - , ("Record2", Record [("field1", mkV "v1"), ("field2", mkV "v2")] False) + , ("Record0", Record []) + , ("Record1", Record [("field1", mkV "v1")]) + , ("Record2", Record [("field1", mkV "v1"), ("field2", mkV "v2")]) , ("ListCons", ListCons (mkV "x") (mkV "xs")) , ("WithRecord0", WithRecord (mkV "x") []) , ("WithRecord1", WithRecord (mkV "x") [("field1", mkV "v1")]) diff --git a/compiler/test/ir2raw-test/testcases/Tree.hs b/compiler/test/ir2raw-test/testcases/Tree.hs index d57f0a4a..9e2212ac 100644 --- a/compiler/test/ir2raw-test/testcases/Tree.hs +++ b/compiler/test/ir2raw-test/testcases/Tree.hs @@ -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/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..7ca0b91e 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; + _isADT: boolean; - constructor(x: LVal[]) { + constructor(x: LVal[], isADT: boolean) { super(...x) + this._isADT = isADT; this.stringRep = function (omitLevels = false, taintRef = null) { - return ("(" + listStringRep(x, omitLevels, taintRef) + ")"); + if (this._isADT) { + 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 950b4183..45dd2341 100644 --- a/rt/src/Record.mts +++ b/rt/src/Record.mts @@ -10,33 +10,20 @@ export class Record implements TroupeAggregateRawValue { _troupeType = TroupeType.RECORD _dataLevel: Level = levels.TOP // TODO compute data level? __obj : Map - _isADT: boolean stringRep (omitLevels?: boolean, taintRef?: any) { - if (this._isADT) { - if (this.__obj.has("value")) { - let tag = this.__obj.get("tag").val.toString() - let val = this.__obj.get("value").stringRep(omitLevels, taintRef) - return "(" + tag + " " + val + ")" - } else { - return this.__obj.get("tag").val.toString() - } - } else { - // 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 += "}" - return s - } + let s = "{" + let spaceOrComma = "" + for (let [k,v] of this.__obj.entries()) { + s += spaceOrComma + k + "=" + v.stringRep(omitLevels, taintRef) + spaceOrComma = ", " + } + s += "}" + return s } - constructor(fields: Iterable, isADT: boolean) { + constructor(fields: Iterable) { this.__obj = new Map (fields) - this._isADT = isADT } hasField (fieldName:string):boolean { @@ -51,13 +38,13 @@ export class Record implements TroupeAggregateRawValue { return this._dataLevel } - static mkRecord(fields: Iterable, isADT): Record { - return new Record(fields, isADT) + static mkRecord(fields: Iterable): Record { + return new Record(fields) } static mkWithRecord(r: Record, fields: ConcatArray<[string, LVal]>): Record { let a = Array.from(r.__obj) let b = a.concat(fields) - return new Record(b, false) + return new Record(b) } } 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..a8444b0c 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[], isADT: boolean) { + return new RawTuple(x, isADT) } 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/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 78b57b2d..24848410 100644 --- a/rt/src/deserialize.mts +++ b/rt/src/deserialize.mts @@ -246,11 +246,11 @@ function constructCurrent(compilerOutput: string) { for (let i = 0; i < obj.fields.length; i++) { a.push ([ obj.fields[i][0], mkValue(obj.fields[i][1]) ]) } - return Record.mkRecord(a, obj.isADT); // 2025-08-08 ASL: This is a place holder + 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.isADT) case Ty.TroupeType.CLOSURE: return mkClosure(obj.ClosureID) case Ty.TroupeType.NUMBER: diff --git a/rt/src/runtimeMonitored.mts b/rt/src/runtimeMonitored.mts index 4a319a1e..1c54578c 100644 --- a/rt/src/runtimeMonitored.mts +++ b/rt/src/runtimeMonitored.mts @@ -510,7 +510,7 @@ export async function start(f) { if (__p2pRunning) { let service_arg = new LVal ( new Record([ ["authority", mainAuthority], - ["options", __unit]], false), + ["options", __unit]]), levels.BOT); __sched.scheduleNewThreadAtLevel(__service['service'] , service_arg diff --git a/rt/src/serialize.mts b/rt/src/serialize.mts index 93725f53..47197be3 100644 --- a/rt/src/serialize.mts +++ b/rt/src/serialize.mts @@ -72,7 +72,7 @@ export function serialize(w:LVal, pclev:Level) { switch (_tt) { case Ty.TroupeType.RECORD: - jsonObj = { fields: [], isADT: x._isADT }; + jsonObj = { fields: [] }; for (let [k,v] of x.__obj.entries()) { jsonObj.fields.push ([k, walk(v)]) } @@ -86,9 +86,9 @@ export function serialize(w:LVal, pclev:Level) { } break; case Ty.TroupeType.TUPLE: - jsonObj = []; + jsonObj = { vals: [], isADT: x._isADT }; for (let i = 0; i < x.length; i++) { - jsonObj.push(walk(x[i])); + jsonObj.vals.push(walk(x[i])); } break; case Ty.TroupeType.CLOSURE: From 906dc930a46341c5dcdbbb6e5483ab06cbed8b2c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Sun, 28 Sep 2025 19:45:34 +0200 Subject: [PATCH 18/30] Changed the name of ADTTag datatype to SynVariantTag in the compiler --- compiler/src/Basics.hs | 2 +- compiler/src/Core.hs | 4 ++-- compiler/src/Direct.hs | 4 ++-- compiler/src/DirectWOPats.hs | 4 ++-- compiler/src/IR.hs | 2 +- compiler/src/Raw.hs | 2 +- compiler/src/RetCPS.hs | 2 +- 7 files changed, 10 insertions(+), 10 deletions(-) diff --git a/compiler/src/Basics.hs b/compiler/src/Basics.hs index 067dee4c..5525bbdd 100644 --- a/compiler/src/Basics.hs +++ b/compiler/src/Basics.hs @@ -15,7 +15,7 @@ type TypeConstructorName = String type TypeConstructor = (TypeConstructorName, [VarName]) type DataTypeDef = (DataTypeName, [TypeConstructor]) type FieldName = String -type ADTTag = Bool +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/Core.hs b/compiler/src/Core.hs index c0265ab8..c6787e9d 100644 --- a/compiler/src/Core.hs +++ b/compiler/src/Core.hs @@ -108,7 +108,7 @@ data Term | Let Decl Term | If Term Term Term | AssertElseError Term Term Term PosInf - | Tuple [Term] ADTTag + | Tuple [Term] SynVariantTag | Record Fields | WithRecord Term Fields | ProjField Term FieldName @@ -446,7 +446,7 @@ ppTerm' (Tuple ts False) = 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: MissingADT" + otherwise -> text "error: Missing syntactic variant" ppTerm' (List ts) = PP.brackets $ diff --git a/compiler/src/Direct.hs b/compiler/src/Direct.hs index d67f4fd3..784b6535 100644 --- a/compiler/src/Direct.hs +++ b/compiler/src/Direct.hs @@ -95,7 +95,7 @@ data Term | Let [Decl] Term | Case Term [(DeclPattern, Term)] PosInf | If Term Term Term - | Tuple [Term] ADTTag + | Tuple [Term] SynVariantTag | Record Fields | WithRecord Term Fields | ProjField Term FieldName @@ -174,7 +174,7 @@ ppTerm' (Tuple ts False) = 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: MissingADT" + otherwise -> text "error: Missing syntactiv variant" ppTerm' (Record fs) = PP.braces $ qqFields fs diff --git a/compiler/src/DirectWOPats.hs b/compiler/src/DirectWOPats.hs index 990ffeda..fe9791f3 100644 --- a/compiler/src/DirectWOPats.hs +++ b/compiler/src/DirectWOPats.hs @@ -52,7 +52,7 @@ data Term | Let [Decl] Term | If Term Term Term | AssertElseError Term Term Term PosInf - | Tuple [Term] ADTTag + | Tuple [Term] SynVariantTag | Record Fields | WithRecord Term Fields | ProjField Term FieldName @@ -121,7 +121,7 @@ ppTerm' (Tuple ts False) = 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: MissingADT" + otherwise -> text "error: Missing syntactiv variant" ppTerm' (Record fs) = PP.braces $ qqFields fs diff --git a/compiler/src/IR.hs b/compiler/src/IR.hs index 0a4cf2de..f43506e0 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] Basics.ADTTag + | Tuple [VarAccess] Basics.SynVariantTag | Record Fields | WithRecord VarAccess Fields | ProjField VarAccess Basics.FieldName diff --git a/compiler/src/Raw.hs b/compiler/src/Raw.hs index 1f223ed3..8f5a132b 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] Basics.ADTTag + | Tuple [VarAccess] Basics.SynVariantTag | Record Fields | WithRecord RawVar Fields | ProjField RawVar Basics.FieldName diff --git a/compiler/src/RetCPS.hs b/compiler/src/RetCPS.hs index 6af64d58..46a2b333 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] Basics.ADTTag + | Tuple [VarName] Basics.SynVariantTag | Record Fields | WithRecord VarName Fields | ProjField VarName Basics.FieldName From 901044db9f38b51cb2de8f8ca01ce8e6b59f90fa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Sun, 28 Sep 2025 19:57:33 +0200 Subject: [PATCH 19/30] updated runtime to use SynVariant naming instead of ADT. --- rt/src/RawTuple.mts | 8 ++++---- rt/src/ValuesUtil.mts | 4 ++-- rt/src/deserialize.mts | 2 +- rt/src/serialize.mts | 2 +- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/rt/src/RawTuple.mts b/rt/src/RawTuple.mts index 7ca0b91e..a75b612b 100644 --- a/rt/src/RawTuple.mts +++ b/rt/src/RawTuple.mts @@ -9,13 +9,13 @@ export class RawTuple extends Array implements TroupeAggregateRawValue { _troupeType = TroupeType.TUPLE; isTuple = true; stringRep = null; - _isADT: boolean; + _isSynVariant: boolean; - constructor(x: LVal[], isADT: boolean) { + constructor(x: LVal[], isSynVariant: boolean) { super(...x) - this._isADT = isADT; + this._isSynVariant = isSynVariant; this.stringRep = function (omitLevels = false, taintRef = null) { - if (this._isADT) { + if (this._isSynVariant) { if (this.length === 2) { let tag = this[0].val.toString() let val = this[1].stringRep(omitLevels, taintRef) diff --git a/rt/src/ValuesUtil.mts b/rt/src/ValuesUtil.mts index a8444b0c..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[], isADT: boolean) { - return new RawTuple(x, isADT) +export function mkTuple(x: LVal[], isSynVariant: boolean) { + return new RawTuple(x, isSynVariant) } diff --git a/rt/src/deserialize.mts b/rt/src/deserialize.mts index 24848410..4433382f 100644 --- a/rt/src/deserialize.mts +++ b/rt/src/deserialize.mts @@ -250,7 +250,7 @@ function constructCurrent(compilerOutput: string) { case Ty.TroupeType.LIST: return mkList(deserializeArray(obj)) case Ty.TroupeType.TUPLE: - return mkTuple(deserializeArray(obj.vals), obj.isADT) + return mkTuple(deserializeArray(obj.vals), obj.isSynVariant) case Ty.TroupeType.CLOSURE: return mkClosure(obj.ClosureID) case Ty.TroupeType.NUMBER: diff --git a/rt/src/serialize.mts b/rt/src/serialize.mts index 47197be3..3e8e9c35 100644 --- a/rt/src/serialize.mts +++ b/rt/src/serialize.mts @@ -86,7 +86,7 @@ export function serialize(w:LVal, pclev:Level) { } break; case Ty.TroupeType.TUPLE: - jsonObj = { vals: [], isADT: x._isADT }; + jsonObj = { vals: [], isSynVariant: x._isSynVariant }; for (let i = 0; i < x.length; i++) { jsonObj.vals.push(walk(x[i])); } From cc8973562a37a0899dd80aeb800e0f0ba7cb5e87 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Sun, 28 Sep 2025 21:32:44 +0200 Subject: [PATCH 20/30] Renamed DataType to SyntacticVariant --- compiler/src/AtomFolding.hs | 12 +++---- compiler/src/Basics.hs | 8 ++--- compiler/src/CaseElimination.hs | 6 ++-- compiler/src/Core.hs | 8 ++--- compiler/src/Direct.hs | 26 ++++++++-------- compiler/src/DirectWOPats.hs | 20 ++++++------ compiler/src/Parser.y | 55 +++++++++++++++++---------------- 7 files changed, 69 insertions(+), 66 deletions(-) diff --git a/compiler/src/AtomFolding.hs b/compiler/src/AtomFolding.hs index ef1ea94e..49e8c7cb 100644 --- a/compiler/src/AtomFolding.hs +++ b/compiler/src/AtomFolding.hs @@ -6,11 +6,11 @@ import Control.Monad import Data.List (find, any) visitProg :: Prog -> Prog -visitProg (Prog imports (DataTypes datatypes) tm) = +visitProg (Prog imports (SyntacticVariants datatypes) tm) = let tcs = concat $ map snd datatypes - in Prog imports (DataTypes datatypes) (visitTerm tcs tm) + in Prog imports (SyntacticVariants datatypes) (visitTerm tcs tm) -visitTerm :: [TypeConstructor] -> Term -> Term +visitTerm :: [SyntacticVariantConstructor] -> Term -> Term visitTerm atms (Lit lit) = Lit lit visitTerm atms (Var nm) = let tag = "tag" @@ -71,7 +71,7 @@ visitFields atms fs = map visitField fs where visitField (f, Nothing) = (f, Nothing) visitField (f, Just t) = (f, Just (visitTerm atms t)) -visitPattern :: [TypeConstructor] -> DeclPattern -> DeclPattern +visitPattern :: [SyntacticVariantConstructor] -> DeclPattern -> DeclPattern visitPattern atms pat@(VarPattern nm) = if any (\x -> x == (nm, [])) atms then TuplePattern [ValPattern (LString nm)] -- Convert atom match into a record match @@ -85,11 +85,11 @@ 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)) -visitPattern atms (DataTypePattern nm pat) = +visitPattern atms (SyntacticVariantPattern nm pat) = TuplePattern [ ValPattern (LString nm), visitPattern atms pat] -visitLambda :: [TypeConstructor] -> Lambda -> Lambda +visitLambda :: [SyntacticVariantConstructor] -> 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 5525bbdd..f1f32b0b 100644 --- a/compiler/src/Basics.hs +++ b/compiler/src/Basics.hs @@ -10,10 +10,10 @@ import Data.Serialize (Serialize) type VarName = String type AtomName = String -type DataTypeName = String -type TypeConstructorName = String -type TypeConstructor = (TypeConstructorName, [VarName]) -type DataTypeDef = (DataTypeName, [TypeConstructor]) +type SyntacticVariantName = String +type SyntacticVariantConstructorName = String +type SyntacticVariantConstructor = (SyntacticVariantConstructorName, [VarName]) +type SyntacticVariantDef = (SyntacticVariantName, [SyntacticVariantConstructor]) type FieldName = String type SynVariantTag = Bool diff --git a/compiler/src/CaseElimination.hs b/compiler/src/CaseElimination.hs index 8e32df3e..dc6c9117 100644 --- a/compiler/src/CaseElimination.hs +++ b/compiler/src/CaseElimination.hs @@ -31,8 +31,8 @@ trans mode (S.Prog imports atms tm) = do tm'' <- transTerm tm' return (T.Prog imports atms' tm'') -transAtoms :: S.DataTypes -> Trans T.DataTypes -transAtoms (S.DataTypes atms) = return (T.DataTypes atms) +transAtoms :: S.SyntacticVariants -> Trans T.SyntacticVariants +transAtoms (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.LDataType a) = T.LDataType a +transLit (S.LSyntacticVariant a) = T.LSyntacticVariant a transLambda_aux :: S.Lambda -> ReaderT T.Term Trans Lambda diff --git a/compiler/src/Core.hs b/compiler/src/Core.hs index c6787e9d..52eba047 100644 --- a/compiler/src/Core.hs +++ b/compiler/src/Core.hs @@ -58,7 +58,7 @@ data Lit | LDCLabel DCLabelExp | LUnit | LBool Bool - | LAtom TypeConstructorName + | LAtom SyntacticVariantConstructorName deriving (Show, Generic) instance Serialize Lit instance Eq Lit where @@ -158,8 +158,8 @@ lowerProg (D.Prog imports atms term) = Prog imports (trans atms) (lower term) -- the rest of the declarations in this part are not exported -trans :: D.DataTypes -> Atoms -trans (D.DataTypes atms) = Atoms [] -- (concat $ map snd atms) +trans :: D.SyntacticVariants -> Atoms +trans (D.SyntacticVariants atms) = Atoms [] -- (concat $ map snd atms) lowerLam (D.Lambda vs t) = case vs of @@ -173,7 +173,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.LDataType n) = LAtom n +lowerLit (D.LSyntacticVariant n) = LAtom n lower :: D.Term -> Core.Term lower (D.Lit l) = Lit (lowerLit l) diff --git a/compiler/src/Direct.hs b/compiler/src/Direct.hs index 784b6535..d4cb5d8b 100644 --- a/compiler/src/Direct.hs +++ b/compiler/src/Direct.hs @@ -5,9 +5,9 @@ module Direct ( Lambda (..) , Lit(..) , DeclPattern(..) , RecordPatternMode(..) - , DataTypeName - , TypeConstructor - , DataTypes(..) + , SyntacticVariantName + , SyntacticVariantConstructor + , SyntacticVariants(..) , Prog(..) , Handler(..) , FieldName @@ -59,7 +59,7 @@ data DeclPattern | ConsPattern DeclPattern DeclPattern --SrcPosInf | ListPattern [DeclPattern] --SrcPosInf | RecordPattern [(FieldName, Maybe DeclPattern)] RecordPatternMode - | DataTypePattern TypeConstructorName DeclPattern + | SyntacticVariantPattern SyntacticVariantConstructorName DeclPattern deriving (Eq) data RecordPatternMode = ExactMatch | WildcardMatch @@ -80,7 +80,7 @@ data Lit | LString String --SrcPosInf | LLabel String --SrcPosInf | LDCLabel DCLabelExp - | LDataType TypeConstructorName --SrcPosInf + | LSyntacticVariant SyntacticVariantConstructorName --SrcPosInf deriving (Eq, Show) @@ -108,11 +108,11 @@ data Term | Error Term deriving (Eq) -data DataTypes = DataTypes [DataTypeDef] +data SyntacticVariants = SyntacticVariants [SyntacticVariantDef] deriving (Eq, Show) -data Prog = Prog Imports DataTypes Term +data Prog = Prog Imports SyntacticVariants Term deriving (Eq, Show) @@ -132,8 +132,8 @@ instance ShowIndent Prog where ppProg :: Prog -> PP.Doc -ppProg (Prog (Imports imports) (DataTypes datatypes) term) = - let ppDataTypes = +ppProg (Prog (Imports imports) (SyntacticVariants datatypes) term) = + let ppSyntacticVariants = if null datatypes then PP.empty else vcat $ flip map datatypes (\dt -> (text "datatype ") <+> @@ -149,7 +149,7 @@ ppProg (Prog (Imports imports) (DataTypes datatypes) term) = in (vcat $ (map ppLibName imports)) $$ PP.text "" in vcat [ ppImports - , ppDataTypes + , ppSyntacticVariants , ppTerm 0 term ] @@ -345,9 +345,9 @@ ppDeclPattern (RecordPattern fields mode) = wildcard = case mode of ExactMatch -> [] WildcardMatch -> [text ".."] -ppDeclPattern (DataTypePattern nm pat) = +ppDeclPattern (SyntacticVariantPattern nm pat) = text nm PP.<> PP.space PP.<> - case pat of DataTypePattern _ _ -> PP.parens $ ppDeclPattern pat + case pat of SyntacticVariantPattern _ _ -> PP.parens $ ppDeclPattern pat otherwise -> ppDeclPattern pat ppLit :: Lit -> PP.Doc @@ -358,7 +358,7 @@ ppLit (LUnit ) = text "()" ppLit (LBool True ) = text "true" ppLit (LBool False) = text "false" ppLit (LLabel s ) = PP.braces (text s) -ppLit (LDataType s) = text s +ppLit (LSyntacticVariant s) = text s termPrec :: Term -> Precedence diff --git a/compiler/src/DirectWOPats.hs b/compiler/src/DirectWOPats.hs index fe9791f3..99d78702 100644 --- a/compiler/src/DirectWOPats.hs +++ b/compiler/src/DirectWOPats.hs @@ -3,9 +3,9 @@ module DirectWOPats ( Lambda (..) , Decl (..) , FunDecl (..) , Lit(..) - , DataTypeName - , TypeConstructor - , DataTypes(..) + , SyntacticVariantName + , SyntacticVariantConstructor + , SyntacticVariants(..) , Prog(..) ) where @@ -34,7 +34,7 @@ data Lit | LDCLabel DCLabelExp | LUnit | LBool Bool - | LDataType DataTypeName + | LSyntacticVariant SyntacticVariantName deriving (Eq, Show) @@ -64,10 +64,10 @@ data Term | Error Term PosInf deriving (Eq) -data DataTypes = DataTypes [DataTypeDef] +data SyntacticVariants = SyntacticVariants [SyntacticVariantDef] deriving (Eq, Show) -data Prog = Prog Imports DataTypes Term +data Prog = Prog Imports SyntacticVariants Term deriving (Eq, Show) @@ -86,8 +86,8 @@ instance ShowIndent Prog where ppProg :: Prog -> PP.Doc -ppProg (Prog (Imports imports) (DataTypes datatypes) term) = - let ppDataTypes = +ppProg (Prog (Imports imports) (SyntacticVariants datatypes) term) = + let ppSyntacticVariants = if null datatypes then PP.empty else vcat $ flip map datatypes (\dt -> (text "datatype ") <+> @@ -97,7 +97,7 @@ ppProg (Prog (Imports imports) (DataTypes datatypes) term) = 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 $$ ppDataTypes $$ ppTerm 0 term + in ppImports $$ ppSyntacticVariants $$ ppTerm 0 term ppTerm :: Precedence -> Term -> PP.Doc @@ -228,7 +228,7 @@ ppLit (LDCLabel dc) = ppDCLabelExpLit dc ppLit LUnit = text "()" ppLit (LBool True) = text "true" ppLit (LBool False) = text "false" -ppLit (LDataType a) = text a +ppLit (LSyntacticVariant a) = text a termPrec :: Term -> Precedence diff --git a/compiler/src/Parser.y b/compiler/src/Parser.y index b998a2d4..3cb69657 100644 --- a/compiler/src/Parser.y +++ b/compiler/src/Parser.y @@ -133,24 +133,27 @@ import Control.Monad.Except -Prog : ImportDecl DataTypeDecl Expr { Prog (Imports $1) (DataTypes $2) $3 } +Prog : ImportDecl SyntacticVariantDecl Expr { Prog (Imports $1) (SyntacticVariants $2) $3 } ImportDecl: import VAR ImportDecl { ((LibName (varTok $2), Nothing)): $3 } | { [] } -DataTypeDecl : datatype VAR '=' DataTypeConstructor DataTypeList DataTypeDecl { (varTok $2, $4:$5):$6 } +SyntacticVariantDecl : datatype VAR '=' + SyntacticVariantConstructor + SyntacticVariantList + SyntacticVariantDecl { (varTok $2, $4:$5):$6 } | {[]} -DataTypeList : { [] } - | '|' DataTypeConstructor DataTypeList { $2: $3 } +SyntacticVariantList : { [] } + | '|' SyntacticVariantConstructor SyntacticVariantList { $2: $3 } -DataTypeConstructor : VAR { (varTok $1, []) } - | VAR of DataTypeConstructorArgs { (varTok $1, $3) } +SyntacticVariantConstructor : VAR { (varTok $1, []) } + | VAR of SyntacticVariantConstructorArgs { (varTok $1, $3) } -DataTypeConstructorArgs : VAR { (varTok $1):[] } - | VAR '*' DataTypeConstructorArgs { (varTok $1):$3 } - | '(' DataTypeConstructorArgs ')' { $2 } +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 } @@ -160,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 } @@ -168,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 } @@ -189,18 +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 } - | DataTypePattern '=>' Expr { [($1,$3)] } - | DataTypePattern '=>' 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 } @@ -225,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 } @@ -272,8 +275,8 @@ ListExpr : '[' ']' { List [] } CSExpr : Expr ',' { [$1] } | CSExpr Expr ',' { ($2:$1) } -DataTypePattern : VAR Pattern { DataTypePattern (varTok $1) $2 } - | VAR '(' DataTypePattern ')' { DataTypePattern (varTok $1) $3 } +SyntacticVariantPattern : VAR Pattern { SyntacticVariantPattern (varTok $1) $2 } + | VAR '(' SyntacticVariantPattern ')' { SyntacticVariantPattern (varTok $1) $3 } Pattern : VAR { VarPattern (varTok $1) } | '(' Pattern ')' { $2 } @@ -313,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] } @@ -344,8 +347,8 @@ AndFunDecl : and VAR FunOptions { FunDecl (varTok $2) $3 (pos $2) } FunArgs : Pattern { [$1] } | Pattern FunArgs { $1 : $2} - | '(' DataTypePattern ')' { [$2] } - | '(' DataTypePattern ')' FunArgs { $2 : $4 } + | '(' SyntacticVariantPattern ')' { [$2] } + | '(' SyntacticVariantPattern ')' FunArgs { $2 : $4 } { From 94d3055350e5e66f054b6473c52efd85abf3e265 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Sun, 12 Oct 2025 15:42:51 +0200 Subject: [PATCH 21/30] renaming from Atom SyntacticVariant --- compiler/src/AtomFolding.hs | 12 +++--- compiler/src/Basics.hs | 1 - compiler/src/ClosureConv.hs | 10 ++--- compiler/src/Core.hs | 41 ++++++++++----------- compiler/src/IR.hs | 18 ++++----- compiler/src/IR2Raw.hs | 2 +- compiler/src/Raw.hs | 4 +- compiler/src/Raw2Stack.hs | 6 +-- compiler/src/RawDefUse.hs | 2 +- compiler/src/RawOpt.hs | 6 +-- compiler/src/RetCPS.hs | 10 ++--- compiler/src/RetFreeVars.hs | 2 +- compiler/src/Stack.hs | 4 +- compiler/src/Stack2JS.hs | 20 +++++----- compiler/test/ir2raw-test/testcases/Expr.hs | 2 +- compiler/test/ir2raw-test/testcases/Inst.hs | 2 +- compiler/test/ir2raw-test/testcases/TR.hs | 2 +- compiler/test/ir2raw-test/testcases/Tree.hs | 2 +- 18 files changed, 71 insertions(+), 75 deletions(-) diff --git a/compiler/src/AtomFolding.hs b/compiler/src/AtomFolding.hs index 49e8c7cb..0b5ca440 100644 --- a/compiler/src/AtomFolding.hs +++ b/compiler/src/AtomFolding.hs @@ -13,16 +13,14 @@ visitProg (Prog imports (SyntacticVariants datatypes) tm) = visitTerm :: [SyntacticVariantConstructor] -> Term -> Term visitTerm atms (Lit lit) = Lit lit visitTerm atms (Var nm) = - let tag = "tag" - value = "value" - var = "v" - in case find (\x -> (fst x) == nm) atms of + case find (\x -> (fst x) == nm) atms of Nothing -> Var nm Just (t, []) -> Tuple [Lit (LString nm)] True -- Convert atom into a tuple Just (t, _) -> - Abs (Lambda [VarPattern var] (Tuple [ Lit (LString nm) - , Var var - ] True)) + let var = "v" + in Abs (Lambda [VarPattern var] (Tuple [ Lit (LString nm) + , Var var + ] True)) visitTerm atms (Abs lam) = Abs (visitLambda atms lam) visitTerm atms (Hnd (Handler pat maybePat maybeTerm term)) = diff --git a/compiler/src/Basics.hs b/compiler/src/Basics.hs index f1f32b0b..d917c651 100644 --- a/compiler/src/Basics.hs +++ b/compiler/src/Basics.hs @@ -9,7 +9,6 @@ import GHC.Generics(Generic) import Data.Serialize (Serialize) type VarName = String -type AtomName = String type SyntacticVariantName = String type SyntacticVariantConstructorName = String type SyntacticVariantConstructor = (SyntacticVariantConstructorName, [VarName]) diff --git a/compiler/src/ClosureConv.hs b/compiler/src/ClosureConv.hs index 44543f9f..aaa111b6 100644 --- a/compiler/src/ClosureConv.hs +++ b/compiler/src/ClosureConv.hs @@ -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, C.SyntacticVariants, NestingLevel, Map VarName VarLevel, Maybe VarName) type Frees = [(VarName, NestingLevel)] type FunDefs = [CCIR.FunDef] type ConstEntry = (VarName, C.Lit) @@ -87,7 +87,7 @@ incLev fname (compileMode, atms, lev, vmap, _) = transVar :: VarName -> CC VarAccess transVar v@(VN vname) = do - (_, C.Atoms atms, lev, vmap, maybe_fname) <- ask + (_, C.SyntacticVariants atms, lev, vmap, maybe_fname) <- ask case maybe_fname of Just fname | fname == v -> return $ VarFunSelfRef _ -> @@ -263,8 +263,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 +closureConvert compileMode (CPS.Prog (C.SyntacticVariants atms) t) = + let atms' = C.SyntacticVariants atms initEnv = ( compileMode , atms' , 0 -- initial nesting counter @@ -282,7 +282,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 (C.SyntacticVariants atms) $ fdefs++[main] in do CCIR.wfIRProg irProg return irProg -- then irProg diff --git a/compiler/src/Core.hs b/compiler/src/Core.hs index 52eba047..7f008039 100644 --- a/compiler/src/Core.hs +++ b/compiler/src/Core.hs @@ -7,9 +7,8 @@ module Core ( Lambda (..) , Decl (..) , FunDecl (..) , Lit(..) - , AtomName - , Atoms(..) , Prog(..) + , SyntacticVariants(..) , VarAccess(..) , lowerProg , renameProg @@ -58,7 +57,7 @@ data Lit | LDCLabel DCLabelExp | LUnit | LBool Bool - | LAtom SyntacticVariantConstructorName + | LSynVar SyntacticVariantConstructorName deriving (Show, Generic) instance Serialize Lit instance Eq Lit where @@ -67,7 +66,7 @@ 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 + (LSynVar x) == (LSynVar y) = x == y (LDCLabel dc) == (LDCLabel dc') = dc == dc' _ == _ = False instance Ord Lit where @@ -76,15 +75,15 @@ 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 + (LSynVar x) <= (LSynVar 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 + (LBool _) <= (LSynVar _) = True + (LSynVar _) <= (LDCLabel _) = True + _ <= _ = False instance GetPosInfo Lit where posInfo (LInt _ p) = p @@ -121,12 +120,12 @@ data Term deriving (Eq) -data Atoms = Atoms [AtomName] +data SyntacticVariants = SyntacticVariants [SyntacticVariantName] deriving (Eq, Show, Generic) -instance Serialize Atoms +instance Serialize SyntacticVariants -data Prog = Prog Imports Atoms Term +data Prog = Prog Imports SyntacticVariants Term deriving (Eq, Show) @@ -158,8 +157,8 @@ lowerProg (D.Prog imports atms term) = Prog imports (trans atms) (lower term) -- the rest of the declarations in this part are not exported -trans :: D.SyntacticVariants -> Atoms -trans (D.SyntacticVariants atms) = Atoms [] -- (concat $ map snd atms) +trans :: D.SyntacticVariants -> SyntacticVariants +trans (D.SyntacticVariants atms) = SyntacticVariants [] -- (concat $ map snd atms) lowerLam (D.Lambda vs t) = case vs of @@ -173,7 +172,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.LSyntacticVariant n) = LAtom n +lowerLit (D.LSyntacticVariant n) = LSynVar n lower :: D.Term -> Core.Term lower (D.Lit l) = Lit (lowerLit l) @@ -222,13 +221,13 @@ 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) = +renameProg (Prog imports (SyntacticVariants atms) term) = let alist = map (\ a -> (a, a)) atms initEnv = Map.fromList alist initReader = mapFromImports imports initState = 0 (term', _) = evalRWS (rename term initEnv) initReader initState - in Prog imports (Atoms atms) term' + in Prog imports (SyntacticVariants atms) term' -- The rest of the declarations here are not exported @@ -414,15 +413,15 @@ instance ShowIndent Prog where ppProg :: Prog -> PP.Doc -ppProg (Prog (Imports imports) (Atoms atoms) term) = - let ppAtoms = +ppProg (Prog (Imports imports) (SyntacticVariants atoms) term) = + let ppSyntacticVariants = 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 + in ppImports $$ ppSyntacticVariants $$ ppTerm 0 term ppTerm :: Precedence -> Term -> PP.Doc @@ -554,13 +553,13 @@ 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 (LSynVar a) = text a ppLit (LDCLabel dc) = ppDCLabelExpLit dc diff --git a/compiler/src/IR.hs b/compiler/src/IR.hs index f43506e0..1e87b4ac 100644 --- a/compiler/src/IR.hs +++ b/compiler/src/IR.hs @@ -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 C.SyntacticVariants [FunDef] deriving (Generic) ----------------------------------------------------------- -- Dependency calculation @@ -127,14 +127,14 @@ 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))) = + dependencies (Assign _ (Const (C.LSynVar a))) = tell ([], [], [a]) dependencies _ = return () @@ -182,7 +182,7 @@ instance Serialize IRBBTree ----------------------------------------------------------- data SerializationUnit = FunSerialization FunDef - | AtomsSerialization C.Atoms + | SyntacticVariantsSerialization C.SyntacticVariants | ProgramSerialization IRProgram deriving (Generic) @@ -192,11 +192,11 @@ 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)) +serializeSyntacticVariants :: C.SyntacticVariants -> BS.ByteString +serializeSyntacticVariants atoms = Serialize.runPut (Serialize.put (SyntacticVariantsSerialization atoms)) -deserializeAtoms :: BS.ByteString -> Either String C.Atoms -deserializeAtoms bs = Serialize.runGet (Serialize.get) bs +deserializeSyntacticVariants :: BS.ByteString -> Either String C.SyntacticVariants +deserializeSyntacticVariants bs = Serialize.runGet (Serialize.get) bs deserialize :: BS.ByteString -> Either String SerializationUnit deserialize bs = @@ -498,7 +498,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 158c505f..13e58bd9 100644 --- a/compiler/src/IR2Raw.hs +++ b/compiler/src/IR2Raw.hs @@ -777,7 +777,7 @@ 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.SyntacticVariantsSerialization c) = SyntacticVariantRawUnit c ir2raw (IR.ProgramSerialization prog) = ProgramRawUnit (prog2raw prog) -- Revision 2023-08: unchanged diff --git a/compiler/src/Raw.hs b/compiler/src/Raw.hs index 8f5a132b..10a37282 100644 --- a/compiler/src/Raw.hs +++ b/compiler/src/Raw.hs @@ -196,7 +196,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 C.SyntacticVariants [FunDef] ----------------------------------------------------------- @@ -204,7 +204,7 @@ data RawProgram = RawProgram C.Atoms [FunDef] ----------------------------------------------------------- data RawUnit = FunRawUnit FunDef - | AtomRawUnit C.Atoms + | SyntacticVariantRawUnit C.SyntacticVariants | ProgramRawUnit RawProgram diff --git a/compiler/src/Raw2Stack.hs b/compiler/src/Raw2Stack.hs index caf87c3b..64fcd1eb 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 ) + , serializeSyntacticVariants ) import qualified IR import qualified Raw import qualified Stack @@ -245,5 +245,5 @@ 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.SyntacticVariantRawUnit c -> Stack.SyntacticVariantStackUnit c + Raw.ProgramRawUnit p -> Stack.ProgramStackUnit (rawProg2Stack p) diff --git a/compiler/src/RawDefUse.hs b/compiler/src/RawDefUse.hs index c22128b7..aea851ab 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 ) + , serializeSyntacticVariants ) import qualified IR import qualified Stack import qualified Data.Maybe as Maybe diff --git a/compiler/src/RawOpt.hs b/compiler/src/RawOpt.hs index da7d146d..98c4cc24 100644 --- a/compiler/src/RawOpt.hs +++ b/compiler/src/RawOpt.hs @@ -189,7 +189,7 @@ typeOfLit lit = Core.LString _ -> Just RawString Core.LLabel _ -> Just RawLevel Core.LBool _ -> Just RawBoolean - Core.LAtom _ -> Nothing + Core.LSynVar _ -> Nothing Core.LDCLabel _ -> Just RawDCLabel @@ -596,10 +596,10 @@ instance RawOptable RawProgram where instance RawOptable FunDef where rawopt = funopt -instance RawOptable Core.Atoms where +instance RawOptable Core.SyntacticVariants where rawopt = id instance RawOptable RawUnit where rawopt (FunRawUnit f) = FunRawUnit (rawopt f) - rawopt (AtomRawUnit c) = AtomRawUnit (rawopt c) + rawopt (SyntacticVariantRawUnit c) = SyntacticVariantRawUnit (rawopt c) rawopt (ProgramRawUnit p) = ProgramRawUnit (rawopt p) diff --git a/compiler/src/RetCPS.hs b/compiler/src/RetCPS.hs index 46a2b333..8928e62c 100644 --- a/compiler/src/RetCPS.hs +++ b/compiler/src/RetCPS.hs @@ -86,7 +86,7 @@ data KTerm deriving (Eq, Ord) -data Prog = Prog C.Atoms KTerm +data Prog = Prog C.SyntacticVariants KTerm deriving (Eq, Show) -------------------------------------------------- @@ -103,13 +103,13 @@ instance ShowIndent Prog where -- ppProg :: Prog -> PP.Doc -ppProg (Prog (C.Atoms atoms) kterm) = - let ppAtoms = +ppProg (Prog (C.SyntacticVariants atoms) kterm) = + let ppSyntacticVariants = if null atoms then PP.empty - else (text "datatype Atoms = ") <+> + else (text "datatype SyntacticVariants = ") <+> (hsep $ PP.punctuate (text " |") (map text atoms)) - in ppAtoms $$ ppKTerm 0 kterm + in ppSyntacticVariants $$ ppKTerm 0 kterm ppKTerm :: Precedence -> KTerm -> PP.Doc diff --git a/compiler/src/RetFreeVars.hs b/compiler/src/RetFreeVars.hs index a938d539..cad1fa1b 100644 --- a/compiler/src/RetFreeVars.hs +++ b/compiler/src/RetFreeVars.hs @@ -38,7 +38,7 @@ instance FreeNames KLambda where instance FreeNames SVal where freeVars (KAbs klam) = freeVars klam - freeVars (Lit (C.LAtom nm)) = FreeVars (Set.singleton $ VN nm) + freeVars (Lit (C.LSynVar nm)) = FreeVars (Set.singleton $ VN nm) freeVars _ = emptyFreeVars instance FreeNames ContDef where diff --git a/compiler/src/Stack.hs b/compiler/src/Stack.hs index 6427a452..9f1bfc5f 100644 --- a/compiler/src/Stack.hs +++ b/compiler/src/Stack.hs @@ -85,11 +85,11 @@ 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 C.SyntacticVariants [FunDef] data StackUnit = FunStackUnit FunDef - | AtomStackUnit C.Atoms + | SyntacticVariantStackUnit C.SyntacticVariants | ProgramStackUnit StackProgram ----------------------------------------------------------- diff --git a/compiler/src/Stack2JS.hs b/compiler/src/Stack2JS.hs index b30ade29..d3a7d88b 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 ) + , serializeSyntacticVariants ) import qualified Data.ByteString.Lazy.Char8 as BL import qualified IR import qualified Raw @@ -64,7 +64,7 @@ data LibAccess = LibAccess Basics.LibName Basics.VarName data JSOutput = JSOutput { libs :: [LibAccess] , fname:: Maybe String , code :: String - , atoms :: [Basics.AtomName] + , atoms :: [Basics.SyntacticVariantName] } deriving (Show, Generic) instance Aeson.ToJSON Basics.LibName @@ -104,7 +104,7 @@ data TheState = TheState { freshCounter :: Integer type RetKontText = PP.Doc -type W = RWS Bool ([LibAccess], [Basics.AtomName], [RetKontText]) TheState +type W = RWS Bool ([LibAccess], [Basics.SyntacticVariantName], [RetKontText]) TheState initState = TheState { freshCounter = 0 @@ -134,7 +134,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 @@ -192,7 +192,7 @@ stack2JSON x = instance ToJS StackUnit where toJS (FunStackUnit fdecl) = toJS fdecl - toJS (AtomStackUnit ca) = toJS ca + toJS (SyntacticVariantStackUnit ca) = toJS ca toJS (ProgramStackUnit p) = error "not implemented" instance ToJS IR.VarAccess where @@ -232,13 +232,13 @@ instance ToJS StackProgram where -instance ToJS C.Atoms where - toJS catoms@(C.Atoms atoms) = return $ +instance ToJS C.SyntacticVariants where + toJS catoms@(C.SyntacticVariants atoms) = return $ vcat [ vcat $ (map (\a -> hsep ["const" , text a - , "= new rt.Atom" + , "= new rt.SyntacticVariant" , (PP.parens ( (PP.quotes.text) a))]) atoms) - , text "this.serializedatoms =" <+> (pickle.serializeAtoms) catoms] + , text "this.serializedatoms =" <+> (pickle.serializeSyntacticVariants) catoms] jsonValueToString :: Value -> String @@ -617,7 +617,7 @@ instance ToJS RawExpr where text "rt.mkV1Label" <> (PP.parens . PP.doubleQuotes) (text s) Const lit -> do case lit of - C.LAtom atom -> tell ([], [atom], []) + C.LSynVar atom -> tell ([], [atom], []) _ -> return () return $ ppLit lit Lib lib'@(Basics.LibName libname) varname -> do diff --git a/compiler/test/ir2raw-test/testcases/Expr.hs b/compiler/test/ir2raw-test/testcases/Expr.hs index 76f8d00a..cb8802ab 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 (Core.SyntacticVariants []) [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)] diff --git a/compiler/test/ir2raw-test/testcases/Inst.hs b/compiler/test/ir2raw-test/testcases/Inst.hs index 9336d1a1..ad2cdd04 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 (Core.SyntacticVariants []) [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..9b0f2ab7 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 (Core.SyntacticVariants []) [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 9e2212ac..4e626bd8 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 (Core.SyntacticVariants []) [FunDef (HFN "main") (VN "arg") [] tree] tcs :: [(String, IRProgram)] tcs = map (second mkP) From c753e9f8a823a7e4e0c4946ea2cfac3332413103 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Sun, 12 Oct 2025 16:42:52 +0200 Subject: [PATCH 22/30] Removed the Atom leftovers from much of the compiler --- compiler/src/CPSOpt.hs | 4 +- compiler/src/ClosureConv.hs | 28 ++++++-------- compiler/src/Core.hs | 41 +++++--------------- compiler/src/IR.hs | 18 ++------- compiler/src/IR2Raw.hs | 5 +-- compiler/src/IROpt.hs | 2 +- compiler/src/Raw.hs | 5 +-- compiler/src/Raw2Stack.hs | 7 ++-- compiler/src/RawDefUse.hs | 2 +- compiler/src/RawOpt.hs | 9 +---- compiler/src/RetCPS.hs | 10 +---- compiler/src/RetDFCPS.hs | 4 +- compiler/src/RetFreeVars.hs | 1 - compiler/src/RetRewrite.hs | 2 +- compiler/src/Stack.hs | 5 +-- compiler/src/Stack2JS.hs | 42 +++++---------------- compiler/test/ir2raw-test/testcases/Expr.hs | 2 +- compiler/test/ir2raw-test/testcases/Inst.hs | 2 +- compiler/test/ir2raw-test/testcases/TR.hs | 2 +- compiler/test/ir2raw-test/testcases/Tree.hs | 2 +- 20 files changed, 59 insertions(+), 134 deletions(-) diff --git a/compiler/src/CPSOpt.hs b/compiler/src/CPSOpt.hs index ebe02fb1..99677231 100644 --- a/compiler/src/CPSOpt.hs +++ b/compiler/src/CPSOpt.hs @@ -545,5 +545,5 @@ iter kt = iter kt' rewrite :: Prog -> Prog -rewrite (Prog atoms kterm) = - Prog atoms (iter kterm) +rewrite (Prog kterm) = + Prog (iter kterm) diff --git a/compiler/src/ClosureConv.hs b/compiler/src/ClosureConv.hs index aaa111b6..540c3ee0 100644 --- a/compiler/src/ClosureConv.hs +++ b/compiler/src/ClosureConv.hs @@ -45,7 +45,7 @@ type CC = RWS FreshCounter -- state: the counter for fresh name generation -type CCEnv = (CompileMode, C.SyntacticVariants, 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.SyntacticVariants 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 @@ -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.SyntacticVariants atms) t) = - let atms' = C.SyntacticVariants 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.SyntacticVariants atms) t) = consts = (fst.unzip) consts_wo_levs main = FunDef (HFN toplevel) (VN argumentName) consts bb - irProg = CCIR.IRProgram (C.SyntacticVariants 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 7f008039..2c9fc60e 100644 --- a/compiler/src/Core.hs +++ b/compiler/src/Core.hs @@ -8,7 +8,6 @@ module Core ( Lambda (..) , FunDecl (..) , Lit(..) , Prog(..) - , SyntacticVariants(..) , VarAccess(..) , lowerProg , renameProg @@ -57,7 +56,6 @@ data Lit | LDCLabel DCLabelExp | LUnit | LBool Bool - | LSynVar SyntacticVariantConstructorName 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 - (LSynVar x) == (LSynVar y) = x == y (LDCLabel dc) == (LDCLabel dc') = dc == dc' _ == _ = False instance Ord Lit where @@ -75,14 +72,11 @@ instance Ord Lit where (LLabel x) <= (LLabel y) = x <=y (LUnit) <= (LUnit) = True (LBool x) <= (LBool y) = x <=y - (LSynVar x) <= (LSynVar y) = x <=y (LDCLabel x) <= (LDCLabel y) = x <= y (LInt _ _) <= (LString _) = True (LString _) <= (LLabel _) = True (LLabel _) <= (LUnit) = True (LUnit) <= (LBool _) = True - (LBool _) <= (LSynVar _) = True - (LSynVar _) <= (LDCLabel _) = True _ <= _ = False instance GetPosInfo Lit where @@ -120,12 +114,7 @@ data Term deriving (Eq) -data SyntacticVariants = SyntacticVariants [SyntacticVariantName] - deriving (Eq, Show, Generic) -instance Serialize SyntacticVariants - - -data Prog = Prog Imports SyntacticVariants 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.SyntacticVariants -> SyntacticVariants -trans (D.SyntacticVariants atms) = SyntacticVariants [] -- (concat $ map snd atms) - lowerLam (D.Lambda vs t) = case vs of [] -> Unary "$unit" (lower t) @@ -172,7 +158,8 @@ lowerLit (D.LLabel s) = LLabel s lowerLit (D.LDCLabel dc) = LDCLabel dc lowerLit D.LUnit = LUnit lowerLit (D.LBool b) = LBool b -lowerLit (D.LSyntacticVariant n) = LSynVar n +-- We need some error handling here +-- lowerLit (D.LSyntacticVariant n) = LSynVar n lower :: D.Term -> Core.Term lower (D.Lit l) = Lit (lowerLit l) @@ -221,13 +208,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 (SyntacticVariants 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 (SyntacticVariants atms) term' + in Prog imports term' -- The rest of the declarations here are not exported @@ -413,15 +399,9 @@ instance ShowIndent Prog where ppProg :: Prog -> PP.Doc -ppProg (Prog (Imports imports) (SyntacticVariants atoms) term) = - let ppSyntacticVariants = - 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 $$ ppSyntacticVariants $$ 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 @@ -559,7 +539,6 @@ ppLit (LLabel s) = PP.braces (text s) ppLit LUnit = text "()" ppLit (LBool True) = text "true" ppLit (LBool False) = text "false" -ppLit (LSynVar a) = text a ppLit (LDCLabel dc) = ppDCLabelExpLit dc diff --git a/compiler/src/IR.hs b/compiler/src/IR.hs index 1e87b4ac..eed7ce11 100644 --- a/compiler/src/IR.hs +++ b/compiler/src/IR.hs @@ -118,7 +118,7 @@ data FunDef = FunDef -- An IR program is just a collection of atoms declarations -- and function definitions -data IRProgram = IRProgram C.SyntacticVariants [FunDef] deriving (Generic) +data IRProgram = IRProgram [FunDef] deriving (Generic) ----------------------------------------------------------- -- Dependency calculation @@ -133,10 +133,7 @@ instance ComputesDependencies IRInst where dependencies (MkFunClosures _ fdefs) = mapM_ (\(_, hfn) -> tell ([hfn],[],[])) fdefs dependencies (Assign _ (Lib libname _)) = - tell ([], [libname],[]) - dependencies (Assign _ (Const (C.LSynVar a))) = - tell ([], [], [a]) - + tell ([], [libname],[]) dependencies _ = return () instance ComputesDependencies IRBBTree where @@ -182,7 +179,6 @@ instance Serialize IRBBTree ----------------------------------------------------------- data SerializationUnit = FunSerialization FunDef - | SyntacticVariantsSerialization C.SyntacticVariants | ProgramSerialization IRProgram deriving (Generic) @@ -192,12 +188,6 @@ instance Serialize SerializationUnit serializeFunDef :: FunDef -> BS.ByteString serializeFunDef fdef = Serialize.runPut ( Serialize.put (FunSerialization fdef) ) -serializeSyntacticVariants :: C.SyntacticVariants -> BS.ByteString -serializeSyntacticVariants atoms = Serialize.runPut (Serialize.put (SyntacticVariantsSerialization atoms)) - -deserializeSyntacticVariants :: BS.ByteString -> Either String C.SyntacticVariants -deserializeSyntacticVariants 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 diff --git a/compiler/src/IR2Raw.hs b/compiler/src/IR2Raw.hs index 13e58bd9..0d08eb83 100644 --- a/compiler/src/IR2Raw.hs +++ b/compiler/src/IR2Raw.hs @@ -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.SyntacticVariantsSerialization c) = SyntacticVariantRawUnit 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 e2edff16..b1bd25ec 100644 --- a/compiler/src/IROpt.hs +++ b/compiler/src/IROpt.hs @@ -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/Raw.hs b/compiler/src/Raw.hs index 10a37282..ef0e0cfb 100644 --- a/compiler/src/Raw.hs +++ b/compiler/src/Raw.hs @@ -196,7 +196,7 @@ data FunDef = FunDef -- An IR program is just a collection of atoms declarations -- and function definitions -data RawProgram = RawProgram C.SyntacticVariants [FunDef] +data RawProgram = RawProgram [FunDef] ----------------------------------------------------------- @@ -204,7 +204,6 @@ data RawProgram = RawProgram C.SyntacticVariants [FunDef] ----------------------------------------------------------- data RawUnit = FunRawUnit FunDef - | SyntacticVariantRawUnit C.SyntacticVariants | ProgramRawUnit RawProgram @@ -259,7 +258,7 @@ instructionType i = case i of -- PRETTY PRINTING ----------------------------------------------------------- -ppProg (RawProgram atoms funs) = +ppProg (RawProgram funs) = vcat $ (map ppFunDef funs) instance Show RawProgram where diff --git a/compiler/src/Raw2Stack.hs b/compiler/src/Raw2Stack.hs index 64fcd1eb..91e225b4 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 - , serializeSyntacticVariants ) + ) import qualified IR import qualified Raw import qualified Stack @@ -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.SyntacticVariantRawUnit c -> Stack.SyntacticVariantStackUnit c Raw.ProgramRawUnit p -> Stack.ProgramStackUnit (rawProg2Stack p) diff --git a/compiler/src/RawDefUse.hs b/compiler/src/RawDefUse.hs index aea851ab..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 - , serializeSyntacticVariants ) + ) import qualified IR import qualified Stack import qualified Data.Maybe as Maybe diff --git a/compiler/src/RawOpt.hs b/compiler/src/RawOpt.hs index 98c4cc24..a0c0db9e 100644 --- a/compiler/src/RawOpt.hs +++ b/compiler/src/RawOpt.hs @@ -189,7 +189,6 @@ typeOfLit lit = Core.LString _ -> Just RawString Core.LLabel _ -> Just RawLevel Core.LBool _ -> Just RawBoolean - Core.LSynVar _ -> Nothing Core.LDCLabel _ -> Just RawDCLabel @@ -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.SyntacticVariants where - rawopt = id - instance RawOptable RawUnit where rawopt (FunRawUnit f) = FunRawUnit (rawopt f) - rawopt (SyntacticVariantRawUnit c) = SyntacticVariantRawUnit (rawopt c) rawopt (ProgramRawUnit p) = ProgramRawUnit (rawopt p) diff --git a/compiler/src/RetCPS.hs b/compiler/src/RetCPS.hs index 8928e62c..9dd8daa7 100644 --- a/compiler/src/RetCPS.hs +++ b/compiler/src/RetCPS.hs @@ -86,7 +86,7 @@ data KTerm deriving (Eq, Ord) -data Prog = Prog C.SyntacticVariants KTerm +data Prog = Prog KTerm deriving (Eq, Show) -------------------------------------------------- @@ -103,13 +103,7 @@ instance ShowIndent Prog where -- ppProg :: Prog -> PP.Doc -ppProg (Prog (C.SyntacticVariants atoms) kterm) = - let ppSyntacticVariants = - if null atoms - then PP.empty - else (text "datatype SyntacticVariants = ") <+> - (hsep $ PP.punctuate (text " |") (map text atoms)) - in ppSyntacticVariants $$ ppKTerm 0 kterm +ppProg (Prog kterm) = ppKTerm 0 kterm ppKTerm :: Precedence -> KTerm -> PP.Doc diff --git a/compiler/src/RetDFCPS.hs b/compiler/src/RetDFCPS.hs index 26932ca2..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 = diff --git a/compiler/src/RetFreeVars.hs b/compiler/src/RetFreeVars.hs index cad1fa1b..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.LSynVar nm)) = FreeVars (Set.singleton $ VN nm) freeVars _ = emptyFreeVars instance FreeNames ContDef where diff --git a/compiler/src/RetRewrite.hs b/compiler/src/RetRewrite.hs index 8a01e22c..0f6161bc 100644 --- a/compiler/src/RetRewrite.hs +++ b/compiler/src/RetRewrite.hs @@ -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 9f1bfc5f..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.SyntacticVariants [FunDef] +data StackProgram = StackProgram [FunDef] data StackUnit = FunStackUnit FunDef - | SyntacticVariantStackUnit C.SyntacticVariants | 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 d3a7d88b..78e92b79 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 - , serializeSyntacticVariants ) + ) 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.SyntacticVariantName] } 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.SyntacticVariantName], [RetKontText]) TheState +type W = RWS Bool ([LibAccess], [RetKontText]) TheState initState = TheState { freshCounter = 0 @@ -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 (SyntacticVariantStackUnit 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.SyntacticVariants where - toJS catoms@(C.SyntacticVariants atoms) = return $ - vcat [ vcat $ (map (\a -> hsep ["const" - , text a - , "= new rt.SyntacticVariant" - , (PP.parens ( (PP.quotes.text) a))]) atoms) - , text "this.serializedatoms =" <+> (pickle.serializeSyntacticVariants) 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)) <+> ";", @@ -615,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.LSynVar 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.quotes.text) libname <> text ", " <> (PP.quotes.text) varname <> text ", this") ConstructLVal r1 r2 r3 -> return $ diff --git a/compiler/test/ir2raw-test/testcases/Expr.hs b/compiler/test/ir2raw-test/testcases/Expr.hs index cb8802ab..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.SyntacticVariants []) [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)] diff --git a/compiler/test/ir2raw-test/testcases/Inst.hs b/compiler/test/ir2raw-test/testcases/Inst.hs index ad2cdd04..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.SyntacticVariants []) [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 9b0f2ab7..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.SyntacticVariants []) [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 4e626bd8..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.SyntacticVariants []) [FunDef (HFN "main") (VN "arg") [] tree] +mkP tree = IRProgram [FunDef (HFN "main") (VN "arg") [] tree] tcs :: [(String, IRProgram)] tcs = map (second mkP) From e342e538ac13c7f264063efce0b190c3001ee0de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Sun, 12 Oct 2025 17:05:12 +0200 Subject: [PATCH 23/30] Further removing of atoms --- compiler/app/Main.hs | 4 +- compiler/src/AtomFolding.hs | 93 --------------------------------- compiler/src/CaseElimination.hs | 6 +-- compiler/src/RetCPS.hs | 3 -- compiler/src/SynVarFolding.hs | 93 +++++++++++++++++++++++++++++++++ 5 files changed, 98 insertions(+), 101 deletions(-) delete mode 100644 compiler/src/AtomFolding.hs create mode 100644 compiler/src/SynVarFolding.hs 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/AtomFolding.hs b/compiler/src/AtomFolding.hs deleted file mode 100644 index 0b5ca440..00000000 --- a/compiler/src/AtomFolding.hs +++ /dev/null @@ -1,93 +0,0 @@ -module AtomFolding ( visitProg ) -where -import Basics -import Direct -import Control.Monad -import Data.List (find, any) - -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 atms (Lit lit) = Lit lit -visitTerm atms (Var nm) = - case find (\x -> (fst x) == nm) atms of - Nothing -> Var nm - Just (t, []) -> Tuple [Lit (LString nm)] True -- Convert atom into a tuple - Just (t, _) -> - let var = "v" - in Abs (Lambda [VarPattern var] (Tuple [ Lit (LString nm) - , Var var - ] True)) -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 tag) = - Tuple (map (visitTerm atms) terms) tag -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 :: [SyntacticVariantConstructor] -> DeclPattern -> DeclPattern -visitPattern atms pat@(VarPattern nm) = - if any (\x -> x == (nm, [])) atms - then TuplePattern [ValPattern (LString nm)] -- Convert atom match into a record match - 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)) -visitPattern atms (SyntacticVariantPattern nm pat) = - TuplePattern [ ValPattern (LString nm), visitPattern atms pat] - - -visitLambda :: [SyntacticVariantConstructor] -> Lambda -> Lambda -visitLambda atms (Lambda pats term) = - (Lambda (map (visitPattern atms) pats) (visitTerm atms term)) - diff --git a/compiler/src/CaseElimination.hs b/compiler/src/CaseElimination.hs index dc6c9117..86bcf9df 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.SyntacticVariants -> Trans T.SyntacticVariants -transAtoms (S.SyntacticVariants atms) = return (T.SyntacticVariants 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 diff --git a/compiler/src/RetCPS.hs b/compiler/src/RetCPS.hs index 9dd8daa7..8d25d7bf 100644 --- a/compiler/src/RetCPS.hs +++ b/compiler/src/RetCPS.hs @@ -111,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 diff --git a/compiler/src/SynVarFolding.hs b/compiler/src/SynVarFolding.hs new file mode 100644 index 00000000..089e3a2f --- /dev/null +++ b/compiler/src/SynVarFolding.hs @@ -0,0 +1,93 @@ +module SynVarFolding ( visitProg ) +where +import Basics +import Direct +import Control.Monad +import Data.List (find, any) + +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 (\x -> (fst x) == nm) svs of + Nothing -> Var nm + Just (t, []) -> Tuple [Lit (LString nm)] True -- Convert atom into a tuple + Just (t, _) -> + 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 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 (\x -> x == (nm, [])) svs + then TuplePattern [ValPattern (LString nm)] -- Convert atom match into a record 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)) + From 62af7cb8056fb4f61de41316c09a3d1c35fb2dd8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Sun, 12 Oct 2025 18:05:20 +0200 Subject: [PATCH 24/30] Eliminated atoms from runtime --- rt/src/Asserts.mts | 6 ---- rt/src/Atom.mts | 22 -------------- rt/src/builtins/UserRuntimeZero.mts | 2 -- rt/src/builtins/receive.mts | 46 +---------------------------- rt/src/deserialize.mts | 42 ++++---------------------- 5 files changed, 7 insertions(+), 111 deletions(-) delete mode 100644 rt/src/Atom.mts 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/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/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/deserialize.mts b/rt/src/deserialize.mts index 4433382f..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]) } @@ -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: From 62a62824da6d1ccea4f429d832e5c30eb7058226 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Mon, 13 Oct 2025 12:18:08 +0200 Subject: [PATCH 25/30] Added a negative test --- tests/cmp/synvar1.golden | 2 ++ tests/cmp/synvar1.trp | 1 + 2 files changed, 3 insertions(+) create mode 100644 tests/cmp/synvar1.golden create mode 100644 tests/cmp/synvar1.trp 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 From 3e3ca7c6212d67ed0581beb51667178ebc68e268 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Mon, 13 Oct 2025 12:19:55 +0200 Subject: [PATCH 26/30] added another negative test --- tests/cmp/synvar2.trp | 1 + 1 file changed, 1 insertion(+) create mode 100644 tests/cmp/synvar2.trp diff --git a/tests/cmp/synvar2.trp b/tests/cmp/synvar2.trp new file mode 100644 index 00000000..b22e94d7 --- /dev/null +++ b/tests/cmp/synvar2.trp @@ -0,0 +1 @@ +case 0 of SOME 1 => 0 From edfc3833e928b9470d9c5ce0d269adbbe0d50b0f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Mon, 13 Oct 2025 13:39:13 +0200 Subject: [PATCH 27/30] cleaned some code and fixed missing match case warnings --- compiler/src/CaseElimination.hs | 3 +- compiler/src/ClosureConv.hs | 2 +- compiler/src/Core.hs | 3 +- compiler/src/Raw2Stack.hs | 2 +- compiler/src/SynVarFolding.hs | 86 +++++++++++++++++++-------------- 5 files changed, 55 insertions(+), 41 deletions(-) diff --git a/compiler/src/CaseElimination.hs b/compiler/src/CaseElimination.hs index 86bcf9df..42c3f50d 100644 --- a/compiler/src/CaseElimination.hs +++ b/compiler/src/CaseElimination.hs @@ -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. diff --git a/compiler/src/ClosureConv.hs b/compiler/src/ClosureConv.hs index 540c3ee0..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 diff --git a/compiler/src/Core.hs b/compiler/src/Core.hs index 2c9fc60e..03bbad1b 100644 --- a/compiler/src/Core.hs +++ b/compiler/src/Core.hs @@ -158,8 +158,7 @@ lowerLit (D.LLabel s) = LLabel s lowerLit (D.LDCLabel dc) = LDCLabel dc lowerLit D.LUnit = LUnit lowerLit (D.LBool b) = LBool b --- We need some error handling here --- lowerLit (D.LSyntacticVariant n) = LSynVar n +lowerLit (D.LSyntacticVariant n) = error $ "Unexpected syntactic variant: \"" ++ n ++ "\"" lower :: D.Term -> Core.Term lower (D.Lit l) = Lit (lowerLit l) diff --git a/compiler/src/Raw2Stack.hs b/compiler/src/Raw2Stack.hs index 91e225b4..12a277a6 100644 --- a/compiler/src/Raw2Stack.hs +++ b/compiler/src/Raw2Stack.hs @@ -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 diff --git a/compiler/src/SynVarFolding.hs b/compiler/src/SynVarFolding.hs index 089e3a2f..b9b0e396 100644 --- a/compiler/src/SynVarFolding.hs +++ b/compiler/src/SynVarFolding.hs @@ -1,33 +1,43 @@ -module SynVarFolding ( visitProg ) -where +module SynVarFolding (visitProg) where + import Basics -import Direct import Control.Monad -import Data.List (find, any) +import Data.List (any, find) +import Direct visitProg :: Prog -> Prog visitProg (Prog imports (SyntacticVariants datatypes) tm) = - let tcs = concat $ map snd datatypes - in Prog imports (SyntacticVariants datatypes) (visitTerm tcs 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 (\x -> (fst x) == nm) svs of + case find ((==) nm . fst) svs of Nothing -> Var nm - Just (t, []) -> Tuple [Lit (LString nm)] True -- Convert atom into a tuple - Just (t, _) -> + Just (_t, []) -> Tuple [Lit (LString nm)] True -- Convert atom into a tuple + Just (_t, _) -> let var = "v" - in Abs (Lambda [VarPattern var] (Tuple [ Lit (LString nm) - , Var var - ] True)) + 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)) + 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) = @@ -37,20 +47,21 @@ visitTerm svs (Let decls term) = 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 + 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 (WithRecord e fields) = + WithRecord (visitTerm svs e) (visitFields svs fields) visitTerm svs (ProjField t f) = - ProjField (visitTerm svs t) f + ProjField (visitTerm svs t) f visitTerm svs (ProjIdx t idx) = - ProjIdx (visitTerm svs t) idx + ProjIdx (visitTerm svs t) idx visitTerm svs (List terms) = List (map (visitTerm svs) terms) visitTerm svs (ListCons t1 t2) = @@ -59,21 +70,25 @@ 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) = +visitTerm svs (Seq ts) = Seq $ map (visitTerm svs) ts visitTerm svs (Error t) = Error (visitTerm svs t) - -visitFields svs fs = map visitField fs - where visitField (f, Nothing) = (f, Nothing) - visitField (f, Just t) = (f, Just (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 (\x -> x == (nm, [])) svs - then TuplePattern [ValPattern (LString nm)] -- Convert atom match into a record match - else pat + 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 @@ -81,13 +96,12 @@ 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)) + 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] - + TuplePattern [ValPattern (LString nm), visitPattern svs pat] visitLambda :: [SyntacticVariantConstructor] -> Lambda -> Lambda visitLambda svs (Lambda pats term) = (Lambda (map (visitPattern svs) pats) (visitTerm svs term)) - From 5b9c548737d6e7d3620af6ae1d584907ad6a3c64 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Mon, 13 Oct 2025 13:49:28 +0200 Subject: [PATCH 28/30] fixed some formatter silliness --- compiler/src/SynVarFolding.hs | 72 +++++++++++++++-------------------- 1 file changed, 30 insertions(+), 42 deletions(-) diff --git a/compiler/src/SynVarFolding.hs b/compiler/src/SynVarFolding.hs index b9b0e396..5935fc35 100644 --- a/compiler/src/SynVarFolding.hs +++ b/compiler/src/SynVarFolding.hs @@ -7,8 +7,8 @@ import Direct visitProg :: Prog -> Prog visitProg (Prog imports (SyntacticVariants datatypes) tm) = - let tcs = concat $ map snd datatypes - in Prog imports (SyntacticVariants datatypes) (visitTerm tcs 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 @@ -18,26 +18,16 @@ visitTerm svs (Var nm) = Just (_t, []) -> Tuple [Lit (LString nm)] True -- Convert atom into a tuple Just (_t, _) -> let var = "v" - in Abs - ( Lambda - [VarPattern var] - ( Tuple - [ Lit (LString nm), - Var var - ] - True - ) - ) + 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) - ) + 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) = @@ -47,21 +37,20 @@ visitTerm svs (Let decls term) = 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 + 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 (WithRecord e fields) = + WithRecord (visitTerm svs e) (visitFields svs fields) visitTerm svs (ProjField t f) = - ProjField (visitTerm svs t) f + ProjField (visitTerm svs t) f visitTerm svs (ProjIdx t idx) = - ProjIdx (visitTerm svs t) idx + ProjIdx (visitTerm svs t) idx visitTerm svs (List terms) = List (map (visitTerm svs) terms) visitTerm svs (ListCons t1 t2) = @@ -70,25 +59,23 @@ 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) = +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)) +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 + 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 @@ -96,12 +83,13 @@ 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)) + 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] + TuplePattern [ ValPattern (LString nm), visitPattern svs pat ] + visitLambda :: [SyntacticVariantConstructor] -> Lambda -> Lambda visitLambda svs (Lambda pats term) = (Lambda (map (visitPattern svs) pats) (visitTerm svs term)) + From 2df8fb670743cf3ffd24c5d0265bc0761aa30271 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Mon, 13 Oct 2025 13:54:36 +0200 Subject: [PATCH 29/30] More cleaning of SynVarFolding.hs --- compiler/src/SynVarFolding.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/compiler/src/SynVarFolding.hs b/compiler/src/SynVarFolding.hs index 5935fc35..53ff58ef 100644 --- a/compiler/src/SynVarFolding.hs +++ b/compiler/src/SynVarFolding.hs @@ -5,6 +5,7 @@ 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 @@ -15,8 +16,8 @@ visitTerm svs (Lit lit) = Lit lit visitTerm svs (Var nm) = case find ((==) nm . fst) svs of Nothing -> Var nm - Just (_t, []) -> Tuple [Lit (LString nm)] True -- Convert atom into a tuple - Just (_t, _) -> + 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 @@ -87,7 +88,6 @@ visitPattern svs (RecordPattern fields mode) = RecordPattern (map visitField fie 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) = From 83210bf0747cf051e7b08caa72e8478022a45f66 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20Stenb=C3=A6k=20Larsen?= <47752472+AStenbaek@users.noreply.github.com> Date: Mon, 13 Oct 2025 15:00:01 +0200 Subject: [PATCH 30/30] checkpoint --- tests/cmp/synvar2.trp | 1 - 1 file changed, 1 deletion(-) delete mode 100644 tests/cmp/synvar2.trp diff --git a/tests/cmp/synvar2.trp b/tests/cmp/synvar2.trp deleted file mode 100644 index b22e94d7..00000000 --- a/tests/cmp/synvar2.trp +++ /dev/null @@ -1 +0,0 @@ -case 0 of SOME 1 => 0