WIP: More massaging of Core Transform, Analysis, and Analysis cases.

discus-lang · Oct 28, 2018 · 486cdc3 · 486cdc3
1 parent a756670
commit 486cdc3
Show file tree

Hide file tree

Showing 11 changed files with 62 additions and 14 deletions.
diff --git a/src/s1/ddc-core-flow/DDC/Core/Flow/Transform/Annotate.hs b/src/s1/ddc-core-flow/DDC/Core/Flow/Transform/Annotate.hs
@@ -8,9 +8,9 @@ import qualified DDC.Core.Flow.Exp.Simple.Exp   as S
 
 -- | Convert the `Simple` version of the AST to the `Annot` version,
 --   using a the provided default annotation value.
-class Annotate  
-        (c1 :: * -> * -> *) 
-        (c2 :: * -> * -> *) | c1 -> c2 
+class Annotate
+        (c1 :: * -> * -> *)
+        (c2 :: * -> * -> *) | c1 -> c2
  where
  annotate :: a -> c1 a n -> c2 a n
 
@@ -40,6 +40,7 @@ instance Annotate S.Exp A.Exp where
         S.XLet  lts x                   -> A.XLet      def   (down lts) (down x)
         S.XCase x alts                  -> A.XCase     def   (down x)   (map down alts)
         S.XCast c x                     -> A.XCast     def   (down c)   (down x)
+        S.XAsync b e1 e2                -> A.XAsync    def b (down e1)  (down e2)
 
         S.XType    _                    -> error "ddc-core-flow.annotate: naked Xtype"
         S.XWitness _                    -> error "ddc-core-flow.annotate: naked Xwitness"
@@ -90,7 +91,7 @@ instance Annotate S.Witness A.Witness where
         S.WAnnot a (S.WType t)          -> A.WType a t
 
         S.WVar  u                       -> A.WVar  def u
-        S.WCon  dc                      -> A.WCon  def dc        
+        S.WCon  dc                      -> A.WCon  def dc
         S.WApp  x1 x2                   -> A.WApp  def (down x1) (down x2)
         S.WType t                       -> A.WType def t
 

diff --git a/src/s1/ddc-core-flow/DDC/Core/Flow/Transform/Deannotate.hs b/src/s1/ddc-core-flow/DDC/Core/Flow/Transform/Deannotate.hs
@@ -35,9 +35,9 @@ instance Deannotate A.Exp S.Exp where
                 A.MALabel{}             -> error "deannotate: finish me"
                 A.MAPrim p              -> wrap a (S.XPrim p)
 
-        A.XCase a x alts                -> wrap a (S.XCase  (down x)   (map down alts))
-        A.XCast a cc x                  -> wrap a (S.XCast  (down cc)  (down x))
-        A.XAsync a b e1 e2              -> wrap a (S.XAsync (down b) (down e1) (down e2))
+        A.XCase a x alts                -> wrap a (S.XCase    (down x)   (map down alts))
+        A.XCast a cc x                  -> wrap a (S.XCast    (down cc)  (down x))
+        A.XAsync a b e1 e2              -> wrap a (S.XAsync b (down e1)  (down e2))
 
 
 instance Deannotate A.Arg S.Exp where

