Syntactic Variants

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"

compiler/src/AddAmbientMethods.hs

@@ -21,27 +21,27 @@ 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
 
 
 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
 
 
 
 addAmbientMethods :: Prog -> Prog 
 addAmbientMethods (Prog imports atoms t) = 
     let t' = Let [FunDecs [printDecl,printWithLabelsDecl,printStringDecl]] t
-    in Prog imports atoms t'
+    in Prog imports atoms t'

compiler/src/Basics.hs

@@ -9,8 +9,12 @@ import GHC.Generics(Generic)
 import Data.Serialize (Serialize)
 
 type VarName = String
-type AtomName = String
+type SyntacticVariantName = String
+type SyntacticVariantConstructorName = String
+type SyntacticVariantConstructor = (SyntacticVariantConstructorName, [VarName])
+type SyntacticVariantDef = (SyntacticVariantName, [SyntacticVariantConstructor])
 type FieldName = String
+type SynVariantTag = Bool
 
 -- | Eq and Neq: deep equality check on the two parameters, including the types (any type inequality results in false being returned).
 data BinOp = Plus | Minus | Mult | Div | Mod |  Eq | Neq | Le | Lt | Ge | Gt | And | Or | RaisedTo | FlowsTo | Concat| IntDiv | BinAnd | BinOr | BinXor | BinShiftLeft | BinShiftRight | BinZeroShiftRight | HasField | LatticeJoin | LatticeMeet

compiler/src/CPSOpt.hs

@@ -77,8 +77,8 @@ instance Substitutable SimpleTerm where
     case simpleTerm of
       Bin op v1 v2 -> Bin op (fwd v1) (fwd v2)
       Un op v -> Un op (fwd v)
-      Tuple vs -> Tuple (map fwd vs)
-      Record fields -> Record $ fwdFields fields
+      Tuple vs tag -> Tuple (map fwd vs) tag
+      Record fields -> Record (fwdFields fields)
       WithRecord x fields -> WithRecord (fwd x) $ fwdFields fields
       ProjField x f -> ProjField (fwd x) f
       ProjIdx x idx -> ProjIdx (fwd x) idx
@@ -145,7 +145,7 @@ instance CensusCollectible SimpleTerm where
       Bin _ v1 v2 -> updateCensus [v1,v2]
       Un _ v -> updateCensus v 
       ValSimpleTerm sv -> updateCensus sv 
-      Tuple vs -> updateCensus vs 
+      Tuple vs _ -> updateCensus vs 
       Record fs -> let (_,vs) = unzip fs in updateCensus vs 
       WithRecord v fs -> updateCensus v >> (let (_,vs) = unzip fs in updateCensus vs )
       ProjField v _ -> updateCensus v
@@ -326,30 +326,30 @@ 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
 
 
         (Basics.IsList, St (List _))          -> _ret __trueLit
         (Basics.IsList, St (ListCons _ _))    -> _ret __trueLit
-        (Basics.IsList, St (Record _))        -> _ret __falseLit
+        (Basics.IsList, St (Record _))      -> _ret __falseLit
         (Basics.IsList, St (WithRecord _ _))  -> _ret __falseLit 
-        (Basics.IsList, St (Tuple _))         -> _ret __falseLit
+        (Basics.IsList, St (Tuple _ _))         -> _ret __falseLit
         (Basics.IsList, St (ValSimpleTerm _)) -> _ret __falseLit
 
-        (Basics.TupleLength, St (Tuple xs)) -> 
+        (Basics.TupleLength, St (Tuple xs _)) -> 
             _ret $ lit (C.LInt (fromIntegral (length xs)) NoPos)
         -- 2023-08 Revision: Added this case
         (Basics.ListLength, St (List xs)) -> 
@@ -366,7 +366,7 @@ simplifySimpleTerm t =
   ProjIdx x idx -> do
     t <- look x
     case t of
-      St (Tuple vs) | fromIntegral (length vs) > idx ->
+      St (Tuple vs _) | fromIntegral (length vs) > idx ->
         _subst (vs !! fromIntegral idx)
       _ -> _nochange
 
@@ -409,7 +409,7 @@ failFree st = case st of
   Bin op _ _ ->  op `elem` [Basics.Eq, Basics.Neq] -- Equality comparisons are safe (return boolean)
   Un _ _ -> False  -- Unary operations can fail (e.g., head on empty list, arithmetic on non-numbers)
   ValSimpleTerm _ -> True 
-  Tuple _ -> True 
+  Tuple _ _ -> True 
   Record _ -> True 
   WithRecord _ _ -> True 
   ProjField _ _ -> False  -- Field projection can fail if field doesn't exist
