Added more test, removed id-function check

Author: PhucVH888

src/back/CodeGen/CCodeNames.hs

@@ -62,10 +62,6 @@ isEncoreArgT :: CCode Ty -> Bool
 isEncoreArgT (Typ "encore_arg_t") = True
 isEncoreArgT _ = False
 
-isIdFun :: ID.Name -> Bool
-isIdFun (ID.Name "_id_fun_tmp") = True
-isIdFun _ = False
-
 ponyMsgT :: CCode Ty
 ponyMsgT = Typ "pony_msg_t"
 

src/back/CodeGen/Closure.hs

@@ -51,8 +51,6 @@ translateClosure closure typeVars table
            freeVars    = map (first ID.qnlocal) $
                          filter (ID.isLocalQName . fst) $
                          Util.freeVariables boundVars body
-          --  freeVarsForwarding = freeVars ++ [(ID.Name "_enc__field_fut", future)]
-          --  freeVarsForwarding = if freeVars then True else False--freeVars ++ [(future, Var "_enc__field_fut")]
            fTypeVars   = typeVars `intersect` Util.freeTypeVars body
            encEnvNames = map fst freeVars
            envNames    = map (AsLval . fieldName) encEnvNames
@@ -85,9 +83,7 @@ translateClosure closure typeVars table
                       [(Ptr (Ptr encoreCtxT), encoreCtxVar),
                        (Ptr (Ptr ponyTypeT), encoreRuntimeType),
                        (Typ "value_t", Var "_args[]"),
-                       (Ptr void, envVar)
-                       ]
-                      --  ,(future, futVar)]
+                       (Ptr void, envVar)]
                       (Seq $
                         dtraceClosureEntry argNames :
                         extractArguments params ++
@@ -96,16 +92,11 @@ translateClosure closure typeVars table
                         ,dtraceClosureExit
                         ,returnStmnt forwardingBodyName unitType])
        in
-        --  Concat $ [buildEnvironment envName freeVars fTypeVars,
-        --            tracefunDecl traceName envName freeVars fTypeVars] ++
-                  --  [normalClosureImpl]
-                  --  ++
-         Concat $  if null $ Util.filter A.isForward body
-                   then [buildEnvironmentForward envName freeVars fTypeVars,
-                         tracefunDecl traceName envName freeVars fTypeVars extractEnvironment,
+         Concat $  [buildEnvironmentForward envName freeVars fTypeVars] ++
+                   if null $ Util.filter A.isForward body
+                   then [tracefunDecl traceName envName freeVars fTypeVars extractEnvironment,
                          normalClosureImpl]
-                   else [buildEnvironmentForward envName freeVars fTypeVars,
-                         tracefunDecl traceName envName freeVars fTypeVars extractEnvironmentForward,
+                   else [tracefunDecl traceName envName freeVars fTypeVars extractEnvironmentForward,
                          forwardingClosureImpl]
   | otherwise =
         error

src/back/CodeGen/Expr.hs

@@ -1020,7 +1020,7 @@ instance Translatable A.Expr (State Ctx.Context (CCode Lval, CCode Stat)) where
         callTheMethodOneway
           ntarget targetType name args typeArguments Ty.unitType
 
-      let nullCheck = targetNullCheck ntarget target name emeta "."
+      let nullCheck = targetNullCheck ntarget target name emeta "!"
           result =
             case eCtx of
               Ctx.ClosureContext clos -> []
@@ -1064,7 +1064,7 @@ instance Translatable A.Expr (State Ctx.Context (CCode Lval, CCode Stat)) where
             Ctx.ClosureContext clos -> []
             _ -> [dtraceExit, Return Skip]
         futureChain =
-          if Util.isForwardInClos chain
+          if Util.isForwardInExpr chain
           then
             Call futureChainActor
               [AsExpr encoreCtxVar, AsExpr nfuture, ty, AsExpr nchain]
@@ -1154,7 +1154,7 @@ instance Translatable A.Expr (State Ctx.Context (CCode Lval, CCode Stat)) where
                      (Call futureChainActor
                        [AsExpr encoreCtxVar, AsExpr nfuture, ty, AsExpr nchain]
                        ))] ++
