Merge branch '32-simplify-aspats-2' into 32-extended-syntax

Author: Anabra

grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs

@@ -168,11 +168,7 @@ producesNode (Undefined T_NodeSet{}) = True
 producesNode _ = False
 
 asPatternDataflow :: IR.Reg -> BPat -> CG ()
-asPatternDataflow r asPat@(AsPat _ asVal) = case asVal of
-  Unit  -> pure ()
-  Lit{} -> pure ()
-  Var v -> addReg v r
-  ConstTagNode tag args -> do
+asPatternDataflow r asPat@(AsPat tag args _) = do
     irTag <- getTag tag
     bindInstructions <- forM (zip [1..] args) $ \(idx, arg) -> do
       argReg <- newReg
@@ -187,7 +183,6 @@ asPatternDataflow r asPat@(AsPat _ asVal) = case asVal of
       , srcReg        = r
       , instructions  = concat bindInstructions
       }
-  valPat -> error $ "unsupported @pattern: " ++ show (PP asPat)
 asPatternDataflow _ pat = error $ "not @pattern: " ++ show (PP pat)
 
 {- NOTE: para is needed to specify the order of evalution of the lhs and rhs on binds.
@@ -227,17 +222,10 @@ codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where
       cgRhs
 
     -- NOTE: @patterns
-    EBindF (lhs, cgLhs) asPat@(AsPat var valPat) (_, cgRhs) -> do
+    EBindF (lhs, cgLhs) asPat@(AsPat tag args var) (_, cgRhs) -> do
       lhsRes <- cgLhs
       case lhsRes of
-        Z -> do
-          r <- newReg
-          emit IR.Set {dstReg = r, constant = IR.CSimpleType unitType}
-          addReg var r
-          case valPat of
-            Unit      -> pure ()
-            Var inner -> addReg inner r
-            _ -> error $ "pattern mismatch at CreatedBy bind codegen, expected Unit got " ++ show (PP valPat)
+        Z -> error $ "pattern mismatch at CreatedBy bind codegen, expected Unit got " ++ show (PP $ ConstTagNode tag args)
         R r -> do
           case lhs of
             SReturn val | producesNode val -> do

grin/src/AbstractInterpretation/ExtendedSyntax/EffectTracking/CodeGen.hs

@@ -66,8 +66,8 @@ codeGenM = cata folder where
       let R rhsReg = rhs
 
       case bPat of
-        VarPat var   -> addReg var lhsReg
-        AsPat  var _ -> addReg var lhsReg
+        VarPat var     -> addReg var lhsReg
+        AsPat  _ _ var -> addReg var lhsReg
 
       emit IR.Move { srcReg = lhsReg, dstReg = rhsReg }
       pure $ R rhsReg

grin/src/AbstractInterpretation/ExtendedSyntax/HeapPointsTo/CodeGen.hs

@@ -176,28 +176,14 @@ codeGenM = cata folder where
     EBindF leftExp bpat rightExp -> do
       leftExp >>= \case
         Z -> case bpat of
-          AsPat varName Unit -> do
-            r <- newReg
-            emit IR.Set {dstReg = r, constant = IR.CSimpleType unitType}
-            addReg varName r
           VarPat varName -> do
             r <- newReg
             emit IR.Set {dstReg = r, constant = IR.CSimpleType unitType}
             addReg varName r
           _ -> error $ "pattern mismatch at HPT bind codegen, Unit cannot be matched against " ++ show bpat
         R r -> case bpat of -- QUESTION: should the evaluation continue if the pattern does not match yet?
           VarPat varName -> addReg varName r
-          AsPat varName Unit -> do
-            addReg varName r
-            pure () -- TODO: is this ok? or error?
-          -- NOTE: I think this is okay. Could be optimised though (since we already know the result)?
-          AsPat varName Lit{} -> do
-            addReg varName r
-            pure () -- TODO: is this ok? or error?
-          AsPat v1 (Var v2) -> do
-            addReg v1 r
-            addReg v2 r
-          AsPat varName (ConstTagNode tag args) -> do
+          AsPat tag args varName -> do
             addReg varName r
             irTag <- getTag tag
             bindInstructions <- forM (zip [0..] args) $ \(idx, name) -> do

grin/src/AbstractInterpretation/ExtendedSyntax/LiveVariable/CodeGen.hs

@@ -237,16 +237,7 @@ codeGenM e = (cata folder >=> const setMainLive) e
 
       case bPat of
         VarPat v -> mkRegsThenVarPatternDataFlow v
-        AsPat v Unit -> do
-          setBasicValLive lhsReg
-          mkRegsThenVarPatternDataFlow v
-        AsPat v Lit{} -> do
-          setBasicValLive lhsReg
-          mkRegsThenVarPatternDataFlow v
-        AsPat v1 (Var v2) -> do
-          mkRegsThenVarPatternDataFlow v1
-          mkRegsThenVarPatternDataFlow v2
-        AsPat v (ConstTagNode tag args) -> do
+        AsPat tag args v -> do
           irTag <- getTag tag
           setTagLive irTag lhsReg
           bindInstructions <- codeGenBlock_ $ forM (zip [1..] args) $ \(idx, arg) -> do

grin/src/Grin/ExtendedSyntax/Grin.hs

@@ -25,8 +25,8 @@ instance FoldNames Val where
 
 instance FoldNames BPat where
   foldNames f = \case
-    VarPat v    -> f v
-    AsPat v val -> f v <> foldNames f val
+    VarPat v     -> f v
+    AsPat t vs v -> f v <> foldNames f (ConstTagNode t vs)
 
 
 instance FoldNames CPat where
@@ -54,6 +54,7 @@ _Lit :: Traversal' Val Lit
 _Lit f (Lit l) = Lit <$> f l
 _Lit _ rest    = pure rest
 
+-- NOTE: This will return NM "" for everyrhing that is not a Var
 _Var :: Traversal' Val Name
 _Var f (Var name) = Var <$> f name
 _Var _ rest       = pure rest

grin/src/Grin/ExtendedSyntax/Lint.hs

@@ -310,8 +310,8 @@ lint warningKinds mTypeEnv exp@(Program exts _) =
         when (isn't _OnlyVarPat bPat) $ do
           forM_ mTypeEnv $ \typeEnv -> do
             fromMaybe (pure ()) $ case bPat of
-              AsPat v val -> do -- Maybe
-                expectedPatType <- normalizeType <$> mTypeOfValTE typeEnv val
+              AsPat tag fields v -> do -- Maybe
+                expectedPatType <- normalizeType <$> mTypeOfValTE typeEnv (ConstTagNode tag fields)
                 lhsType         <- normalizeType <$> extract leftExp
                 pure $ do -- Lint
                   -- NOTE: This can still give false positive errors, because bottom-up typing can only approximate the result of HPT.

grin/src/Grin/ExtendedSyntax/Nametable.hs

@@ -86,7 +86,7 @@ convert = second (view nametable) . flip runState emptyNS . cata build where
     ProgramF es defs            -> Program <$> mapM external es <*> sequence defs
     DefF fn ps body             -> Def <$> (nameToIdx fn) <*> (mapM nameToIdx ps) <*> body
     EBindF l (VarPat v) r       -> EBind <$> l <*> (VarPat <$> nameToIdx v) <*> r
-    EBindF l (AsPat var val) r  -> EBind <$> l <*> (AsPat <$> nameToIdx var <*> value val) <*> r
+    EBindF l (AsPat t vars v) r -> EBind <$> l <*> (AsPat <$> tag t <*> mapM nameToIdx vars <*> nameToIdx v) <*> r
     ECaseF v alts               -> ECase <$> nameToIdx v <*> sequence alts
     SAppF v ps                  -> SApp <$> nameToIdx v <*> (mapM nameToIdx ps)
     SReturnF v                  -> SReturn <$> value v
@@ -107,7 +107,7 @@ restore (exp, nt) = cata build exp where
     ProgramF es defs           -> Program (map rexternal es) defs
     DefF fn ps body            -> Def (rname fn) (map rname ps) body
     EBindF l (VarPat v) r      -> EBind l (VarPat $ rname v) r
-    EBindF l (AsPat var val) r -> EBind l (AsPat (rname var) (rvalue val)) r
+    EBindF l (AsPat t vs v) r  -> EBind l (AsPat (rtag t) (map rname vs) (rname v)) r
     ECaseF v alts              -> ECase (rname v) alts
     SAppF v ps                 -> SApp (rname v) (map rname ps)
     SReturnF v                 -> SReturn (rvalue v)

grin/src/Grin/ExtendedSyntax/Parse/AST.hs

@@ -54,8 +54,9 @@ alternative i = Alt <$> try (L.indentGuard sc EQ i *> altPat) <*> (op "@" *> var
 -- and we don't want to parenthesize variables, literals and units.
 bindingPat :: Parser BPat
 bindingPat =
-  try (flip AsPat <$> value <*> (op "@" *> var)) <|>
-  VarPat <$> var
+  VarPat <$> var <|>
+  mkAsPat <$> parens ((,) <$> tag <*> many var) <*> (op "@" *> var)
+  where mkAsPat (tag, fields) var = AsPat tag fields var
 
 
 altPat :: Parser CPat

grin/src/Grin/ExtendedSyntax/Pretty.hs

@@ -144,8 +144,8 @@ instance Pretty Lit where
 
 instance Pretty BPat where
   pretty = \case
-    VarPat v    -> pretty v
-    AsPat v pat -> pretty pat <+> pretty '@' <+> pretty v
+    VarPat v           -> pretty v
+    AsPat tag fields v -> pretty (ConstTagNode tag fields) <+> pretty '@' <+> pretty v
 
 instance Pretty CPat where
   pretty = \case

grin/src/Grin/ExtendedSyntax/Statistics.hs

@@ -67,7 +67,7 @@ statistics = cata $ \case
   e -> Data.Foldable.fold e
 
 tagInBPat :: BPat -> Set.Set Tag
-tagInBPat (AsPat var (ConstTagNode t _)) = Set.singleton t
+tagInBPat (AsPat t _ _) = Set.singleton t
 tagInBPat _ = mempty