Merge pull request #188 from albertnetymk/trait

Add trait support and its test.

mylittlepony.cabal

@@ -20,8 +20,8 @@ executable encorec
   main-is:             TopLevel.hs
   default-extensions: NamedFieldPuns
                     , FlexibleContexts
-  other-extensions: GADTs
-                  , FlexibleInstances
+                    , GADTs
+  other-extensions: FlexibleInstances
                   , MultiParamTypeClasses
                   , StandaloneDeriving
                   , TypeSynonymInstances
@@ -38,6 +38,8 @@ executable encorec
                , unix >=2.7 && <2.8
                , text >=1.1
                , template-haskell
+               , hashable
+               , unordered-containers
                , MissingH
   hs-source-dirs:      src/back src/front src/ir src/opt src/parser src/types
   default-language:    Haskell2010

src/back/CCode/Main.hs

@@ -8,9 +8,6 @@ will be generated, but it tries to enforce some reasonable invariants.
 
 module CCode.Main where
 
-import qualified AST.AST as AST
-import Data.Char
-
 data Toplevel
 data Stat
 data Expr
@@ -60,7 +57,7 @@ data CCode a where
     AssignTL     :: (UsableAs l Lval, UsableAs e Expr) => CCode l -> CCode e -> CCode Toplevel
     Decl         :: CVarSpec -> CCode Lval
     DeclTL       :: CVarSpec -> CCode Toplevel
-    Concat       :: [CCode Toplevel] -> CCode Toplevel 
+    Concat       :: [CCode Toplevel] -> CCode Toplevel
     Seq          :: UsableAs Stat s => [CCode s] -> CCode Stat
     Enum         :: [CCode Name] -> CCode Toplevel
     Braced       :: CCode a -> CCode a
@@ -100,3 +97,4 @@ data CCode a where
     Double       :: Double -> CCode Expr
     Comm         :: String -> CCode a
     Annotated    :: String -> CCode a -> CCode a
+    FunPtrDecl   :: CCode Ty -> CCode Name -> [CCode Ty] -> CCode Stat

src/back/CCode/PrettyCCode.hs

@@ -59,7 +59,7 @@ pp' (Assign lhs rhs) = add_semi $ pp' lhs <+> text "=" <+> pp' rhs
 pp' (AssignTL lhs rhs) = add_semi $ pp' lhs <+> text "=" <+> pp' rhs
 pp' (Decl (ty, id)) = tshow ty <+> tshow id
 pp' (DeclTL (ty, id)) = add_semi $ tshow ty <+> tshow id
-pp' (FunTypeDef id ty argTys) = add_semi $ text "typedef" <+> tshow ty <+> parens (star <> tshow id) <> 
+pp' (FunTypeDef id ty argTys) = add_semi $ text "typedef" <+> tshow ty <+> parens (star <> tshow id) <>
                                 parens (commaList argTys)
 pp' (Concat ccodes) = vcat $ intersperse (text "\n") $ map pp' ccodes
 pp' (Seq ccodes) = vcat $ map (add_semi . pp') ccodes
@@ -74,7 +74,7 @@ pp' (CUnary o e) = parens $  pp' o <+> pp' e
 pp' (BinOp o e1 e2) = parens $  pp' e1 <+> pp' o <+> pp' e2
 pp' (Dot ccode id) = pp' ccode <> text "." <> tshow id
 pp' (Arrow ccode id) = pp' ccode <> text "->" <> tshow id
-pp' (Deref ccode) = parens $ star <> pp' ccode 
+pp' (Deref ccode) = parens $ star <> pp' ccode
 pp' (Cast ty e) = parens $ (parens $ pp' ty) <+> pp' e
 pp' (ArrAcc i l) = parens $  pp' l <> brackets (tshow i)
 pp' (Amp ccode) = parens $ text "&" <> (parens $ pp' ccode)
@@ -110,8 +110,13 @@ pp' (Int n) = tshow n
 pp' (String s) = tshow s
 pp' (Double d) = tshow d
 pp' (Comm s) = text ("/* "++s++" */")
---Annotated :: CCode a -> String -> CCode a
 pp' (Annotated s ccode) = pp' ccode <+> pp' (Comm s)