@@ -545,5 +545,5 @@ iter kt =
                            iter kt' 
 
 rewrite :: Prog -> Prog
-rewrite (Prog atoms kterm) = 
- Prog atoms (iter kterm)
+rewrite (Prog kterm) = 
+ Prog (iter kterm)

compiler/src/CaseElimination.hs

@@ -27,12 +27,12 @@ trans mode (S.Prog imports atms tm) = do
                   S.Let [ S.ValDecl (S.VarPattern "authority") (S.Var "$$authorityarg") _srcRT ]
                         tm
               Export -> tm
-  atms' <- transAtoms atms
+  atms' <- transSynVars atms
   tm'' <- transTerm tm'
   return (T.Prog imports atms' tm'')
 
-transAtoms :: S.Atoms -> Trans T.Atoms
-transAtoms (S.Atoms atms) = return (T.Atoms atms)
+transSynVars :: S.SyntacticVariants -> Trans T.SyntacticVariants
+transSynVars (S.SyntacticVariants atms) = return (T.SyntacticVariants atms)
 
 transLit :: S.Lit -> T.Lit
 transLit (S.LInt n pi)    = T.LInt n pi
@@ -41,7 +41,7 @@ transLit (S.LLabel s)  = T.LLabel s
 transLit (S.LDCLabel dc)  = T.LDCLabel dc
 transLit (S.LUnit)     = T.LUnit
 transLit (S.LBool b)   = T.LBool b
-transLit (S.LAtom a)   = T.LAtom a
+transLit (S.LSyntacticVariant a)   = T.LSyntacticVariant a
 
 
 transLambda_aux :: S.Lambda -> ReaderT T.Term Trans Lambda
@@ -95,8 +95,8 @@ transHandler (S.Handler pat1 mbpat2 guard body) = do
               Just pat2 -> pat2
               Nothing   -> S.Wildcard      
       lambdaPats = [S.VarPattern argInput] 
-      callFailure = S.Tuple [S.Lit (S.LInt 1 _srcRT), S.Lit S.LUnit ]  
-      body' =  S.Tuple[ S.Lit (S.LInt 0 _srcRT), S.Abs ( S.Lambda [S.Wildcard] body )  ]
+      callFailure = S.Tuple [S.Lit (S.LInt 1 _srcRT), S.Lit S.LUnit ] False
+      body' =  S.Tuple[ S.Lit (S.LInt 0 _srcRT), S.Abs ( S.Lambda [S.Wildcard] body )  ] False
       guardCheck = case guard of
          Nothing -> body'
          Just g -> S.If g body' callFailure
@@ -188,7 +188,8 @@ compilePattern succ (v, S.RecordPattern fieldPatterns mode) = do
 
           compileField succ (f, Nothing) = do 
               ifHasField f $ compilePattern succ (T.ProjField v f, S.VarPattern f)
-
+compilePattern _ (_, (S.SyntacticVariantPattern nm _)) =
+  lift $ throwError $ "Unexpected syntactic variant pattern: \"" ++ nm ++ "\""
 
 
 -- | Tranform a declaration, compiling patterns into terms.
@@ -211,7 +212,7 @@ transDecl (S.FunDecs fundecs) succ = do
       let lams' = map (transLambda_aux . (\(S.Lambda args e) -> S.Lambda [S.TuplePattern args] e)) lams
           names = map (((f ++ "_pat") ++) . show) [1..(length lams)]
           args =  map (((f ++ "_arg") ++) . show) [1..(argLength lams)]
-          args' =  Tuple (map Var args)
+          args' =  Tuple (map Var args) False
           errorMsg = Error (Lit (LString $ "pattern match failure in function " ++ f)) pos
       (fst, decls) <- foldr (\(n, l) acc -> do
             (fail, decls) <- acc
@@ -257,9 +258,9 @@ transTerm (S.If t1 t2 t3) = do
   t2' <- transTerm t2
   t3' <- transTerm t3
   return (If t1' t2' t3')
-transTerm (S.Tuple tms) = do
+transTerm (S.Tuple tms tag) = do
   tms' <- mapM transTerm tms
-  return (T.Tuple tms')
+  return (T.Tuple tms' tag)
 transTerm (S.Record fields) = do
   fields' <- transFields fields
   return (T.Record fields')
@@ -302,4 +303,4 @@ transFields = mapM $ \case
   (f, Nothing) -> return (f, T.Var f)
   (f, Just t) -> do
     t' <- transTerm t
-    return (f, t')
+    return (f, t')