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')