+pp' (FunPtrDecl t name arg_types) =
+  let
+    args = parens (commaList arg_types)
+    id = text "(*" <> pp' name <> text ")"
+  in
+    pp' t <+> id <+> args
 
 commaList :: [CCode a] -> Doc
 commaList l = hcat $ intersperse (text ", ") $ map pp' l

src/back/CodeGen/CCodeNames.hs

@@ -16,8 +16,7 @@ module CodeGen.CCodeNames where
 import qualified Identifiers as ID
 import Types as Ty
 import CCode.Main
-import Data.Char
-
+import Data.List
 
 char :: CCode Ty
 char = Typ "char"
@@ -86,7 +85,11 @@ unit :: CCode Lval
 unit = Embed "UNIT"
 
 encore_name :: String -> String -> String
-encore_name kind name = "_enc__" ++ kind ++ "_" ++ name
+encore_name kind name =
+  let
+    non_emptys = filter (not . null) ["_enc_", kind, name]
+  in
+    concat $ intersperse "_" non_emptys
 
 self_type_field :: CCode Name
 self_type_field = Nam $ encore_name "self_type" ""
@@ -98,11 +101,11 @@ method_impl_name clazz mname =
     Nam $ encore_name "method" $ (Ty.getId clazz) ++ "_" ++ (show mname)
 
 arg_name :: ID.Name -> CCode Lval
-arg_name name = 
+arg_name name =
     Var $ encore_name "arg" (show name)
 
 field_name :: ID.Name -> CCode Name
-field_name name = 
+field_name name =
     Nam $ encore_name "field" (show name)
 
 global_closure_name :: ID.Name -> CCode Name
@@ -126,41 +129,47 @@ closure_trace_name name =
     Nam $ encore_name "trace" name
 
 task_function_name :: String -> CCode Name
-task_function_name name = 
+task_function_name name =
     Nam $ encore_name "task" name
 
 task_env_name :: String -> CCode Name
-task_env_name name = 
+task_env_name name =
     Nam $ encore_name "task_env" name
 
 task_dependency_name :: String -> CCode Name
-task_dependency_name name = 
+task_dependency_name name =
     Nam $ encore_name "task_dep" name
 
 task_trace_name :: String -> CCode Name
-task_trace_name name = 
+task_trace_name name =
     Nam $ encore_name "task_trace" name
 
 stream_handle :: CCode Lval
 stream_handle = Var "_stream"
 
 type_var_ref_name :: Ty.Type -> CCode Name
-type_var_ref_name ty = 
+type_var_ref_name ty =
     Nam $ encore_name "type" (show ty)
 
 class_id :: Ty.Type -> CCode Name
 class_id ty =
     Nam $ encore_name "ID" (Ty.getId ty)
 
+ref_type_id :: Ty.Type -> CCode Name
+ref_type_id ty =
+    Nam $ encore_name "ID" (Ty.getId ty)
+
+trait_method_selector_name = Nam "trait_method_selector"
+
 -- | each class, in C, provides a dispatch function that dispatches
 -- messages to the right method calls. This is the name of that
 -- function.
 class_dispatch_name :: Ty.Type -> CCode Name
-class_dispatch_name clazz = 
+class_dispatch_name clazz =
     Nam $ encore_name "dispatch" (Ty.getId clazz)
 
 class_trace_fn_name :: Ty.Type -> CCode Name
-class_trace_fn_name clazz = 
+class_trace_fn_name clazz =
     Nam $ encore_name "trace" (Ty.getId clazz)
 
 runtime_type_init_fn_name :: Ty.Type -> CCode Name
@@ -177,8 +186,8 @@ one_way_msg_type_name cls mname =
 
 -- | for each method, there's a corresponding message, this is its name
 fut_msg_id :: Ty.Type -> ID.Name -> CCode Name
-fut_msg_id cls mname =
-    Nam $ "_ENC__FUT_MSG_" ++ Ty.getId cls ++ "_" ++ show mname
+fut_msg_id ref mname =
+    Nam $ "_ENC__FUT_MSG_" ++ Ty.getId ref ++ "_" ++ show mname
 
 task_msg_id :: CCode Name
 task_msg_id = Nam "_ENC__MSG_TASK"
