Add DTrace/SystemTap support to Encore (parapluu#655)

* DTrace for Pony and Encore works together <3

use make use=dtrace. This will create probes in both encore and pony.
For systemtap you can try this feature with following:

cd src/tests/encore/systemtap
encorec ../basic/realfutures.enc -o realfutures
sudo stap -L 'process("*").mark("*")'

* Adds DTrace probes for specific future uses

* Adds probe for closure creation

* Fix DTrace compilation

* Framework for inserting dtrace probes

This commit provides a framework for inserting dtrace probes in Encore
programs. Currently, only comments are generated, but in theory we
should be able to replace them with actual dtrace calls. This at least
works as a starting point for the dtrace-team.

Also some boyscouting.

* Adds the actual probes to the generated C code

* Early exit on DTrace header generation

* Fix the encore probes

* Fix dtrace function without arguments

* Enable DTrace for embedded statements

* haskell changes should now be working

* Fixes the Embedded probe mess

* Add additional header to compile clean without DTrace
This is a workaround that will make sure that Encore compiles cleanly when
compiled without the  flag. The extra header file is placed in

Author: Jip J. Dekker

.gitignore

@@ -74,3 +74,5 @@ src/tests/encore/traits/*
 .stack*
 coverage/
 encorec.tix
+src/runtime/common/dtrace_probes.h
+src/runtime/common/encore_probes.h

Makefile

@@ -81,7 +81,7 @@ RANGE_INC=$(RUNTIME_DIR)/range/range.h
 RANGE_LIB=$(RUNTIME_DIR)/pony/bin/$(CONFIG)/librange.a
 
 pony: dirs $(PONY_INC)
-	make -C $(SRC_DIR) pony
+	make -C $(SRC_DIR) pony use=$(use)
 	cp -r $(COMMON_INC) $(INC_DIR)
 	cp -r $(POOL_INC) $(INC_DIR)
 	cp -r $(PONY_INC) $(INC_DIR)

src/Makefile

@@ -2,15 +2,15 @@ PONY_DIR=runtime/pony
 
 all: pony
 
-test: 
+test:
 	make -C tests
 
-pony: 
-	cd $(PONY_DIR); premake4 gmake
+pony:
+	cd $(PONY_DIR); premake4 gmake $(use)
 	make -C $(PONY_DIR) config=debug
 	make -C $(PONY_DIR) config=release
 
-clean: clean_pony
+clean: clean_pony clean_dtrace
 	@echo "cleaning test files..."
 	make -C tests clean
 	@echo "done"
@@ -20,4 +20,10 @@ clean_pony:
 	[ -f $(PONY_DIR)/Makefile ] && make -C $(PONY_DIR) clean || true
 	rm -rf $(PONY_DIR)/*.make $(PONY_DIR)/Makefile $(PONY_DIR)/bin $(PONY_DIR)/obj
 
+clean_dtrace:
+	rm -f $(PONY_DIR)/../common/dtrace_probes.h
+	rm -f $(PONY_DIR)/../common/encore_probes.h
+	rm -f $(PONY_DIR)/../common/dtrace_probes.o
+	rm -f $(PONY_DIR)/../common/encore_probes.o
+
 .PHONY: all test pony clean clean_pony

src/back/CodeGen/CCodeNames.hs

@@ -141,6 +141,15 @@ encoreAssert :: CCode Expr -> CCode Stat
 encoreAssert p =
   Statement $ Call (Nam "encore_assert") [Cast (Typ "intptr_t") p]
 
+this :: String
+this = "_this"
+
+thisName :: CCode Name
+thisName = Nam this
+
+thisVar :: CCode Lval
+thisVar = Var this
+
 encoreName :: String -> String -> String
 encoreName kind name =
   let

src/back/CodeGen/ClassDecl.hs

@@ -16,6 +16,7 @@ import CodeGen.ClassTable
 import CodeGen.Type
 import CodeGen.Trace
 import CodeGen.GC
+import CodeGen.DTrace
 
 import CCode.Main
 import CCode.PrettyCCode ()
@@ -67,7 +68,7 @@ dispatchFunDecl cdecl@(A.Class{A.cname, A.cfields, A.cmethods}) =
      ([(Ptr (Ptr encoreCtxT), encoreCtxVar),
        (Ptr ponyActorT, Var "_a"),
        (Ptr ponyMsgT, Var "_m")])
-     (Seq [Assign (Decl (Ptr . AsType $ classTypeName cname, Var "_this"))
+     (Seq [Assign (Decl (Ptr . AsType $ classTypeName cname, thisVar))
                   (Cast (Ptr . AsType $ classTypeName cname) (Var "_a")),
            Seq $ map assignTypeVar classTypeVars,
            (Switch (Var "_m" `Arrow` Nam "id")
@@ -83,7 +84,7 @@ dispatchFunDecl cdecl@(A.Class{A.cname, A.cfields, A.cmethods}) =
        classTypeVars = Ty.getTypeParameters cname
        assignTypeVar t =
             Assign (Decl (Ptr ponyTypeT, AsLval $ typeVarRefName t))
-                   (Arrow (Nam "_this") (typeVarRefName t))
+                   (Arrow thisName (typeVarRefName t))
        ponyMainClause =
            (Nam "_ENC__MSG_MAIN",
             Seq $ [Assign (Decl (Ptr ponyMainMsgT, Var "msg")) (Cast (Ptr ponyMainMsgT) (Var "_m")),
@@ -167,7 +168,7 @@ dispatchFunDecl cdecl@(A.Class{A.cname, A.cfields, A.cmethods}) =
              streamMethodCall =
                  Statement $ Call (methodImplName cname mName)
                                   (encoreCtxVar :
-                                   Var "_this" :
+                                   thisVar :
                                    nullVar :
                                    Var "_fut" :
                                    map (AsLval . argName . A.pname) mParams)
@@ -178,7 +179,7 @@ dispatchFunDecl cdecl@(A.Class{A.cname, A.cfields, A.cmethods}) =
                          AsExpr $ Var "_fut",
                          asEncoreArgT (translate mType)
                          (Call (methodImplName cname mName)
-                               (encoreCtxVar : Var "_this" :
+                               (encoreCtxVar : thisVar :
                                 pMethodArrName :
                                 map (AsLval . argName . A.pname) mParams))]
              mName   = A.methodName mdecl
@@ -199,7 +200,7 @@ dispatchFunDecl cdecl@(A.Class{A.cname, A.cfields, A.cmethods}) =
              methodCall =
                  Statement $
                    Call (methodImplName cname mName)
-                        (encoreCtxVar : Var "_this" : pMethodArrName :
+                        (encoreCtxVar : thisVar : pMethodArrName :
                            map (AsLval . argName . A.pname) mParams)
              mName   = A.methodName mdecl
              mParams = A.methodParams mdecl
@@ -237,15 +238,14 @@ constructorImpl act cname =
     fBody = Seq $
       assignThis :
       decorateThis act ++
-      [ret this]
+      [ret thisVar]
   in
     Function retType fName args fBody
   where
     classType = AsType $ classTypeName cname
     thisType = Ptr classType
     cast = Cast thisType
-    this = Var "this"
-    declThis = Decl (thisType, this)
+    declThis = Decl (thisType, thisVar)
     runtimeType = Amp $ runtimeTypeName cname
     create = createCall act
     assignThis = Assign declThis $ cast create
@@ -260,7 +260,7 @@ constructorImpl act cname =
       Call encoreAllocName [AsExpr $ Deref encoreCtxVar, Sizeof classType]
 
     decorateThis :: Activity -> [CCode Stat]
-    decorateThis Passive = [Assign (this `Arrow` selfTypeField) runtimeType]
+    decorateThis Passive = [Assign (thisVar `Arrow` selfTypeField) runtimeType]
     decorateThis _ = []
 
 translateSharedClass cdecl@(A.Class{A.cname, A.cfields, A.cmethods}) table =
@@ -327,16 +327,16 @@ traitMethodSelector table A.Class{A.cname, A.ccomposition} =
 runtimeTypeInitFunDecl :: A.ClassDecl -> CCode Toplevel
 runtimeTypeInitFunDecl A.Class{A.cname, A.cfields, A.cmethods} =
     Function void (runtimeTypeInitFnName cname)
-                 [(Ptr . AsType $ classTypeName cname, Var "this"), (Embed "...", Embed "")]
+                 [(Ptr . AsType $ classTypeName cname, thisVar), (Embed "...", Embed "")]
                    (Seq $
                     (Statement $ Decl (Typ "va_list", Var "params")) :
-                    (Statement $ Call (Nam "va_start") [Var "params", Var "this"]) :
+                    (Statement $ Call (Nam "va_start") [Var "params", thisVar]) :
                     map initRuntimeType typeParams ++
                     [Statement $ Call (Nam "va_end") [Var "params"]])
         where
           typeParams = Ty.getTypeParameters cname
           initRuntimeType ty =
-              Assign (Var "this" `Arrow` typeVarRefName ty)
+              Assign (thisVar `Arrow` typeVarRefName ty)
                      (Call (Nam "va_arg") [Var "params", Var "pony_type_t *"])
 
 tracefunDecl :: A.ClassDecl -> CCode Toplevel
@@ -353,7 +353,7 @@ tracefunDecl A.Class{A.cname, A.cfields, A.cmethods} =
                    (Ptr void, Var "p")]
                    (Seq $
                     (Assign (Decl (Ptr (Ptr encoreCtxT), encoreCtxVar)) (Amp ctxArg)):
-                    (Assign (Decl (Ptr . AsType $ classTypeName cname, Var "_this"))
+                    (Assign (Decl (Ptr . AsType $ classTypeName cname, thisVar))
                             (Var "p")) :
                      runtimeTypeAssignment ++
                      map traceField cfields)
@@ -363,12 +363,12 @@ tracefunDecl A.Class{A.cname, A.cfields, A.cmethods} =
       extractTypeVariable t =
          if Ty.isTypeVar t then
             Assign (Decl (Ptr ponyTypeT, AsLval $ typeVarRefName t))
-                   (Arrow (Nam "_this") (typeVarRefName t))
-         else error $ "Expected type variable but found concrete type"
+                   (Arrow thisName (typeVarRefName t))
+         else error "Expected type variable but found concrete type"
       typeParams = Ty.getTypeParameters cname
       traceField A.Field {A.ftype, A.fname} =
         let var = Var . show $ fieldName fname
-            field = Var "_this" `Arrow` fieldName fname
+            field = thisVar `Arrow` fieldName fname
             fieldAssign = Assign (Decl (translate ftype, var)) field
         in Seq [fieldAssign, traceVariable ftype var]
 

src/back/CodeGen/Closure.hs

@@ -11,6 +11,7 @@ import CodeGen.Trace (traceVariable)
 import CodeGen.CCodeNames
 import CodeGen.ClassTable
 import qualified CodeGen.Context as Ctx
+import CodeGen.DTrace
 import CCode.Main
 import qualified Identifiers as ID
 
@@ -69,9 +70,12 @@ translateClosure closure typeVars table
                            (Typ "value_t", Var "_args[]"),
                            (Ptr void, Var "_env")]
                           (Seq $
+                            dtraceClosureEntry argNames :
                             extractArguments params ++
                             extractEnvironment envName freeVars fTypeVars ++
-                            [bodyStat, returnStmnt bodyName resultType])]
+                            [bodyStat
+                            ,dtraceClosureExit
+                            ,returnStmnt bodyName resultType])]
   | otherwise =
         error
         "Tried to translate a closure from something that was not a closure"
@@ -118,8 +122,7 @@ translateClosure closure typeVars table
           ctxArg = Var "_ctx_arg"
           body = Seq $
               Assign (Decl (Ptr (Ptr encoreCtxT), encoreCtxVar)) (Amp ctxArg) :
-              Assign (Decl (Ptr $ Struct envName, Var "_this")) (Var "p") :
+              Assign (Decl (Ptr $ Struct envName, thisVar)) (Var "p") :
               map traceMember members
           traceMember (name, ty) = traceVariable ty $ getVar name
-          getVar name =
-              (Var "_this") `Arrow` fieldName name
+          getVar name = thisVar `Arrow` fieldName name

src/back/CodeGen/DTrace.hs

@@ -0,0 +1,61 @@
+module CodeGen.DTrace where
+
+import CCode.Main
+import CCode.PrettyCCode
+import Identifiers as ID
+import Data.List
+import Text.Printf
+
+dtrace :: String -> [String] -> CCode Stat
+dtrace probe [] =
+    Embed $ printf "ENC_DTRACE0(%s)" probe
+dtrace probe args =
+  let n = length args
+  in
+  Embed $ printf "ENC_DTRACE%d(%s, %s)"
+          n probe (intercalate ", " args)
+
+-- TODO: Args not used; can't use variable size of arguments
+
+dtraceFieldAccess :: CCode Lval -> ID.Name -> CCode Stat
+dtraceFieldAccess target name =
+  dtrace "FIELD_ACCESS" ["(uintptr_t)*_ctx", "(uintptr_t)" ++ pp target, show $ show name]
+
+dtraceFieldWrite :: CCode Lval -> ID.Name -> CCode Stat
+dtraceFieldWrite target name =
+  dtrace "FIELD_WRITE" ["(uintptr_t)*_ctx", "(uintptr_t)" ++ pp target, show $ show name]
+
+dtraceMethodCall :: CCode Lval -> ID.Name -> [CCode Lval] -> CCode Stat
+dtraceMethodCall target name args =
+  dtrace "METHOD_CALL" $ ["(uintptr_t)*_ctx", "(uintptr_t)" ++ pp target, show $ show name] -- ++ map pp args
+
+dtraceMethodEntry :: CCode Lval -> ID.Name -> [CCode Lval] -> CCode Stat
+dtraceMethodEntry this name args =
+  dtrace "METHOD_ENTRY" $ ["(uintptr_t)*_ctx", "(uintptr_t)" ++ pp this, show $ show name] -- ++ map pp args
+
+dtraceMethodExit :: CCode Lval -> ID.Name -> CCode Stat
+dtraceMethodExit this name =
+  dtrace "METHOD_EXIT" ["(uintptr_t)*_ctx", "(uintptr_t)" ++ pp this, show $ show name]
+
+dtraceFunctionCall :: ID.QualifiedName -> [CCode Lval] -> CCode Stat
+dtraceFunctionCall name args =
+  dtrace "FUNCTION_CALL" $ ["(uintptr_t)*_ctx", show $ show name ] -- : map pp args
+
+dtraceFunctionEntry :: ID.Name -> [CCode Lval] -> CCode Stat
+dtraceFunctionEntry name args =
+  dtrace "FUNCTION_ENTRY" ["(uintptr_t)*_ctx", show $ show name] -- : map pp args
+
+dtraceFunctionExit :: ID.Name -> CCode Stat
+dtraceFunctionExit name =
+  dtrace "FUNCTION_EXIT" ["(uintptr_t)*_ctx", show $ show name]
+
+dtraceClosureCall :: ID.QualifiedName -> [CCode Lval] -> CCode Stat
+dtraceClosureCall name args =
+  dtrace "CLOSURE_CALL" ["(uintptr_t)*_ctx", show $ show name] -- : map pp args
+
+dtraceClosureEntry :: [CCode Lval] -> CCode Stat
+dtraceClosureEntry args =
+  dtrace "CLOSURE_ENTRY" ["(uintptr_t)*_ctx"] -- $ map pp args
+
+dtraceClosureExit :: CCode Stat
+dtraceClosureExit = dtrace "CLOSURE_EXIT" ["(uintptr_t)*_ctx"]