diff --git a/src/s1/ddc-core/DDC/Core/Analysis/Usage.hs b/src/s1/ddc-core/DDC/Core/Analysis/Usage.hs
@@ -215,6 +215,13 @@ usageX' xx
          -> ( used'
             , XCast (used', a) c' x1')
 
+        -- TODO FIXME do we need to do anything with the bound variable here?
+        XAsync a b e1 e2
+         |  (used1, e1')   <- usageX' e1
+         ,  (used2, e2')   <- usageX' e2
+         ,  used'          <- plusUsedMap used1 used2
+         -> ( used'
+            , XAsync (used', a) b e1' e2')
 
 usageArg' :: Ord n
         => Arg a n

diff --git a/src/s1/ddc-core/DDC/Core/Check/Post.hs b/src/s1/ddc-core/DDC/Core/Check/Post.hs
@@ -37,6 +37,10 @@ checkExp xx
         XCast _a _c x
          ->     checkExp  x
 
+        XAsync a b e1 e2
+         -> do  checkExp e1
+                checkBind a b
+                checkExp e2
 
 -- | Post check a parameter.
 checkParam :: a -> Param n -> Either (Error a n) ()

diff --git a/src/s1/ddc-core/DDC/Core/Fragment/Compliance.hs b/src/s1/ddc-core/DDC/Core/Fragment/Compliance.hs
@@ -258,6 +258,15 @@ instance Complies Exp where
         XCast _ _ x     -> compliesX profile kenv tenv (reset context) x
 
 
+        -- xasync ------------------------------
+        XAsync _ b e1 e2
+         -> do  (tUsed1, vUsed1) <- compliesX profile kenv tenv  (reset context) e1
+                let tenv'        =  Env.extend b tenv
+                (tUsed2, vUsed2) <- compliesX profile kenv tenv' (reset context) e2
+                vUsed2'          <- checkBind profile tenv b vUsed2
+
+                return ( Set.union tUsed1 tUsed2
+                       , Set.union vUsed1 vUsed2' )
 
 instance Complies Alt where
  compliesX profile kenv tenv context aa

diff --git a/src/s1/ddc-core/DDC/Core/Transform/Namify.hs b/src/s1/ddc-core/DDC/Core/Transform/Namify.hs
@@ -169,6 +169,11 @@ instance Namify (Exp a) where
         XCase a x1 alts -> liftM2 (XCase    a) (down x1)  (mapM down alts)
         XCast a c  x    -> liftM2 (XCast    a) (down c)   (down x)
 
+        XAsync a b e1 e2
+         -> do  e1'             <- namify tnam xnam  e1
+                (xnam', b')     <- pushX  tnam xnam  b
+                e2'             <- namify tnam xnam' e2
+                return $ XAsync a b' e1' e2'
 
 instance Namify (Arg a) where
  namify tnam xnam aa

diff --git a/src/s1/ddc-core/DDC/Core/Transform/Reannotate.hs b/src/s1/ddc-core/DDC/Core/Transform/Reannotate.hs
@@ -38,13 +38,14 @@ instance Reannotate Exp where
  reannotateM f xx
   = let down x   = reannotateM f x
     in case xx of
-        XVar  a u       -> XVar  <$> f a <*> pure u
-        XAbs  a b x     -> XAbs  <$> f a <*> pure b   <*> down x
-        XApp  a x1 x2   -> XApp  <$> f a <*> down x1  <*> down x2
-        XLet  a lts x   -> XLet  <$> f a <*> down lts <*> down x
-        XAtom a t       -> XAtom <$> f a <*> pure t
-        XCase a x alts  -> XCase <$> f a <*> down x   <*> mapM down alts
-        XCast a c x     -> XCast <$> f a <*> down c   <*> down x
+        XVar   a u       -> XVar   <$> f a <*> pure u
+        XAbs   a b x     -> XAbs   <$> f a <*> pure b   <*> down x
+        XApp   a x1 x2   -> XApp   <$> f a <*> down x1  <*> down x2
+        XLet   a lts x   -> XLet   <$> f a <*> down lts <*> down x
+        XAtom  a t       -> XAtom  <$> f a <*> pure t
+        XCase  a x alts  -> XCase  <$> f a <*> down x   <*> mapM down alts
+        XCast  a c x     -> XCast  <$> f a <*> down c   <*> down x
+        XAsync a b e1 e2 -> XAsync <$> f a <*> pure b   <*> down e1 <*> down e2
 
 
 instance Reannotate Arg where

diff --git a/src/s1/ddc-core/DDC/Core/Transform/Snip.hs b/src/s1/ddc-core/DDC/Core/Transform/Snip.hs
@@ -168,6 +168,12 @@ enterX config arities xx
         XCast a c e
          -> XCast a c (down [] e)
 
+        -- asynchronous binding (similar to a non-recursive let)
+        XAsync a b e1 e2
+         -> let e1'     = down [] e1
+                e2'     = snipLetBody config a
+                        $ down [(b, arityOfExp' e1')] e2
+            in  XAsync a b e1' e2'
 
 -- | Build an A-normalised application of some functional expression to
 --   its arguments. Atomic arguments are applied directly, while

diff --git a/src/s1/ddc-core/DDC/Core/Transform/SubstituteTX.hs b/src/s1/ddc-core/DDC/Core/Transform/SubstituteTX.hs
@@ -112,6 +112,11 @@ instance SubstituteTX (Exp a) where
         XCase a x1 alts -> XCase    a (down sub x1) (map (down sub) alts)
         XCast a cc x1   -> XCast    a (down sub cc) (down sub x1)
 
+        XAsync a b e1 e2
+         -> let e1'             = down  sub  e1
+                (sub', b')      = bind0 sub  (down sub b)
+                e2'             = down  sub' e2
+            in XAsync a b' e1' e2'
 
 instance SubstituteTX (Arg a) where
  substituteWithTX tArg sub aa

diff --git a/src/s1/ddc-core/DDC/Core/Transform/SubstituteWX.hs b/src/s1/ddc-core/DDC/Core/Transform/SubstituteWX.hs
@@ -118,6 +118,11 @@ instance SubstituteWX Exp where
         XCase    a x1 alts      -> XCase a (down sub x1) (map (down sub) alts)
         XCast    a cc x1        -> XCast a (down sub cc) (down sub x1)
 
+        XAsync a b e1 e2
+         -> let e1'             = down  sub  e1
+                (sub', b')      = bind0 sub  b
+                e2'             = down  sub' e2
+            in XAsync a b' e1' e2'
 
 instance SubstituteWX Arg where
  substituteWithWX wArg sub aa

diff --git a/src/s1/ddc-core/DDC/Core/Transform/SubstituteXX.hs b/src/s1/ddc-core/DDC/Core/Transform/SubstituteXX.hs
@@ -157,6 +157,11 @@ instance SubstituteXX Exp where
         XCast     a cc x1
          -> XCast a (down sub cc) (down sub x1)
 
+        XAsync    a b e1 e2
+         -> let e1'             = down  sub  e1
+                (sub', b')      = bind0 sub  b
+                e2'             = down  sub' e2
+            in XAsync a b' e1' e2'
 
 instance SubstituteXX Arg where
  substituteWithXX xArg sub aa