@@ -187,23 +196,25 @@ one_way_msg_id :: Ty.Type -> ID.Name -> CCode Name
 one_way_msg_id cls mname =
     Nam $ "_ENC__ONEWAY_MSG_" ++ Ty.getId cls ++ "_" ++ show mname
 
+type_name_prefix :: Ty.Type -> String
+type_name_prefix ref
+    | Ty.isActiveRefType ref =
+        encore_name "active" $ Ty.getId ref
+    | Ty.isPassiveRefType ref =
+        encore_name "passive" $ Ty.getId ref
+    | Ty.isTrait ref =
+        encore_name "trait" $ Ty.getId ref
+    | otherwise = error $ "type_name_prefix Type '" ++ show ref ++
+                          "' isnt reference type!"
+
+ref_type_name :: Ty.Type -> CCode Name
+ref_type_name ref = Nam $ (type_name_prefix ref) ++ "_t"
+
 class_type_name :: Ty.Type -> CCode Name
-class_type_name cls
-    | Ty.isActiveRefType cls =
-        Nam $ encore_name "active" ((Ty.getId cls) ++ "_t")
-    | Ty.isPassiveRefType cls =
-        Nam $ encore_name "passive" ((Ty.getId cls) ++ "_t")
-    | otherwise = error $ "Type '" ++ show cls ++
-                          "' is neither active nor passive!"
+class_type_name ref = Nam $ (type_name_prefix ref) ++ "_t"
 
 runtime_type_name :: Ty.Type -> CCode Name
-runtime_type_name cls
-    | Ty.isActiveRefType cls =
-        Nam $ encore_name "active" ((Ty.getId cls) ++ "_type")
-    | Ty.isPassiveRefType cls =
-        Nam $ encore_name "passive" ((Ty.getId cls) ++ "_type")
-    | otherwise = error $ "Type '" ++ show cls ++
-                          "' is neither active nor passive!"
+runtime_type_name ref = Nam $ (type_name_prefix ref) ++ "_type"
 
 future_trace_fn :: CCode Name
 future_trace_fn = Nam "future_trace"

src/back/CodeGen/ClassDecl.hs

@@ -1,31 +1,30 @@
-{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, GADTs, NamedFieldPuns #-}
+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
 
-{-| Translate a @ClassDecl@ (see "AST") to its @CCode@ (see
-"CCode.Main") equivalent.
+{-|
 
- -}
+Translate a @ClassDecl@ (see "AST") to its @CCode@ (see "CCode.Main")
+equivalent.
+
+-}
 
 module CodeGen.ClassDecl () where
 
 import CodeGen.Typeclasses
 import CodeGen.CCodeNames
-import CodeGen.MethodDecl
+import CodeGen.MethodDecl ()
 import CodeGen.ClassTable
 import CodeGen.Type
 import CodeGen.Trace (trace_variable)
-import qualified CodeGen.Context as Ctx
 
 import CCode.Main
-import CCode.PrettyCCode
+import CCode.PrettyCCode ()
 
 import Data.List
 
 import qualified AST.AST as A
 import qualified Identifiers as ID
 import qualified Types as Ty
 
-import Control.Monad.Reader hiding (void)
-
 instance Translatable A.ClassDecl (ClassTable -> CCode FIN) where
   translate cdecl ctable
       | A.isActive cdecl = translateActiveClass cdecl ctable
@@ -37,6 +36,7 @@ instance Translatable A.ClassDecl (ClassTable -> CCode FIN) where
 translateActiveClass cdecl@(A.Class{A.cname, A.fields, A.methods}) ctable =
     Program $ Concat $
       (LocalInclude "header.h") :
+      [trait_method_selector cdecl] ++
       [type_struct_decl] ++
       [runtime_type_init_fun_decl cdecl] ++
       [tracefun_decl cdecl] ++
@@ -176,12 +176,12 @@ translateActiveClass cdecl@(A.Class{A.cname, A.fields, A.methods}) ctable =
 translatePassiveClass cdecl@(A.Class{A.cname, A.fields, A.methods}) ctable =
     Program $ Concat $
       (LocalInclude "header.h") :
+      [trait_method_selector cdecl] ++
       [runtime_type_init_fun_decl cdecl] ++
       [tracefun_decl cdecl] ++
       method_impls ++
       [dispatchfun_decl] ++
       [runtime_type_decl cname]
-
     where
       method_impls = map method_decl methods
           where
@@ -192,6 +192,33 @@ translatePassiveClass cdecl@(A.Class{A.cname, A.fields, A.methods}) ctable =
                     (Ptr pony_msg_t, Var "_m")]
                    (Comm "Stub! Might be used when we have dynamic dispatch on passive classes")
 