-            if (Util.isForwardInClos chain) then [assignVar futNam (Nam result)]
+            if (Util.isForwardInExpr chain) then [assignVar futNam (Nam result)]
             else [])
     where
       metaId    = Meta.getMetaId . A.getMeta $ chain
@@ -1169,7 +1169,6 @@ instance Translatable A.Expr (State Ctx.Context (CCode Lval, CCode Stat)) where
     let bound = map (ID.qLocal . A.pname) eparams
         freeVars = filter (ID.isLocalQName . fst) $
                    Util.freeVariables bound body
-        isIdClosure = not . null $ filter (isIdFun . A.pname) eparams
         ty = runtimeType . A.getType $ body
         futArg = if isAsyncForward
                  then futVar
@@ -1179,11 +1178,11 @@ instance Translatable A.Expr (State Ctx.Context (CCode Lval, CCode Stat)) where
       (Var tmp,
       Seq $
         mkEnv envName : fillEnv ++
-        (if isIdClosure || isAsyncForward || (not $ Util.isForwardInClos body)
+        (if isAsyncForward || (not $ Util.isForwardInExpr body)
          then []
          else [Assign (Decl (future, Var fut))
                 (Call futureMkFn [AsExpr encoreCtxVar, ty])]) ++
-        (if (not isIdClosure) && (Util.isForwardInClos body)
+        (if Util.isForwardInExpr body
          then [assignVar futNam futArg]
          else []) ++
         [Assign (Decl (closure, Var tmp))

src/back/CodeGen/MethodDecl.hs

@@ -77,7 +77,8 @@ translateGeneral mdecl@(A.Method {A.mbody, A.mlocals})
                       ,parametricMethodTypeVars
                       ,extractTypeVars
                       ,forwardingBody
-                      ])
+                      ,dtraceMethodExit thisVar mName
+                      ,Return Skip])
     in
       code ++ return (Concat $ locals ++ closures ++
                                [normalMethodImpl] ++

src/ir/AST/Util.hs

@@ -19,7 +19,7 @@ module AST.Util(
     , markStatsInBody
     , isStatement
     , isForwardMethod
-    , isForwardInClos
+    , isForwardInExpr
     ) where
 
 import qualified Data.List as List
@@ -482,5 +482,5 @@ mark asParent s =
 isForwardMethod :: MethodDecl -> Bool
 isForwardMethod mdecl = not . null . (filter isForward) . mbody $ mdecl
 
-isForwardInClos :: Expr -> Bool
-isForwardInClos e = not . null $ filter isForward e
+isForwardInExpr :: Expr -> Bool
+isForwardInExpr e = not . null $ filter isForward e

src/tests/encore/forward/forwardInClosurePolyType.enc

@@ -0,0 +1,22 @@
+-- Test with polymorphic type
+active class Base[t]
+  var v  : t
+  def init(v : t) : unit
+    this.v = v
+  end
+  def base() : t
+    this.v
+  end
+end
+active class Foo[sharable ty]
+  def foo(arg : Fut[ty]) : ty
+    get(arg ~~> fun(x : ty) : ty => forward((new Base[ty](x)) ! base()))
+  end
+end
+
+active class Main
+  def main() : unit
+    val arg = (new Base[int](42)) ! base()
+    println("{}", get((new Foo[int]) ! foo(arg)))
+  end
+end

src/tests/encore/forward/forwardInClosurePolyType.out

@@ -0,0 +1 @@
+42

src/tests/encore/forward/forwardPolyTypes.enc

@@ -0,0 +1,39 @@
+local class Rock[sharable t]
+  def roll(b : bool, v : t, r : t) : Fut[t]
+    ((new Lazy[t]) ! lazyWork(b, v, r))
+  end
+end
+
+active class Worker[t]
+  val v : t
+  def init(v : t) : unit
+    this.v = v
+  end
+  def work() : t
+    this.v
+  end
+end
+
+active class Lazy[sharable t]
+  def lazyWork(b : bool, v : t, r : t) : t
+    if b then
+      forward((new Worker[t](v)) ! work())
+    else
+      r
+    end
+    println("This should never run!")
+    r
+  end
+end
+
+active class Main
+  def main() : unit
+    println(get((new Lazy[String]) ! lazyWork(true, "42.0", "100.0")))
+    println(get((new Lazy[real]) ! lazyWork(true, 42.0, 100.0)))
+    println(get((new Lazy[int]) ! lazyWork(true, 42, 100)))
+    println(get((new Lazy[bool]) ! lazyWork(true, true, false)))
+    println(get((new Lazy[Maybe[int]]) ! lazyWork(true, Just(42), Just(100))))
+    -- Tested with passive class
+    println(get((new Rock[int]).roll(true, 42, 100)))
+  end
+end

src/tests/encore/forward/forwardPolyTypes.out

@@ -0,0 +1,6 @@
+42.0
+42.000000
+42
+true
+Just 42
+42

src/types/Typechecker/TypeError.hs

@@ -295,6 +295,7 @@ data Error =
   | ForwardInPassiveContext Type
   | ForwardInFunction
   | ForwardTypeError Type Type
+  | ForwardTypeClosError Type Type
   | CannotHaveModeError Type
   | ModelessError Type
   | ModeOverrideError Type
@@ -724,6 +725,10 @@ instance Show Error where
         printf ("Returned type %s of forward should match with " ++
                "the result type of the containing method %s")
                (show retType) (show ty)
+    show (ForwardTypeClosError retType ty) =
+        printf ("Returned type %s of forward should match with " ++
+               "the result type of the closure %s")
+               (show retType) (show ty)
     show (ForwardInPassiveContext cname) =
         printf "Forward can not be used in passive class '%s'"
                (show cname)

src/types/Typechecker/Typechecker.hs

@@ -24,7 +24,8 @@ import Control.Arrow((&&&), second)
 import Identifiers
 import AST.AST hiding (hasType, getType)
 import qualified AST.AST as AST (getType)
-import qualified AST.Util as Util (freeVariables, filter, markStatsInBody, isStatement)
+import qualified AST.Util as Util (freeVariables, filter, markStatsInBody,
+                                  isStatement, isForwardInExpr)
 import AST.PrettyPrinter
 import AST.Util(extend)
 import Types as Ty
@@ -458,7 +459,7 @@ instance Checkable ClassDecl where
       typeParameters = getTypeParameters cname
       addTypeVars = addTypeParameters typeParameters
       addThis = extendEnvironmentImmutable [(thisName, cname)]
-      isForwardMethod m@Method{mbody} = not . null $ Util.filter isForward mbody
+      isForwardMethod m@Method{mbody} = Util.isForwardInExpr mbody
 
       checkMethodExtensionAllowed
         | isModeless cname = do
@@ -1261,13 +1262,14 @@ instance Checkable Expr where
            context <- asks currentExecutionContext
            case context of
              MethodContext mdecl -> do
-               let returnType = methodType mdecl
-               unlessM (getResultType ty `subtypeOf` returnType) $
-                       pushError eExpr $ ForwardTypeError returnType ty
-               return $ setType (getResultType ty) forward {forwardExpr = eExpr}
+                let returnType = methodType mdecl
+                unlessM (getResultType ty `subtypeOf` returnType) $
+                      pushError eExpr $ ForwardTypeError returnType ty
+                return $ setType (getResultType ty) forward {forwardExpr = eExpr}
              ClosureContext (Just mty) -> do
-                unlessM (getResultType ty `subtypeOf` mty) $
-                    pushError eExpr $ ForwardTypeError mty ty
+                mty' <- resolveType mty
+                unlessM (getResultType ty `subtypeOf` mty') $
+                      pushError eExpr $ ForwardTypeClosError mty' ty
                 return $ setType (getResultType ty) forward {forwardExpr = eExpr}
              ClosureContext Nothing -> tcError ClosureForwardError
              _ -> pushError eExpr ForwardInFunction