+trait_case :: Ty.Type -> A.Trait -> [(CCode Name, CCode Stat)]
+trait_case cname A.Trait{A.traitName, A.traitMethods} =
+  let
+    method_names = map A.mname traitMethods
+    name_pairs = zip (repeat traitName) method_names
+    case_names = map (Nam . show . (uncurry one_way_msg_id)) name_pairs
+    stmt_pairs = zip (repeat cname) method_names
+    c_method_names = map (Nam . show . (uncurry method_impl_name)) stmt_pairs
+    case_stmts = map Return c_method_names
+  in
+    zip case_names case_stmts
+
+trait_method_selector :: A.ClassDecl -> CCode Toplevel
+trait_method_selector A.Class{A.cname, A.ctraits} =
+  let
+    ret_type = (Static (Ptr void))
+    f = trait_method_selector_name
+    args = [(Typ "int" , Var "id")]
+    cond = Var "id"
+    cases = concatMap (trait_case cname) $ map A.itrait ctraits
+    err = String "error, got invalid id: %d"
+    default_case = Statement $ Call (Nam "printf") [err, AsExpr $ Var "id"]
+    switch = Switch cond cases default_case
+    body = Seq [ switch, Return Null ]
+  in
+    Function ret_type f args body
+
 runtime_type_init_fun_decl :: A.ClassDecl -> CCode Toplevel
 runtime_type_init_fun_decl A.Class{A.cname, A.fields, A.methods} =
     Function void (runtime_type_init_fn_name cname)
@@ -238,4 +265,9 @@ runtime_type_decl cname =
                     Null,
                     Null,
                     AsExpr . AsLval $ class_dispatch_name cname,
-                    Null]))
+                    Null,
+                    Int 0,
+                    Null,
+                    Null,
+                    Record [AsExpr . AsLval $ trait_method_selector_name]
+                    ]))

src/back/CodeGen/ClassTable.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE NamedFieldPuns #-}
 module CodeGen.ClassTable (
   ClassTable,
   lookup_method,
@@ -10,27 +9,27 @@ import AST.AST
 import Identifiers
 
 type FieldTable  = [(Name, FieldDecl)]
-type MethodTable = [(Name, MethodDecl)] 
+type MethodTable = [(Name, MethodDecl)]
 type ClassTable  = [(Type, (FieldTable, MethodTable))]
 
 build_class_table :: Program -> ClassTable
 build_class_table = traverseProgram f merge
-    where
-        f Program{classes, imports} = map get_class_entry classes
-        merge a b = a ++ concat b 
-        get_class_entry Class{cname, fields, methods} = 
-            (cname, ((map get_field_entry fields), (map get_method_entry methods)))
-        get_field_entry f@Field{fname} = (fname, f)
-        get_method_entry m = (mname m, m)
-    
-       
+  where
+    f Program{classes} = map get_class_entry classes
+    merge a b = a ++ concat b
+    get_class_entry Class{cname, fields, methods} =
+      (cname, ((map get_field_entry fields), (map get_method_entry methods)))
+    get_field_entry f@Field{fname} = (fname, f)
+    get_method_entry m = (mname m, m)
+
+
 lookup_field :: ClassTable -> Type -> Name -> Maybe FieldDecl
-lookup_field ctable cls f = 
-    do (fs, _) <- lookup cls ctable 
+lookup_field ctable cls f =
+    do (fs, _) <- lookup cls ctable
        lookup f fs
 
 
 lookup_method :: ClassTable -> Type -> Name -> Maybe MethodDecl
-lookup_method ctable cls m = 
-    do (_, ms) <- lookup cls ctable 
+lookup_method ctable cls m =
+    do (_, ms) <- lookup cls ctable
        lookup m ms