A ref change was pushed to the repository containing the project "Grayskull Repository". The branch, master has been updated via 14c57e23348aff2afda7709a05298029bb724ab4 (commit) via c201e3128f4e2dd9937a44e438e80d21fc313eb5 (commit) via 7a41b641fa45571ce3b3a062462f7fa97d198f7f (commit) via 8b61ad032514fbdfd308ae707a3e819e5bed7176 (commit) via 1d7b0a46e4952414efd090a985b0517386b1d300 (commit) from 633a91e55dab62f2552b52e311b721ed6c097985 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 14c57e23348aff2afda7709a05298029bb724ab4 Merge: c201e3128f4e2dd9937a44e438e80d21fc313eb5 633a91e55dab62f2552b52e311b721ed6c097985 Author: Samuel Lang <[email protected]> Date: Wed Dec 16 14:58:33 2009 -0600 Merge branch 'master' of login3.mcs.anl.gov:~dkimpe/git/grayskull commit c201e3128f4e2dd9937a44e438e80d21fc313eb5 Author: Samuel Lang <[email protected]> Date: Wed Dec 16 14:57:31 2009 -0600 fix for pbranch bug found with parallelfor2.gs commit 7a41b641fa45571ce3b3a062462f7fa97d198f7f Author: Samuel Lang <[email protected]> Date: Wed Dec 16 13:28:56 2009 -0600 fixed directory entries commit 8b61ad032514fbdfd308ae707a3e819e5bed7176 Author: Samuel Lang <[email protected]> Date: Wed Dec 16 13:27:20 2009 -0600 basic remote parser. commit 1d7b0a46e4952414efd090a985b0517386b1d300 Author: Samuel Lang <[email protected]> Date: Wed Dec 16 13:15:24 2009 -0600 Adding basic remote functionality. This commit adds some functionality for generating stubs/skeletons using the __remote specifier. ----------------------------------------------------------------------- Summary of changes: code/src/gsl/.gitignore | 5 + code/src/gsl/Makefile.in | 12 +- code/src/gsl/README | 2 +- code/src/gsl/configure.in | 3 + code/src/gsl/include/gs-internal.h | 9 + code/src/gsl/maint/hs/language-c.patch | 98 +++- code/src/gsl/parser/BlockingContext.lhs | 12 +- code/src/gsl/parser/CGen.lhs | 41 +- code/src/gsl/parser/CParse.lhs | 97 ++++- .../{gs-parser.lhs => gs-blocking-parser.lhs} | 183 +++++--- code/src/gsl/parser/gs-remote-parser.lhs | 518 ++++++++++++++++++++ code/src/gsl/parser/module.mk.in | 12 +- code/src/gsl/tests/correctness/funptrs.gs | 35 ++ code/src/gsl/tests/correctness/module.mk.in | 5 +- 14 files changed, 911 insertions(+), 121 deletions(-) create mode 100644 code/src/gsl/.gitignore rename code/src/gsl/parser/{gs-parser.lhs => gs-blocking-parser.lhs} (90%) create mode 100644 code/src/gsl/parser/gs-remote-parser.lhs Diff of changes: diff --git a/code/src/gsl/.gitignore b/code/src/gsl/.gitignore new file mode 100644 index 0000000..571af37 --- /dev/null +++ b/code/src/gsl/.gitignore @@ -0,0 +1,5 @@ +aclocal.m4 +autom4te.cache +build +configure +maint/hs/GHC diff --git a/code/src/gsl/Makefile.in b/code/src/gsl/Makefile.in index 26aac5d..24169b7 100644 --- a/code/src/gsl/Makefile.in +++ b/code/src/gsl/Makefile.in @@ -176,6 +176,9 @@ modlibs = $(MODLIBS_$(call canonname,$(1))) \ MODLIBS_GS = $(call modlibs,$(patsubst %.o,%.gs,$(1))) MODLIBS_C = $(call modlibs,$(patsubst %.o,%.c,$(1))) +modname = $(MODNAME_$(call canonname,$(1))) \ + $(MODNAME_$(patsubst $(srcdir)/%,%,$(1))) + modcc = $(if $(MODCC_$(1)), \ $(MODCC_$(1)),$(CC)) @@ -265,12 +268,12 @@ $(GSOBJS): %.o: %.gs.s $(CFLAGS) $(CWARNS) -Wno-redundant-decls $(call MODCFLAGS_GS,$<) $< $(GSOBJS_INTERM): %.gs.s: %.gs.i parser - $(E)$(builddir)/parser/gs-parser -o $@ -r $*.gs $(GSPRETTY) $*.gs.i + $(E)$(builddir)/parser/gs-blocking-parser -o $@ -r $*.gs $(GSPRETTY) $*.gs.i $(GSOBJS_DUMMY): %.gs.dummyobj: %.gs $(Q) " GSCC $*" $(E)$(call MCC_GS,$<) -D__blocking="" \ - -Dpwait="while(0)" -Dpbranch="" -Dpbreak="break"\ + -Dpwait="while(0)" -Dpbranch="" -Dpbreak="break" -Dpprivate="" -Dpshared=""\ -I$(srcdir)/include/ -x c -c -o $@ $(LIBCFLAGS) \ -Wall -Wno-implicit -Wno-unused -Werror \ $(CFLAGS) $(call MODCFLAGS_GS,$<) $< @@ -285,7 +288,7 @@ $(GSTRHDR_CPP): %.gsh.i: %.gsh $(LIBCFLAGS) $(CFLAGS) $(CWARNS) $(call MODCFLAGS_GS,$<) $(srcdir)/$*.gsh $(GSTRHDR): %.h: %.gsh.i parser - $(E)$(builddir)/parser/gs-parser -j -r $(srcdir)/$*.gsh -o $@ $< + $(E)$(builddir)/parser/gs-blocking-parser -j -r $(srcdir)/$*.gsh -o $@ $< $(LIBOBJS): %.o: %.d $(Q) " CC $@" @@ -311,7 +314,8 @@ $(HSBIN): %: %.lhs $(HSSRC) $(E)$(GHC) -odir $(call canonname,$<) \ -hidir $(call canonname,$<) \ -o $@ \ - -i$(call dir,$<) -ilanguage-c-0.3.1/src --make $< + -main-is $(call modname,$<) \ + -i$(call dir,$<) --make $< LIBRARIES=lib/libgs.a lib/libgstest.a diff --git a/code/src/gsl/README b/code/src/gsl/README index e57faf2..c720212 100644 --- a/code/src/gsl/README +++ b/code/src/gsl/README @@ -10,9 +10,9 @@ On debian/ubuntu, run (requires sudo privs): On systems without haskell binary packages, you'll need to do: * Download/Build/Install ghc from http://www.haskell.org/ghc/ +* Download/Build/Install MTL from http://hackage.haskell.org/cgi-bin/hackage-scripts/package/mtl * Download/Build/Install happy from http://www.haskell.org/happy/ * Download/Build/Install alex from http://www.haskell.org/alex/ -* Download/Build/Install MTL from http://hackage.haskell.org/cgi-bin/hackage-scripts/package/mtl * Then run: setup-langc diff --git a/code/src/gsl/configure.in b/code/src/gsl/configure.in index 77768cb..aef0cb8 100644 --- a/code/src/gsl/configure.in +++ b/code/src/gsl/configure.in @@ -28,7 +28,10 @@ AC_PROG_INSTALL AC_PROG_CC AC_PROG_CPP +AC_C_BIGENDIAN + AC_CHECK_SIZEOF([long int]) +AC_CHECK_SIZEOF(void *) AC_MSG_CHECKING([for required gcc]) if test "x$GCC" = "x"; then diff --git a/code/src/gsl/include/gs-internal.h b/code/src/gsl/include/gs-internal.h index 7b2893b..36a3319 100644 --- a/code/src/gsl/include/gs-internal.h +++ b/code/src/gsl/include/gs-internal.h @@ -1,6 +1,15 @@ #ifndef __GS_INTERNAL_H__ #define __GS_INTERNAL_H__ +#ifdef __STRICT_ANSI__ +/* strict ANSI C doesn't have 'inline' functions, so we use __inline__ instead */ +#define inline __inline__ __attribute__((flatten)) +#endif + +#ifndef __unused +#define __unused __attribute__((unused)) +#endif + /* The gs_ctl structure is used by the gsl generated code to manage parallel and * nested operations. This structure is not needed by resource writers or gsl * code. diff --git a/code/src/gsl/maint/hs/language-c.patch b/code/src/gsl/maint/hs/language-c.patch index e07dbde..9f7ccb5 100644 --- a/code/src/gsl/maint/hs/language-c.patch +++ b/code/src/gsl/maint/hs/language-c.patch @@ -1,6 +1,6 @@ diff -Naur language-c-0.3.3/language-c.cabal language-c-0.3.3-new/language-c.cabal --- language-c-0.3.3/language-c.cabal 2009-07-02 14:11:45.000000000 -0500 -+++ language-c-0.3.3-new/language-c.cabal 2009-07-07 13:08:11.000000000 -0500 ++++ language-c-0.3.3-new/language-c.cabal 2009-12-15 09:16:28.275537558 -0600 @@ -1,4 +1,4 @@ -Name: language-c +Name: language-gsl @@ -28,7 +28,7 @@ diff -Naur language-c-0.3.3/language-c.cabal language-c-0.3.3-new/language-c.cab Extra-Source-Files: AUTHORS AUTHORS.c2hs ChangeLog README diff -Naur language-c-0.3.3/src/Language/C/Data/Position.hs language-c-0.3.3-new/src/Language/C/Data/Position.hs --- language-c-0.3.3/src/Language/C/Data/Position.hs 2009-07-02 14:11:45.000000000 -0500 -+++ language-c-0.3.3-new/src/Language/C/Data/Position.hs 2009-07-07 13:11:58.000000000 -0500 ++++ language-c-0.3.3-new/src/Language/C/Data/Position.hs 2009-12-15 09:16:28.277945977 -0600 @@ -50,7 +50,7 @@ show BuiltinPosition = "<builtin>" show InternalPosition = "<internal>" @@ -40,40 +40,46 @@ diff -Naur language-c-0.3.3/src/Language/C/Data/Position.hs language-c-0.3.3-new position :: Int -> String -> Int -> Int -> Position diff -Naur language-c-0.3.3/src/Language/C/Parser/Lexer.x language-c-0.3.3-new/src/Language/C/Parser/Lexer.x --- language-c-0.3.3/src/Language/C/Parser/Lexer.x 2009-07-02 14:11:45.000000000 -0500 -+++ language-c-0.3.3-new/src/Language/C/Parser/Lexer.x 2009-07-07 13:08:11.000000000 -0500 -@@ -351,6 +351,10 @@ ++++ language-c-0.3.3-new/src/Language/C/Parser/Lexer.x 2009-12-15 09:16:28.280809877 -0600 +@@ -351,6 +351,13 @@ idkwtok ('v' : 'o' : 'l' : 'a' : 't' : 'i' : 'l' : 'e' : []) = tok 8 CTokVolatile idkwtok ('_' : '_' : 'v' : 'o' : 'l' : 'a' : 't' : 'i' : 'l' : 'e' : '_' : '_' : []) = tok 12 CTokVolatile idkwtok ('w' : 'h' : 'i' : 'l' : 'e' : []) = tok 5 CTokWhile +idkwtok ('_':'_':'b':'l':'o':'c':'k':'i':'n':'g':[]) = tok 10 CTokBlocking ++idkwtok ('_':'_':'r':'e':'m':'o':'t':'e':[]) = tok 10 CTokRemote +idkwtok ('p':'w':'a':'i':'t':[]) = tok 5 CTokPWait +idkwtok ('p':'b':'r':'a':'n':'c':'h':[]) = tok 7 CTokPBranch +idkwtok ('p':'b':'r':'e':'a':'k':[]) = tok 6 CTokPBreak ++idkwtok ('p':'p':'r':'i':'v':'a':'t':'e':[]) = tok 6 CTokPPrivate ++idkwtok ('p':'s':'h':'a':'r':'e':'d':[]) = tok 6 CTokPShared idkwtok cs = \pos -> do name <- getNewName diff -Naur language-c-0.3.3/src/Language/C/Parser/Parser.y language-c-0.3.3-new/src/Language/C/Parser/Parser.y --- language-c-0.3.3/src/Language/C/Parser/Parser.y 2009-07-02 14:11:45.000000000 -0500 -+++ language-c-0.3.3-new/src/Language/C/Parser/Parser.y 2009-07-07 13:08:11.000000000 -0500 -@@ -217,6 +217,7 @@ ++++ language-c-0.3.3-new/src/Language/C/Parser/Parser.y 2009-12-15 09:16:28.286135310 -0600 +@@ -217,6 +217,8 @@ typedef { CTokTypedef _ } typeof { CTokTypeof _ } "__thread" { CTokThread _ } +"__blocking" { CTokBlocking _ } ++"__remote" { CTokRemote _ } union { CTokUnion _ } unsigned { CTokUnsigned _ } void { CTokVoid _ } -@@ -236,6 +237,9 @@ +@@ -236,6 +238,11 @@ "__builtin_va_arg" { CTokGnuC GnuCVaArg _ } "__builtin_offsetof" { CTokGnuC GnuCOffsetof _ } "__builtin_types_compatible_p" { CTokGnuC GnuCTyCompat _ } +pwait { CTokPWait _ } +pbranch { CTokPBranch _ } +pbreak { CTokPBreak _ } ++pshared { CTokPShared _ } ++pprivate { CTokPPrivate _ } %% -@@ -359,6 +363,7 @@ +@@ -359,6 +366,7 @@ | iteration_statement { $1 } | jump_statement { $1 } | asm_statement {% withNodeInfo $1 (CAsm $1) } @@ -81,7 +87,7 @@ diff -Naur language-c-0.3.3/src/Language/C/Parser/Parser.y language-c-0.3.3-new/ -- parse C labeled statement (C99 6.8.1) -@@ -473,6 +478,16 @@ +@@ -473,6 +481,16 @@ | for '(' enter_scope declaration expression_opt ';' expression_opt ')' statement leave_scope {% withNodeInfo $1 $ CFor (Right $4) $5 $7 $9 } @@ -98,44 +104,72 @@ diff -Naur language-c-0.3.3/src/Language/C/Parser/Parser.y language-c-0.3.3-new/ -- parse C jump statement (C99 6.8.6) -- -@@ -1188,6 +1203,7 @@ +@@ -550,7 +568,7 @@ + -- storage class and type qualifier + --------------------------------------------------------------------------------------------------------------- + attr :- __attribute__((..)) +-storage_class :- typedef | extern | static | auto | register | __thread ++storage_class :- typedef | extern | static | auto | register | __thread | __blocking | pprivate | ppshared + type_qualifier :- const | volatile | restrict | inline + type_qualifier_list :- type_qualifier+ + +@@ -755,7 +773,7 @@ + + + -- A mixture of type qualifiers (const, volatile, restrict, inline) and storage class specifiers +--- (extern, static, auto, register, __thread), in any order, but containing at least one storage class specifier. ++-- (extern, static, auto, register, __thread, __blocking, pshared, pprivate), in any order, but containing at least one storage class specifier. + -- + -- declaration_qualifier_list :- <permute> type_qualifier* storage_class+ + -- +@@ -1188,6 +1206,10 @@ | volatile {% withNodeInfo $1 $ CVolatQual } | restrict {% withNodeInfo $1 $ CRestrQual } | inline {% withNodeInfo $1 $ CInlineQual } + | "__blocking" {% withNodeInfo $1 $ CBlocking } ++ | "__remote" {% withNodeInfo $1 $ CRemote } ++ | pshared {% withNodeInfo $1 $ CPShared } ++ | pprivate {% withNodeInfo $1 $ CPPrivate } -- a list containing at least one type_qualifier (const, volatile, restrict, inline) -- and additionally CAttrs diff -Naur language-c-0.3.3/src/Language/C/Parser/Tokens.hs language-c-0.3.3-new/src/Language/C/Parser/Tokens.hs --- language-c-0.3.3/src/Language/C/Parser/Tokens.hs 2009-07-02 14:11:45.000000000 -0500 -+++ language-c-0.3.3-new/src/Language/C/Parser/Tokens.hs 2009-07-07 13:08:11.000000000 -0500 -@@ -132,6 +132,10 @@ ++++ language-c-0.3.3-new/src/Language/C/Parser/Tokens.hs 2009-12-15 09:16:28.289379739 -0600 +@@ -132,6 +132,13 @@ | CTokTyIdent !PosLength !Ident -- `typedef-name' identifier | CTokGnuC !GnuCTok !PosLength -- special GNU C tokens | CTokEof -- end of file + | CTokBlocking !PosLength -- '__blocking' ++ | CTokRemote !PosLength -- '__remote' + | CTokPWait !PosLength -- `pwait' + | CTokPBranch !PosLength -- `pbranch' + | CTokPBreak !PosLength -- `pbreak' ++ | CTokPShared !PosLength -- `pshared' ++ | CTokPPrivate !PosLength -- `pprivate' -- special tokens used in GNU C extensions to ANSI C -- -@@ -242,6 +246,10 @@ +@@ -242,6 +249,13 @@ posLenOfTok (CTokIdent pos _) = pos posLenOfTok (CTokTyIdent pos _) = pos posLenOfTok (CTokGnuC _ pos ) = pos +posLenOfTok (CTokBlocking pos ) = pos ++posLenOfTok (CTokRemote pos ) = pos +posLenOfTok (CTokPWait pos ) = pos +posLenOfTok (CTokPBranch pos ) = pos +posLenOfTok (CTokPBreak pos ) = pos ++posLenOfTok (CTokPPrivate pos ) = pos ++posLenOfTok (CTokPShared pos ) = pos posLenOfTok CTokEof = error "tokenPos: Eof" instance Show CToken where -@@ -327,11 +335,15 @@ +@@ -327,11 +341,18 @@ showsPrec _ (CTokTypedef _ ) = showString "typedef" showsPrec _ (CTokTypeof _ ) = showString "typeof" showsPrec _ (CTokThread _ ) = showString "__thread" + showsPrec _ (CTokBlocking _ ) = showString "__blocking" ++ showsPrec _ (CTokRemote _ ) = showString "__remote" showsPrec _ (CTokUnion _ ) = showString "union" showsPrec _ (CTokUnsigned _ ) = showString "unsigned" showsPrec _ (CTokVoid _ ) = showString "void" @@ -144,12 +178,14 @@ diff -Naur language-c-0.3.3/src/Language/C/Parser/Tokens.hs language-c-0.3.3-new + showsPrec _ (CTokPWait _ ) = showString "pwait" + showsPrec _ (CTokPBranch _ ) = showString "pbranch" + showsPrec _ (CTokPBreak _ ) = showString "pbreak" ++ showsPrec _ (CTokPPrivate _ ) = showString "pprivate" ++ showsPrec _ (CTokPShared _ ) = showString "pshared" showsPrec _ (CTokCLit _ c) = shows c showsPrec _ (CTokILit _ i) = shows i showsPrec _ (CTokFLit _ f) = shows f diff -Naur language-c-0.3.3/src/Language/C/Pretty.hs language-c-0.3.3-new/src/Language/C/Pretty.hs --- language-c-0.3.3/src/Language/C/Pretty.hs 2009-07-02 14:11:45.000000000 -0500 -+++ language-c-0.3.3-new/src/Language/C/Pretty.hs 2009-07-07 13:08:11.000000000 -0500 ++++ language-c-0.3.3-new/src/Language/C/Pretty.hs 2009-12-15 09:18:04.042219887 -0600 @@ -151,7 +151,11 @@ pretty (CReturn Nothing _) = ii $ text "return" <> semi pretty (CReturn (Just e) _) = ii $ text "return" <+> pretty e <> semi @@ -163,17 +199,20 @@ diff -Naur language-c-0.3.3/src/Language/C/Pretty.hs language-c-0.3.3-new/src/La let inner = text "{" $+$ mlistP ppLblDecls localLabels $+$ vcat (map pretty bis) $$ text "}" in if p == -1 then inner else ii inner where ppLblDecls = vcat . map (\l -> text "__label__" <+> identP l <+> semi) -@@ -245,6 +249,7 @@ +@@ -245,6 +249,10 @@ pretty (CRestrQual _) = text "__restrict" pretty (CInlineQual _) = text "inline" pretty (CAttrQual a) = attrlistP [a] + pretty (CBlocking _) = text "__blocking" ++ pretty (CRemote _) = text "__remote" ++ pretty (CPShared _) = text "pshared" ++ pretty (CPPrivate _) = text "pprivate" instance Pretty CStructUnion where pretty (CStruct tag ident Nothing cattrs _) = pretty tag <+> attrlistP cattrs <+> maybeP identP ident diff -Naur language-c-0.3.3/src/Language/C/Syntax/AST.hs language-c-0.3.3-new/src/Language/C/Syntax/AST.hs --- language-c-0.3.3/src/Language/C/Syntax/AST.hs 2009-07-02 14:11:45.000000000 -0500 -+++ language-c-0.3.3-new/src/Language/C/Syntax/AST.hs 2009-07-07 13:08:11.000000000 -0500 ++++ language-c-0.3.3-new/src/Language/C/Syntax/AST.hs 2009-12-15 09:19:46.381624818 -0600 @@ -236,6 +236,9 @@ | CBreak NodeInfo -- ^ break statement | CReturn (Maybe CExpr)NodeInfo -- ^ return statement @CReturn returnExpr@ @@ -184,15 +223,18 @@ diff -Naur language-c-0.3.3/src/Language/C/Syntax/AST.hs language-c-0.3.3-new/sr deriving (Data,Typeable {-! CNode !-}) -- | GNU Assembler statement -@@ -349,6 +352,7 @@ +@@ -349,6 +352,10 @@ | CRestrQual NodeInfo | CInlineQual NodeInfo | CAttrQual CAttr -+ | CBlocking NodeInfo ++ | CBlocking NodeInfo -- ^ blocking function ++ | CRemote NodeInfo -- ^ remote function ++ | CPShared NodeInfo -- ^ shared variable across pbranch blocks ++ | CPPrivate NodeInfo -- ^ private variable across pbranch blocks deriving (Data,Typeable {-! CNode !-}) -- | C structure or union specifiers (K&R A8.3, C99 6.7.2.1) -@@ -596,6 +600,9 @@ +@@ -596,6 +603,9 @@ nodeInfo (CBreak nodeinfo) = nodeinfo nodeInfo (CReturn _ nodeinfo) = nodeinfo nodeInfo (CAsm _ nodeinfo) = nodeinfo @@ -202,11 +244,23 @@ diff -Naur language-c-0.3.3/src/Language/C/Syntax/AST.hs language-c-0.3.3-new/sr instance Pos CStat where posOf x = posOfNode (nodeInfo x) -@@ -659,6 +666,7 @@ +@@ -630,6 +640,8 @@ + nodeInfo (CExtern nodeinfo) = nodeinfo + nodeInfo (CTypedef nodeinfo) = nodeinfo + nodeInfo (CThread nodeinfo) = nodeinfo ++ ++ + instance Pos CStorageSpec + where posOf x = posOfNode (nodeInfo x) + +@@ -659,6 +671,10 @@ nodeInfo (CRestrQual nodeinfo) = nodeinfo nodeInfo (CInlineQual nodeinfo) = nodeinfo nodeInfo (CAttrQual d) = nodeInfo d -+ nodeInfo (CBlocking nodeInfo) = nodeInfo ++ nodeInfo (CBlocking nodeinfo) = nodeinfo ++ nodeInfo (CRemote nodeinfo) = nodeinfo ++ nodeInfo (CPPrivate nodeinfo) = nodeinfo ++ nodeInfo (CPShared nodeinfo) = nodeinfo instance Pos CTypeQual where posOf x = posOfNode (nodeInfo x) diff --git a/code/src/gsl/parser/BlockingContext.lhs b/code/src/gsl/parser/BlockingContext.lhs index 077f394..e1bff49 100644 --- a/code/src/gsl/parser/BlockingContext.lhs +++ b/code/src/gsl/parser/BlockingContext.lhs @@ -271,10 +271,14 @@

where newb = mkContextTree parent (Just next) prev b next:rest = fixupContextList parent (Just newb) bs

-> getPWaitDecls :: BlockingContext -> [CDecl] -> getPWaitDecls (PWaitContext id (CPWait (CCompound _ bitems _) _) _ _ _ _ _ _) = -> findFuncDecls bitems -> getPWaitDecls _ = [] +> getPWaitSharedDecls :: BlockingContext -> [CDecl] +> getPWaitSharedDecls (PWaitContext id (CPWait (CCompound _ bitems _) _) _ _ _ _ _ _) = +> filterDecls (\_ -> True) (not . isPrivateSpec) removeSharedSpecFromDecl $ findFuncDecls bitems +> getPWaitSharedDecls _ = [] + +> getPWaitPrivateDecls :: BlockingContext -> [CDecl] +> getPWaitPrivateDecls (PWaitContext id (CPWait (CCompound _ bitems _) _) _ _ _ _ _ _) = +> filterDecls isPrivateSpec (not . isSharedSpec) removePrivateSpecFromDecl $ findFuncDecls bitems

getPWaitId :: BlockingContext -> String getPWaitId (PWaitContext id _ _ _ _ _ _ _) = id diff --git a/code/src/gsl/parser/CGen.lhs b/code/src/gsl/parser/CGen.lhs index 3f95bab..0c33963 100644 --- a/code/src/gsl/parser/CGen.lhs +++ b/code/src/gsl/parser/CGen.lhs @@ -35,18 +35,18 @@ Functions to generate AST objects from C template code -- parse failed, so we assert fail for now. The CDecl empty constructor is needed to match types (Left pe) -> assert False (CDecl [] [] ni)

-> constructStmtFromC :: NodeInfo -> String -> CStat -> constructStmtFromC ni s = +> mkStmtFromC :: NodeInfo -> String -> CStat +> mkStmtFromC ni s =

let result = (execParser_ statementP (mkInputStream s) $ posOfNode ni) in case result of -- parse succeeded, so we return the statement (Right stmt) -> stmt (Left pe) -> trace ("Parse Error in:\n\n" ++ -> ("constructStmtFromC failed: " ++ s) ++ +> ("mkStmtFromC failed: " ++ s) ++ (show pe)) $ assert False (CBreak ni)

mkStmtsFromCLines :: NodeInfo -> String -> [CStat] -> mkStmtsFromCLines ni lines = [constructStmtFromC ni lines] +> mkStmtsFromCLines ni lines = [mkStmtFromC ni lines]

mkCompoundStmt :: Maybe String -> [CStat] -> NodeInfo -> CStat mkCompoundStmt (Just label) stmts ni = CLabel (newIdent label ni) (CCompound [] (map CBlockStmt stmts) ni) [] ni @@ -135,6 +135,9 @@ mkCDecl (CTypeDef "myType") [CPtrDeclr] "baz" genCDecl :: String -> String -> NodeInfo -> CDecl genCDecl typedef name ni = mkCDecl (CTypeDef (newIdent typedef ni) ni) [] name ni

+> addBlockingTQ :: CDecl -> CDecl +> addBlockingTQ (CDecl specs inits ni) = CDecl (CTypeQual ((CBlocking ni)):specs) inits ni + Functions for building a struct from the name and array of members param1Decl can be created with mkCDecl. @@ -212,17 +215,17 @@ Make the function pointer: void (* name) (params);

let ni = nodeInfo returnType in mkCDecl returnType ([mkFunDeclr params ni] ++ returnDerived) fname ni

-> mkFunDeclWithStorageSpecs :: String -> CTypeSpec -> [CDerivedDeclr] -> [CStorageSpec] -> [CDecl] -> CDecl -> mkFunDeclWithStorageSpecs fname rType rDerived storageSpecs params = +> mkFunDeclWithDeclSpecs :: String -> CTypeSpec -> [CDerivedDeclr] -> [CDeclSpec] -> [CDecl] -> CDecl +> mkFunDeclWithDeclSpecs fname rType rDerived declSpecs params =

let ni = nodeInfo rType -> in CDecl ((map CStorageSpec storageSpecs) ++ [CTypeSpec rType]) +> in CDecl (declSpecs ++ [CTypeSpec rType]) [(Just $ mkCDeclr fname ([mkFunDeclr params ni] ++ rDerived), Nothing, Nothing)] ni

-> mkFunPtrDeclWithStorageSpecs :: String -> CTypeSpec -> [CDerivedDeclr] -> [CStorageSpec] -> [CDecl] -> Maybe String -> CDecl -> mkFunPtrDeclWithStorageSpecs fname rType rDerived storageSpecs params initName = +> mkFunPtrDeclWithDeclSpecs :: String -> CTypeSpec -> [CDerivedDeclr] -> [CDeclSpec] -> [CDecl] -> Maybe String -> CDecl +> mkFunPtrDeclWithDeclSpecs fname rType rDerived declSpecs params initName =

let ni = nodeInfo rType -> in CDecl ((map CStorageSpec storageSpecs) ++ [CTypeSpec rType]) +> in CDecl (declSpecs ++ [CTypeSpec rType]) [(Just $ mkCDeclr fname ([CPtrDeclr [] ni, mkFunDeclr params ni] ++ rDerived), (if isJust initName then Just (CInitExpr (CVar (newIdent (fromJust initName) ni) ni) ni) @@ -365,10 +368,10 @@ results in the statement: params->mymem = funcall(a, 123); let ni = nodeInfo rexpr in (CExpr (Just (CAssign CAssignOp (addStructPtrPrefix sname pname (CVar lvar ni)) rexpr ni)) ni)

-> mkFunDef :: CTypeSpec -> [CStorageSpec] -> String -> [CDecl] -> CStat -> CExtDecl -> mkFunDef return sspecs fname params stmts = +> mkFunDef :: CTypeSpec -> [CDeclSpec] -> String -> [CDecl] -> CStat -> CExtDecl +> mkFunDef return dspecs fname params stmts =

let ni = if null params then nodeInfo stmts else nodeInfo $ head params -> in CFDefExt (CFunDef ((map CStorageSpec sspecs) ++ [(CTypeSpec return)]) +> in CFDefExt (CFunDef (dspecs ++ [(CTypeSpec return)]) (CDeclr (Just $ newIdent fname ni) [(CFunDeclr (Right (params, False)) [] ni)] Nothing [] ni) @@ -411,3 +414,15 @@ results in the statement: params->mymem = funcall(a, 123); mkLabel :: String -> [CStat] -> NodeInfo -> CStat mkLabel s stmts ni = (CLabel (newIdent s ni) (CCompound [] (map CBlockStmt stmts) ni) [] ni)

+> canonCDecl :: CDecl -> String +> canonCDecl (CDecl declspecs derived _) = +> let t = getTypeSpec declspecs +> tstr = case t of +> (CSUType (CStruct CStructTag (Just n) _ _ _) _) -> "struct_" ++ (identToString n) +> (CTypeDef n _) -> identToString n +> (CSUType (CStruct CUnionTag (Just n) _ _ _) _) -> "union_" ++ (identToString n) +> (CEnumType (CEnum (Just n) _ _ _) _) -> "enum_" ++ (identToString n) +> _ -> show $ pretty t +> ptrs = filter isDerivedPtr (join $ map getDerivedDeclrs derived) +> ptrStr = concat [ "_ptr" | p <- ptrs ] +> in tstr ++ ptrStr diff --git a/code/src/gsl/parser/CParse.lhs b/code/src/gsl/parser/CParse.lhs index 9ac56a6..de068d5 100644 --- a/code/src/gsl/parser/CParse.lhs +++ b/code/src/gsl/parser/CParse.lhs @@ -69,6 +69,10 @@ Will result in ["a", "b", "c"]

isTypeDefSpec (CStorageSpec (CTypedef _)) = True isTypeDefSpec _ = False

+> isTypeDefTypeSpec :: CDeclSpec -> Bool +> isTypeDefTypeSpec (CTypeSpec (CTypeDef _ _)) = True +> isTypeDefTypeSpec _ = False +

isVoidTypeSpec :: CDeclSpec -> Bool isVoidTypeSpec (CTypeSpec (CVoidType _)) = True isVoidTypeSpec _ = False @@ -77,7 +81,8 @@ Will result in ["a", "b", "c"] isStructDecl (CDecl specs initdecls ni) = any isStructTypeSpec specs

isTypeDefDecl :: CDecl -> Bool -> isTypeDefDecl (CDecl specs initdecls ni) = any isTypeDefSpec specs +> isTypeDefDecl (CDecl (s:specs) initdecls ni) = isTypeDefSpec s +> isTypeDefDecl _ = False

structSpecHasName :: CDeclSpec -> Bool structSpecHasName (CTypeSpec (CSUType (CStruct _ (Just _) _ _ _) _)) = True @@ -97,13 +102,28 @@ Will result in ["a", "b", "c"] isTypeDefSpec s1 && isStructTypeSpec s2 && structSpecHasFields s2 isTypeDefOfInlineStruct _ = False

getStructTypeDefInfo :: CDecl -> Maybe (Maybe String, String) getStructTypeDefInfo d@(CDecl (s1:s2:[]) initdecls ni) | isTypeDefSpec s1 && isStructTypeSpec s2 = -> let (CTypeSpec (CSUType (CStruct _ n _ _ _) _)) = s2 -> sname = if isJust n then Just $ identToString $ fromJust n else Nothing +> let ((Just (CDeclr (Just (Ident tname _ _)) _ _ _ _)), _, _) = head initdecls +> in Just (getStructName s2, tname) +> | otherwise = Nothing

+> isTypeDefOfTypeDef :: CDecl -> Bool +> isTypeDefOfTypeDef (CDecl (s1:s2:[]) _ _) = +> isTypeDefSpec s1 && isTypeDefTypeSpec s2 +> isTypeDefOfTypeDef _ = False + +> getStructName :: CDeclSpec -> Maybe String +> getStructName (CTypeSpec (CSUType (CStruct _ n _ _ _) _)) = if isJust n then Just $ identToString $ fromJust n else Nothing +> getStructName _ = Nothing + + +> getTypeDefTypeDefInfo :: CDecl -> Maybe (String, String) +> getTypeDefTypeDefInfo d@(CDecl (s1:s2:[]) initdecls ni) +> | isTypeDefSpec s1 && isTypeDefTypeSpec s2 = +> let (CTypeSpec (CTypeDef (Ident pname _ _) _)) = s2

((Just (CDeclr (Just (Ident tname _ _)) _ _ _ _)), _, _) = head initdecls

-> in Just (sname, tname) +> in Just (pname, tname)

| otherwise = Nothing

getStructInfo :: CDecl -> Maybe (Maybe String, [CDecl]) @@ -124,6 +144,10 @@ Will result in ["a", "b", "c"] isVarDecl d@(CDecl specs initdecls ni) = (not $ isFunDecl d) && (not $ any isTypeDefSpec specs) && hasDeclrName d

+> getVarName :: CDecl -> String +> getVarName d@(CDecl _ initdecls _) = vname +> where ((Just (CDeclr (Just (Ident vname _ _)) _ _ _ _)), _, _) = head initdecls + For a compound block item (part of a compound block of statements), is the item a declaration?

isFuncDecl :: CBlockItem -> Bool @@ -228,16 +252,79 @@ Get the return type and derived declarators for a function definition isBlockingSpec (CTypeQual (CBlocking _)) = True isBlockingSpec _ = False

+> isPrivateSpec :: CDeclSpec -> Bool +> isPrivateSpec (CTypeQual (CPPrivate _)) = True +> isPrivateSpec _ = False + +> isSharedSpec :: CDeclSpec -> Bool +> isSharedSpec (CTypeQual (CPShared _)) = True +> isSharedSpec _ = False + +> isStdSpec :: CDeclSpec -> Bool +> isStdSpec c = (not $ isBlockingSpec c) && (not $ isPrivateSpec c) && (not $ isSharedSpec c) + +> isRemoteSpec :: CDeclSpec -> Bool +> isRemoteSpec (CTypeQual (CRemote _)) = True +> isRemoteSpec _ = False + +> getDeclSpecs :: CFunDef -> [CDeclSpec] +> getDeclSpecs (CFunDef declspecs _ _ _ _) = declspecs + +> getAllStorageSpecs :: [CDeclSpec] -> [CStorageSpec] +> getAllStorageSpecs declspecs = map getSto $ filter isSto declspecs +> where isSto (CStorageSpec s) = True +> isSto _ = False +> getSto (CStorageSpec s) = s +

getStorageSpecs :: CFunDef -> [CStorageSpec] getStorageSpecs (CFunDef declspecs _ _ _ _) = getStorageSpecsFromDeclSpecs declspecs

getStorageSpecsFromDeclSpecs :: [CDeclSpec] -> [CStorageSpec] getStorageSpecsFromDeclSpecs ((CStorageSpec s):specs) -> | not $ isBlockingSpec (CStorageSpec s) = s:(getStorageSpecsFromDeclSpecs specs) +> | isStdSpec (CStorageSpec s) = s:(getStorageSpecsFromDeclSpecs specs) | otherwise = getStorageSpecsFromDeclSpecs specs getStorageSpecsFromDeclSpecs (s:specs) = getStorageSpecsFromDeclSpecs specs getStorageSpecsFromDeclSpecs [] = []

+> filterDecls :: (CDeclSpec -> Bool) -> (CDeclSpec -> Bool) -> (CDecl -> CDecl) -> [CDecl] -> [CDecl] +> filterDecls anyFunc allFunc transFunc decls = map transFunc $ filter isFilterDecl decls +> where isFilterDecl (CDecl specs l ni) = any anyFunc specs && all allFunc specs + +> isStorageSpec :: CDeclSpec -> Bool +> isStorageSpec (CStorageSpec _) = True +> isStorageSpec _ = False + +> isTypeQual :: CDeclSpec -> Bool +> isTypeQual (CTypeQual _) = True +> isTypeQual _ = False + +> isStdTypeQual :: CDeclSpec -> Bool +> isStdTypeQual (CTypeQual (CRemote _)) = False +> isStdTypeQual (CTypeQual (CBlocking _)) = False +> isStdTypeQual (CTypeQual (CPPrivate _)) = False +> isStdTypeQual (CTypeQual (CPShared _)) = False +> isStdTypeQual (CTypeQual _) = True +> isStdTypeQual _ = False + +> filterStdDeclSpecs :: [CDeclSpec] -> [CDeclSpec] +> filterStdDeclSpecs declspecs = filter (\s -> isStorageSpec s || isStdTypeQual s) declspecs + +> getStdDeclSpecs :: CFunDef -> [CDeclSpec] +> getStdDeclSpecs (CFunDef declspecs _ _ _ _) = filterStdDeclSpecs declspecs + +> removeSharedSpecFromDecl :: CDecl -> CDecl +> removeSharedSpecFromDecl (CDecl specs l ni) = (CDecl rspecs l ni) +> where rspecs = filter (not . isSharedSpec) specs + +> removePrivateSpecFromDecl :: CDecl -> CDecl +> removePrivateSpecFromDecl (CDecl specs l ni) = (CDecl rspecs l ni) +> where rspecs = filter (not . isPrivateSpec) specs + +> removeRemoteSpecFromFunDef :: CExtDecl -> CExtDecl +> removeRemoteSpecFromFunDef (CFDefExt (CFunDef specs declr decls stmt ni)) = +> let newspecs = filter (not . isRemoteSpec) specs +> in (CFDefExt (CFunDef newspecs declr decls stmt ni)) + Get the local declarations for a function definition

getFunLocalDeclarations :: CFunDef -> [CDecl] diff --git a/code/src/gsl/parser/gs-parser.lhs b/code/src/gsl/parser/gs-blocking-parser.lhs similarity index 90% rename from code/src/gsl/parser/gs-parser.lhs rename to code/src/gsl/parser/gs-blocking-parser.lhs index 4be7f2a..166a9e3 100644 --- a/code/src/gsl/parser/gs-parser.lhs +++ b/code/src/gsl/parser/gs-blocking-parser.lhs @@ -1,4 +1,4 @@ -> module Main where +> module BlockingParser where import Language.C import Language.C.Data.Position import Language.C.System.GCC -- preprocessor used @@ -30,12 +30,12 @@ import Header

mkErrorCBPostHandler :: String -> ReturnType -> String -> NodeInfo -> CStat -> mkErrorCBPostHandler fname retType ctlName ni = constructStmtFromC ni $ +> mkErrorCBPostHandler fname retType ctlName ni = mkStmtFromC ni $ "if (!(__gs_postret == GS_POSTED || __gs_postret == GS_COMPLETE))" ++ "{ fprintf(stderr, \"INVALID POST RETURN: %s:%d: post call did not return GS_POSTED or GS_COMPLETE\\n\", \"" ++ fname ++ "\", " ++ (show $ posRow $ posOfNode ni) ++ "); exit(1); }"

mkErrorPostHandler :: String -> ReturnType -> String -> NodeInfo -> CStat -> mkErrorPostHandler fname retType ctlName ni = constructStmtFromC ni $ +> mkErrorPostHandler fname retType ctlName ni = mkStmtFromC ni $ "if (!(__gs_postret == GS_POSTED || __gs_postret == GS_COMPLETE))" ++ "{ fprintf(stderr, \"INVALID POST RETURN: %s:%d: post call did not return GS_POSTED or GS_COMPLETE\\n\", \"" ++ fname ++ "\", " ++ (show $ posRow $ posOfNode ni) ++ "); exit(1); }"

@@ -43,10 +43,10 @@

mkPBreakStmts :: String -> String -> NodeInfo -> ([CDecl], [CStat]) mkPBreakStmts prefix funName ni = ([mkCDecl (CIntType ni) [] "__gs_cancel_ret" ni], -> [constructStmtFromC ni $ "done_ctl->parent->hit_pbreak = 1;", -> constructStmtFromC ni $ "gs_list_del(&done_ctl->link);", -> constructStmtFromC ni $ "__gs_cancel_ret = gs_cancel_children(done_ctl->context, done_ctl->parent);", -> constructStmtFromC ni $ +> [mkStmtFromC ni $ "done_ctl->parent->hit_pbreak = 1;", +> mkStmtFromC ni $ "gs_list_del(&done_ctl->link);", +> mkStmtFromC ni $ "__gs_cancel_ret = gs_cancel_children(done_ctl->context, done_ctl->parent);", +> mkStmtFromC ni $ "if (__gs_cancel_ret != 0)" ++ "{ fprintf(stderr, \"INVALID CANCEL RETURN: %s:%d: cancel did not return 0\\n\", \"" ++ funName ++ "\", " ++ (show $ posRow $ posOfNode ni) ++ "); exit(1); }"])

@@ -57,14 +57,14 @@ either from a pbreak, or from an external cancel call of the entire blocking fun

mkPBranchCallbackStartStmts prefix funName ni = ([mkCDecl (CIntType ni) [] "__gs_pwait_done" ni, mkStructPtrDecl (mkStructCtlName $ funName) "done_ctl" ni], -> [constructStmtFromC ni $ "done_ctl = "++prefix++";", -> constructStmtFromC ni $ "gs_mutex_lock(&done_ctl->parent->mutex);"]) +> [mkStmtFromC ni $ "done_ctl = "++prefix++";", +> mkStmtFromC ni $ "gs_mutex_lock(&done_ctl->parent->mutex);"])

mkPBranchDeleteStmts :: NodeInfo -> [CStat] -> mkPBranchDeleteStmts ni = [constructStmtFromC ni $ "gs_list_del(&done_ctl->link);"] +> mkPBranchDeleteStmts ni = [mkStmtFromC ni $ "gs_list_del(&done_ctl->link);"]

mkPBranchDoneStmts :: String -> String -> NodeInfo -> [CStat] -> mkPBranchDoneStmts prefix funName ni = map (constructStmtFromC ni) +> mkPBranchDoneStmts prefix funName ni = map (mkStmtFromC ni) ["done_ctl->parent->completed++;", "__gs_pwait_done = done_ctl->parent->allposted == 1 && \ \ done_ctl->parent->posted == done_ctl->parent->completed;", @@ -72,21 +72,21 @@ either from a pbreak, or from an external cancel call of the entire blocking fun "free(done_ctl);"]

mkPBranchCBDoneStmts :: BlockingContext -> NodeInfo -> [CStat] -> mkPBranchCBDoneStmts pb ni = map (constructStmtFromC ni) +> mkPBranchCBDoneStmts pb ni = map (mkStmtFromC ni) ["if(!__gs_pwait_done) goto __gs_callback_end;"]

mkPBranchPostDoneStmts :: BlockingContext -> NodeInfo -> [CStat] -> mkPBranchPostDoneStmts pb ni = map (constructStmtFromC ni) +> mkPBranchPostDoneStmts pb ni = map (mkStmtFromC ni) ["if(!__gs_pwait_done) goto __gs_" ++ (getPBranchId pb) ++ "_end;"]

mkDoneStmts :: NodeInfo -> [CStat] mkDoneStmts ni = [mkGoto "__gs_callback_end" ni]

mkDoneCtlSetStmt :: String -> NodeInfo -> CStat -> mkDoneCtlSetStmt p ni = constructStmtFromC ni $ p++" = done_ctl->parent;" +> mkDoneCtlSetStmt p ni = mkStmtFromC ni $ p++" = done_ctl->parent;"

-> mkPWaitInitStmts :: String -> NodeInfo -> [CStat] -> mkPWaitInitStmts prefix ni = mkStmtsFromCLines ni $ +> mkPWaitInitStmts :: String -> String -> NodeInfo -> [CStat] +> mkPWaitInitStmts pwaitParams prefix ni = mkStmtsFromCLines ni $

"{ \ \ "++prefix++"->posted = 0; \ \ "++prefix++"->completed = 0; \ @@ -97,15 +97,16 @@ either from a pbreak, or from an external cancel call of the entire blocking fun \ "++prefix++"->children.next = &("++prefix++"->children); \ \ "++prefix++"->children.prev = &("++prefix++"->children); \ \ "++prefix++"->in_pwait = 1; \ +> \ "++prefix++"->"++pwaitParams++".shared_params = &"++prefix++"->"++pwaitParams++".shared; \ \}"

mkPWaitFinishStmts :: [CStat] -> String -> NodeInfo -> [CStat] mkPWaitFinishStmts afterPWaitStmts prefix ni = [mkCompoundWithDecls Nothing [mkCDecl (CIntType ni) [] "__gs_pwait_done" ni] -> [constructStmtFromC ni $ "gs_mutex_lock(&"++prefix++"->mutex);", -> constructStmtFromC ni $ "__gs_pwait_done = "++prefix++"->posted == "++prefix++"->completed;", -> constructStmtFromC ni $ prefix++"->allposted = 1;", -> constructStmtFromC ni $ "gs_mutex_unlock(&"++prefix++"->mutex);", +> [mkStmtFromC ni $ "gs_mutex_lock(&"++prefix++"->mutex);", +> mkStmtFromC ni $ "__gs_pwait_done = "++prefix++"->posted == "++prefix++"->completed;", +> mkStmtFromC ni $ prefix++"->allposted = 1;", +> mkStmtFromC ni $ "gs_mutex_unlock(&"++prefix++"->mutex);", mkIfElseStmt (Just (constructExprFromC ni "__gs_pwait_done")) afterPWaitStmts []] ni]

@@ -128,16 +129,17 @@ either from a pbreak, or from an external cancel call of the entire blocking fun

mkPBranchPostStmts pwaitName prefix parentPrefix fname stmts ni = [mkCompoundWithDecls Nothing [constructDeclFromC ni ("struct " ++ (mkStructCtlName fname) ++ " *" ++ prefix ++ ";")] -> ([constructStmtFromC ni $ prefix ++ " = malloc(sizeof(*" ++ prefix ++ "));", -> constructStmtFromC ni $ prefix ++ "->parent = " ++ parentPrefix ++ ";", -> constructStmtFromC ni $ prefix++"->context = "++parentPrefix++"->context;", -> constructStmtFromC ni $ prefix++"->hints = "++parentPrefix++"->hints;", -> constructStmtFromC ni $ prefix++"->params = "++parentPrefix++"->params;", -> constructStmtFromC ni $ "memcpy(&"++prefix++"->"++pwaitName++",&"++parentPrefix++"->"++pwaitName++", sizeof("++prefix++"->"++pwaitName++"));", -> constructStmtFromC ni $ "gs_mutex_lock(&("++prefix++"->parent->mutex));", -> constructStmtFromC ni $ "("++prefix++"->parent->posted)++;", -> constructStmtFromC ni $ "gs_list_add(&"++prefix++"->link, &"++prefix++"->parent->children);", -> constructStmtFromC ni $ "gs_mutex_unlock(&("++prefix++"->parent->mutex));"] +> ([mkStmtFromC ni $ prefix ++ " = malloc(sizeof(*" ++ prefix ++ "));", +> mkStmtFromC ni $ prefix ++ "->parent = " ++ parentPrefix ++ ";", +> mkStmtFromC ni $ prefix++"->context = "++parentPrefix++"->context;", +> mkStmtFromC ni $ prefix++"->hints = "++parentPrefix++"->hints;", +> mkStmtFromC ni $ prefix++"->params = "++parentPrefix++"->params;", +> mkStmtFromC ni $ "memcpy(&"++prefix++"->"++pwaitName++".private,&"++parentPrefix++"->"++pwaitName++".private, sizeof("++prefix++"->"++pwaitName++".private));", +> mkStmtFromC ni $ prefix++"->"++pwaitName++".shared_params = &"++parentPrefix++"->"++pwaitName++".shared;", +> mkStmtFromC ni $ "gs_mutex_lock(&("++prefix++"->parent->mutex));", +> mkStmtFromC ni $ "("++prefix++"->parent->posted)++;", +> mkStmtFromC ni $ "gs_list_add(&"++prefix++"->link, &"++prefix++"->parent->children);", +> mkStmtFromC ni $ "gs_mutex_unlock(&("++prefix++"->parent->mutex));"] ++ stmts) ni]

mkBlockingParamsParallelFields :: String -> Bool -> NodeInfo -> [CDecl] @@ -226,14 +228,21 @@ either from a pbreak, or from an external cancel call of the entire blocking fun (fromJust $ getTypeName i) mapM_ lookupAndReg (filter isStructDecl notBlockingFields)

-> registerTypedef :: CDecl -> Maybe String -> WalkerT () -> registerTypedef d altSname = do +> registerTypedefStruct :: CDecl -> Maybe String -> WalkerT () +> registerTypedefStruct d altSname = do

let t = getStructTypeDefInfo d (Just (sn, tname)) = t sname = if isJust sn then sn else altSname assert (isJust t && isJust sname) return () lookupAndRegisterBlockingTypedef (fromJust sname) tname

+> registerTypedefTypedef :: CDecl -> WalkerT () +> registerTypedefTypedef d = do +> let t = getTypeDefTypeDefInfo d +> (Just (pn, tname)) = t +> assert (isJust t) return () +> lookupAndRegisterBlockingTypedef pn tname +

registerBlockingDecl :: Bool -> CExtDecl -> WalkerT [CExtDecl]

registerBlockingDecl ph e@(CDeclExt d@(CDecl specifiers initdecls ni)) @@ -243,17 +252,23 @@ either from a pbreak, or from an external cancel call of the entire blocking fun (show $ posRow $ posOfNode $ nodeInfo d) ++ "_" ++ (show $ posColumn $ posOfNode $ nodeInfo d) registerStruct d (Just name) -> registerTypedef d (Just name) +> registerTypedefStruct d (Just name) if ph then return [e] else return []

| isTypeDefOfPredefStruct d = do

-> registerTypedef d Nothing +> registerTypedefStruct d Nothing

if ph then return [e] else return []

+> | isTypeDefOfTypeDef d = do +> registerTypedefTypedef d +> if ph then +> return [e] +> else return [] + Register structs containing blocking function pointers as fields: struct a { __blocking int (*myfun) (); } Or fields that are structs with blocking function pointers: struct b { struct a mya; } etc. etc. @@ -476,8 +491,29 @@ From a blocking function definition, Construct an external declaration parameter

mkStructPBranchName :: String -> String -> String -> String mkStructPBranchName name pwaitName id = pwaitName ++ "_" ++ name ++ "_" ++ id ++ "_params"

-> mkParamPWaitName :: String -> String -> mkParamPWaitName id = id ++ "_params" +> mkPrivateParamPWaitName :: String -> String -> String +> mkPrivateParamPWaitName name id = name ++ "_" ++ id ++ "_private_params" + +> mkSharedParamPWaitName :: String -> String -> String +> mkSharedParamPWaitName name id = name ++ "_" ++ id ++ "_shared_params" + +> mkPWaitName :: String -> String +> mkPWaitName id = id ++ "_params" + +> mkPrivateName :: String +> mkPrivateName = "private" + +> mkPrivatePWaitName :: String -> String +> mkPrivatePWaitName id = (mkPWaitName id) ++ "." ++ mkPrivateName + +> mkSharedName :: String +> mkSharedName = "shared" + +> mkSharedPtrName :: String +> mkSharedPtrName = "shared_params" + +> mkSharedPWaitName :: String -> String +> mkSharedPWaitName id = (mkPWaitName id) ++ "." ++ mkSharedPtrName

mkParamPBranchName :: String -> String mkParamPBranchName id = id ++ "_params" @@ -500,9 +536,9 @@ From a blocking function definition, Construct an external declaration parameter removeInits :: (String, [CDecl]) -> (String, [CDecl]) removeInits (pwaitName, pwaitDecls) = (pwaitName, (map removeInitFromDecl pwaitDecls))

-> mkPWaitExtDecl :: String -> (String, [CDecl]) -> NodeInfo -> CExtDecl -> mkPWaitExtDecl fname (pwaitName, pwaitDecls) ni = -> genStructExtDecl (mkStructPWaitName fname pwaitName) pwaitDecls ni +> mkPWaitExtDecl :: (String -> String) -> (String, [CDecl]) -> NodeInfo -> CExtDecl +> mkPWaitExtDecl snamef (pwaitName, pwaitDecls) ni = +> genStructExtDecl (snamef pwaitName) pwaitDecls ni

mkBlockingPBranchStructs :: CFunDef -> (String, BlockingContext) -> WalkerT [CExtDecl] mkBlockingPBranchStructs funDef (pwaitName, pwaitCtx) = do @@ -529,13 +565,21 @@ From a blocking function definition, Construct an external declaration parameter let fname = getFunDefName funDef ni = nodeInfo funDef pwaits = getPWaits bctx -> pwaitDecls = zip (map getPWaitId pwaits) (map getPWaitDecls pwaits) -> params = map removeInits pwaitDecls -> allParams = zipWith (addPBranchParams funDef) pwaits params -> pwaitStructs = map (\p -> mkPWaitExtDecl fname p ni) allParams +> ids = map getPWaitId pwaits +> privatePWaitDecls = zip ids (map getPWaitPrivateDecls pwaits) -- :: [(pwait_id, [private_decl])] +> sharedPWaitDecls = zip ids (map getPWaitSharedDecls pwaits) -- :: [(pwait_id, [shared_decl])] +> private = map removeInits privatePWaitDecls -- :: [(pwait_id, [private_decl_no_inits])] +> shared = map removeInits sharedPWaitDecls -- :: [(pwait_id, [shared_decl_no_inits])] +> sharedWithPBranch = zipWith (addPBranchParams funDef) pwaits shared -- :: [(pwait_id, [shared_decl_no_inits] ++ [pbranch_struct_decl])] +> privatePWaitStructs = map (\p -> mkPWaitExtDecl (mkPrivateParamPWaitName fname) p ni) private +> sharedPWaitStructs = map (\p -> mkPWaitExtDecl (mkSharedParamPWaitName fname) p ni) sharedWithPBranch +> pwaitParams = map (\id -> (id, [mkStructDecl (mkPrivateParamPWaitName fname id) mkPrivateName ni, +> mkStructDecl (mkSharedParamPWaitName fname id) mkSharedName ni, +> mkStructPtrDecl (mkSharedParamPWaitName fname id) mkSharedPtrName ni])) ids -- [(pwait_id, [private_struct, shared_struct])] +> pwaitStructs = map (\p -> mkPWaitExtDecl (mkStructPWaitName fname) p ni) pwaitParams pwaitNamePairs = zip (map getPWaitId pwaits) pwaits pbranchStructs <- liftM concat $ mapM (mkBlockingPBranchStructs funDef) pwaitNamePairs -> return $ pbranchStructs ++ pwaitStructs +> return $ pbranchStructs ++ privatePWaitStructs ++ sharedPWaitStructs ++ pwaitStructs | otherwise = return []

mkPBranchExtDecl :: String -> String -> (String, [CDecl]) -> NodeInfo -> CExtDecl @@ -556,7 +600,7 @@ From a blocking function definition, Construct an external declaration parameter fieldsDecl = mkStructDecl spName "fields" ni paramsDecl = mkStructPtrDecl spName "params" ni pwaitDecls = map (\p -> mkStructDecl (mkStructPWaitName fname (getPWaitId p)) -> (mkParamPWaitName (getPWaitId p)) ni) +> (mkPWaitName (getPWaitId p)) ni) $ getPWaits bctx return $ genStructExtDecl ctlName (bparams ++ pparams ++ @@ -626,7 +670,7 @@ runfun(ctl->fields.a, ctl->fields.b, ctl->fields.c, ctl->fields.d); pwaitCtx = getPWaitAncestor bctx locals = join $ map getCDeclNames $ getPBranchDecls pbranchCtx in (addParams2Prefixes ctlPrefix -> (mkParamPWaitName (getPWaitId pwaitCtx)) +> (mkPWaitName (getPWaitId pwaitCtx)) (mkParamPBranchName (getPBranchId pbranchCtx)) locals) stmt | otherwise = stmt @@ -635,10 +679,11 @@ runfun(ctl->fields.a, ctl->fields.b, ctl->fields.c, ctl->fields.d); trPWaitLocals ctlPrefix bctx stmt | hasPWaitAncestor bctx = let pwaitCtx = getPWaitAncestor bctx -> locals = join $ map getCDeclNames $ getPWaitDecls pwaitCtx -> in (addParamsPrefixes ctlPrefix -> (mkParamPWaitName (getPWaitId pwaitCtx)) -> locals) stmt +> privateLocals = join $ map getCDeclNames $ getPWaitPrivateDecls pwaitCtx +> sharedLocals = join $ map getCDeclNames $ getPWaitSharedDecls pwaitCtx +> privatePrefixedStmt = addParamsPrefixes ctlPrefix (mkPrivatePWaitName (getPWaitId pwaitCtx)) privateLocals stmt +> allPrefixedStmt = addParamsPtrPrefixes ctlPrefix (mkSharedPWaitName (getPWaitId pwaitCtx)) sharedLocals privatePrefixedStmt +> in allPrefixedStmt | otherwise = stmt

trFunLocals :: String -> BlockingContext -> CStat -> CStat @@ -670,8 +715,8 @@ to calling the appropriate callback in mkCompoundStmt Nothing [CExpr (Just (CCall (CMember (mkVar "ctl" ni) (newIdent "callback" ni) True ni) ([constructExprFromC ni "ctl->user_ptr"] ++ retparam) ni)) ni, -> constructStmtFromC ni "free(ctl);", -> constructStmtFromC ni "return;"] ni +> mkStmtFromC ni "free(ctl);", +> mkStmtFromC ni "return;"] ni

swapReturnWithCallback c = c

@@ -686,8 +731,8 @@ to calling the appropriate callback

[(CExpr (Just (CCall (CMember (mkVar "ctl" ni) (newIdent "callback" ni) True ni) ([constructExprFromC ni "ctl->user_ptr"] ++ retparam) ni)) ni),

-> constructStmtFromC ni "free(ctl);", -> constructStmtFromC ni "return 0;"] ni +> mkStmtFromC ni "free(ctl);", +> mkStmtFromC ni "return 0;"] ni

swapPostReturnWithCallback c = c

transformPostFuncReturnStmts :: CStat -> CStat @@ -744,7 +789,7 @@ params->val = val; setPBDone mkPBranchPostDoneStmts setTransExit transformPostFuncReturnStmts gspWarn -> ("The blocking function: " ++ fname ++ " does not contain any blocking statements\n") +> ("The blocking function '" ++ fname ++ "' does not contain any blocking statements\n") (getNI b) return tlInitStmts

@@ -921,28 +966,32 @@ Special case where the if has blocking call(s), but the else doesn't (an else ma

getParallelStmts pb@(PBranchContext _ branchDef (b:branchStmts) _ _ _ _ _) tr = do pp <- getPrefix let ni = getNI pb +> nbStmtsBeforePB = nbStmtsBefore pb nbStmts = nbStmtsBefore b pbDeclInits = getInitsFromDecls $ getLocalDeclarations branchDef ctxInitStmts = getCtxInitStmts b -> pwaitName = mkParamPWaitName $ getPWaitId $ getPWaitAncestor pb +> pwaitName = mkPWaitName (getPWaitId $ getPWaitAncestor pb) pbend = [mkLabel ("__gs_" ++ (getPBranchId pb) ++ "_end") [] ni] -> initStmts <- translateForCB b $ (pbDeclInits ++ nbStmts ++ ctxInitStmts) afterPBranchNBStmts <- translateForCB pb (nbStmtsAfter pb) pushPrefix "child_ctl" +> initStmts <- translateForCB b $ (pbDeclInits ++ nbStmts ++ ctxInitStmts) +> setPBDone mkPBranchPostDoneStmts branchPostStmts <- generatePostStmts (Just b) [] cp <- getPrefix -> let branchStmts = mkPBranchPostStmts pwaitName cp pp (getParentName pb) branchPostStmts (nodeInfo branchDef) +> let branchStmts = mkPBranchPostStmts pwaitName cp pp (getParentName pb) (initStmts ++ branchPostStmts) (nodeInfo branchDef) popPrefix -> return $ initStmts ++ branchStmts ++ pbend ++ afterPBranchNBStmts +> return $ branchStmts ++ pbend ++ afterPBranchNBStmts

getParallelStmts pw@(PWaitContext _ waitDef waitStmts@(w:ws) before after parent next prev) tr = do let nbStmts = nbStmtsBefore w pwaitDeclInits = getInitsFromDecls $ getLocalDeclarations waitDef +> pwParamsName = mkPWaitName (getPWaitId pw) firstStmts <- translateForCB w (pwaitDeclInits ++ nbStmts) pStmts <- liftM concat $ mapM (\b -> (getParallelStmts b tr)) waitStmts p <- getPrefix afterPWaitStmts <- generateAfterStmts pw tr -> return $ (mkPWaitInitStmts p $ getNI pw) ++ firstStmts ++ pStmts ++ (mkPWaitFinishStmts afterPWaitStmts p $ getNI pw) +> return $ (mkPWaitInitStmts pwParamsName p $ getNI pw) ++ +> firstStmts ++ pStmts ++ (mkPWaitFinishStmts afterPWaitStmts p $ getNI pw)

getParallelStmts b@(ForContext forDef forStmts@(f:fs) nbBefore nbAfter parent next prev) tr = do p <- getPrefix @@ -1169,7 +1218,7 @@ and finally the code up-to the first blocking call. -- statements before first blocking call ++ (map (trLocals prefix bctx) blockingStmts) ++ [mkLabel "__gs_post_end" [] $ getNI bctx, -> constructStmtFromC (getNI bctx) "if(op_id) *op_id = gs_id_gen(0, (unsigned long)ctl);", +> mkStmtFromC (getNI bctx) "if(op_id) *op_id = gs_id_gen(0, (unsigned long)ctl);", CReturn (Just (mkVar "__gs_postret" $ getNI bctx)) $ getNI bctx]) $ getNI bctx

mkCBParam :: (CTypeSpec, [CDerivedDeclr]) -> NodeInfo -> [CDecl] @@ -1195,21 +1244,21 @@ and finally the code up-to the first blocking call. mkPostDecl f@((,,) fname return params) declspecs = let ni = nodeInfo $ fst return fparams = mkPostParams f -> in mkFunDeclWithStorageSpecs +> in mkFunDeclWithDeclSpecs (fname ++ "_post") (CTypeDef (newIdent "gs_ret_t" ni) ni) [] -> (getStorageSpecsFromDeclSpecs declspecs) +> (filterStdDeclSpecs declspecs) fparams

mkPostPtrDecl :: Bool -> (String, (CTypeSpec, [CDerivedDeclr]), [CDecl]) -> [CDeclSpec] -> CDecl mkPostPtrDecl extern f@((,,) fname return params) declspecs = let ni = nodeInfo $ fst return fparams = mkPostParams f -> in mkFunPtrDeclWithStorageSpecs +> in mkFunPtrDeclWithDeclSpecs fname (CTypeDef (newIdent "gs_ret_t" ni) ni) [] -> ((getStorageSpecsFromDeclSpecs declspecs) ++ -> (if extern then [CExtern ni] else [])) +> ((filterStdDeclSpecs declspecs) ++ +> (if extern then [CStorageSpec $ CExtern ni] else [])) fparams (if not extern then Just (fname ++ "_post") else Nothing)

@@ -1219,7 +1268,7 @@ and finally the code up-to the first blocking call.

params = map translateBlockingFunParam $ removeVoid decls ni = getNI bctx in mkFunDef (CTypeDef (newIdent "gs_ret_t" ni) ni) -- return type

-> (getStorageSpecs funDef) -- get the storage specifiers for the function +> (getStdDeclSpecs funDef) -- get the storage specifiers for the function

(mkPostFunName "params" $ getFunDefName funDef) -- function name (params ++ (mkBlockingParamsForPost funDef)) (mkPostStmts prefix bctx funDef postStmts) -- statements

diff --git a/code/src/gsl/parser/gs-remote-parser.lhs b/code/src/gsl/parser/gs-remote-parser.lhs new file mode 100644 index 0000000..9c4c991 --- /dev/null +++ b/code/src/gsl/parser/gs-remote-parser.lhs @@ -0,0 +1,518 @@ +> module RemoteParser where +> import Language.C +> import Language.C.Data.Position +> import Language.C.System.GCC -- preprocessor used +> import Language.C.Data.Ident +> import System.Environment +> import System.Console.GetOpt +> import System.Exit +> import Data.Typeable +> import Data.Maybe +> import Data.Either +> import Data.HashTable +> import Data.Generics +> import Data.Generics.Schemes +> import qualified Data.ByteString +> import qualified Data.ByteString.Char8 +> import Control.Monad.State +> import Control.Exception +> import Data.List +> import CGen +> import CParse +> import CUtils +> import System.IO.Unsafe +> import Debug.Trace +> import Data.Tree +> import Serialize +> import CParse +> import CGen +> import Header + +> type RemoteTypeRegistry = [String] + +> data Remote = Remote { +> filename :: String, +> typeReg :: RemoteTypeRegistry +> } + +> newRemoteState :: String -> IO Remote +> newRemoteState fname = return $ Remote fname [] + +> getRemoteTypeName :: CTypeSpec -> Maybe String +> getRemoteTypeName (CSUType (CStruct CStructTag (Just n) _ _ _) _) = Just $ "struct_" ++ (identToString n) +> getRemoteTypeName (CSUType (CStruct CUnionTag (Just n) _ _ _) _) = Just $ "union_" ++ (identToString n) +> getRemoteTypeName (CEnumType (CEnum (Just n) _ _ _) _) = Just $ "enum_" ++ (identToString n) +> getRemoteTypeName (CTypeDef n _) = Just $ identToString n +> getRemoteTypeName _ = Nothing + +> mkRemoteDecl :: CDecl -> [CDerivedDeclr] -> String -> Maybe CDecl +> mkRemoteDecl d@(CDecl specs inits ni) ders v = +> let s = getTypeSpec specs +> in case s of +> (CSUType (CStruct CStructTag name _ _ ni2) ni3) -> Just $ mkCDecl (CSUType (CStruct CStructTag name Nothing [] ni2) ni3) ders v ni +> (CSUType (CStruct CUnionTag name _ _ ni2) ni3) -> Just $ mkCDecl (CSUType (CStruct CUnionTag name Nothing [] ni2) ni3) ders v ni +> (CEnumType (CEnum name _ _ ni2) ni3) -> Just $ mkCDecl (CEnumType (CEnum name Nothing [] ni2) ni3) ders v ni +> (CTypeDef name ni2) -> Just $ mkCDecl (CTypeDef name ni2) ders v ni +> _ -> Nothing + +> getFieldTypeName :: CDecl -> RemoteT String +> getFieldTypeName d@(CDecl specs declrs ni) = do +> let t = getTypeSpec specs +> ds = getCDeclrsFromList declrs +> ptrs = if null ds then [] else getDerivedPtrs $ head ds +> tname = getRemoteTypeName t +> ptrStrings = join $ map (\_ -> "_ptr") ptrs +> when (isNothing tname) $ invalid ("parameter '" ++ (show $ pretty d) ++ "' does not have an known encoding type") ni +> return ((fromJust tname) ++ ptrStrings) + +typeof(expr) + +CTypeOfType CDecl NodeInfo + + +> mkEncodeBlock :: NodeInfo -> Bool -> String -> String -> [CStat] +> mkEncodeBlock ni isPtr typeName fieldName = mkStmtsFromCLines ni $ +> "{ \ +> \ ret = gs_encode_"++typeName++"(buf, "++fieldName++", "++(if isPtr then "" else "&")++"x->"++fieldName++"); \ +> \ if(ret != 0) \ +> \ { \ +> \ return ret; \ +> \ } \ +> \}" + +> mkEncodeStmts :: [CDecl] -> NodeInfo -> RemoteT CStat +> mkEncodeStmts fields ni = do +> types <- mapM getFieldTypeName fields +> let vars = map getVarName fields +> return $ mkCompoundWithDecls Nothing [genCDecl "gs_ret_t" "ret" ni] +> ((concat (zipWith (mkEncodeBlock ni False) types vars)) ++ [mkStmtFromC ni "return ret;"]) ni + +> mkEncodeFun :: CDecl -> String -> [CDecl] -> NodeInfo -> RemoteT CExtDecl +> mkEncodeFun decl sname fields ni = do +> stmts <- mkEncodeStmts fields ni +> let tparam = mkRemoteDecl decl [(CPtrDeclr [] ni)] "x" +> when (isNothing tparam) $ invalid "not a known encoding type" ni +> return $ mkFunDef (CTypeDef (newIdent "gs_ret_t" ni) ni) +> [(CStorageSpec (CStatic ni)), (CTypeQual (CInlineQual ni))] +> ("gs_encode_" ++ sname) +> [genCDecl "gs_buffer_t" "buf" ni, +> genCDecl "gs_string_t" "varname" ni, +> fromJust tparam] +> stmts + +> mkDecodeBlock :: NodeInfo -> Bool -> String -> String -> [CStat] +> mkDecodeBlock ni isPtr typeName fieldName = mkStmtsFromCLines ni $ +> "{ \ +> \ ret = gs_decode_"++typeName++"(buf, "++fieldName++", "++(if isPtr then "" else "&")++"x->"++fieldName++"); \ +> \ if(ret != 0) \ +> \ { \ +> \ return ret; \ +> \ } \ +> \}" + +> mkDecodeStmts :: [CDecl] -> NodeInfo -> RemoteT CStat +> mkDecodeStmts fields ni = do +> types <- mapM getFieldTypeName fields +> let vars = map getVarName fields +> return $ mkCompoundWithDecls Nothing [genCDecl "gs_ret_t" "ret" ni] +> ((concat (zipWith (mkDecodeBlock ni False) types vars)) ++ [mkStmtFromC ni "return ret;"]) ni + +> mkDecodeFun :: CDecl -> String -> [CDecl] -> NodeInfo -> RemoteT CExtDecl +> mkDecodeFun decl sname fields ni = do +> stmts <- mkDecodeStmts fields ni +> let tparam = mkRemoteDecl decl [(CPtrDeclr [] ni)] "x" +> when (isNothing tparam) $ invalid "not a known encoding type" ni +> return $ mkFunDef (CTypeDef (newIdent "gs_ret_t" ni) ni) +> [(CStorageSpec (CStatic ni)), (CTypeQual (CInlineQual ni))] +> ("gs_decode_" ++ sname) +> [genCDecl "gs_buffer_t" "buf" ni, +> genCDecl "gs_string_t" "varname" ni, +> fromJust tparam] +> stmts + +> mkSizeBlock :: NodeInfo -> Bool -> String -> String -> [CStat] +> mkSizeBlock ni isPtr typeName fieldName = mkStmtsFromCLines ni $ +> "{ \ +> \ size += gs_encode_size_"++typeName++"("++fieldName++", "++(if isPtr then "" else "&")++"x->"++fieldName++"); \ +> \}" + +> mkSizeStmts :: [CDecl] -> NodeInfo -> RemoteT CStat +> mkSizeStmts fields ni = do +> types <- mapM getFieldTypeName fields +> let vars = map getVarName fields +> return $ mkCompoundWithDecls Nothing [genCDecl "uint64_t" "size" ni] +> ([mkStmtFromC ni "size = 0;"] ++ ((concat (zipWith (mkSizeBlock ni False) types vars))) ++ [mkStmtFromC ni "return size;"]) ni + +> mkSizeFun :: CDecl -> String -> [CDecl] -> NodeInfo -> RemoteT CExtDecl +> mkSizeFun decl sname fields ni = do +> stmts <- mkSizeStmts fields ni +> let tparam = mkRemoteDecl decl [(CPtrDeclr [] ni)] "x" +> when (isNothing tparam) $ invalid "not a known encoding type" ni +> return $ mkFunDef (CTypeDef (newIdent "uint64_t" ni) ni) +> [(CStorageSpec (CStatic ni)), (CTypeQual (CInlineQual ni))] +> ("gs_encode_size_" ++ sname) +> [genCDecl "gs_string_t" "varname" ni, +> fromJust tparam] +> stmts + + +> registerStruct :: CDecl -> RemoteT [CExtDecl] +> registerStruct d@(CDecl specs inits ni) = do +> let si = getStructInfo d +> (Just (_, fields)) = si +> s = getRemoteTypeName (getTypeSpec specs) +> sname = fromJust s +> allFields = join $ map splitDecls fields +> when (isNothing s) $ invalid ("cannot define a remote struct without a name\n") ni +> if (structSpecHasFields (head $ filter isStructTypeSpec specs)) then do +> let newS = CDeclExt $ CDecl (filter (not . isRemoteSpec) specs) inits ni +> enc <- mkEncodeFun d sname allFields ni +> size <- mkSizeFun d sname allFields ni +> dec <- mkDecodeFun d sname allFields ni +> return [newS, size, enc, dec] +> else return [] + + init = mkInitFun d + dest = mkDestroyFun d + +> transDecl :: CExtDecl -> RemoteT [CExtDecl] +> transDecl e@(CDeclExt d@(CDecl specs inits ni)) +> | any isRemoteSpec specs = registerStruct d +> | otherwise = return [] + +> getFileName :: RemoteT String +> getFileName = do +> w <- get +> return $ filename w + +> getFilePosStr :: NodeInfo -> RemoteT String +> getFilePosStr (NodeInfo p _ _) = do +> fname <- getFileName +> return (fname ++ ":" ++ (show $ posRow p) ++ ":" ++ (show $ posColumn p)) + +> type RemoteT = StateT Remote IO + +> invalid :: String -> NodeInfo -> RemoteT () +> invalid msg ni = do +> fstr <- getFilePosStr ni +> error (fstr ++ ": Invalid grayskull usage: " ++ msg) + +> inRemoteStructs :: CDecl -> Bool +> inRemoteStructs _ = True + +> isRemoteFunDef :: CFunDef -> Bool +> isRemoteFunDef (CFunDef specs declr decls stmt ni) = any isRemoteSpec specs + +> filterOutRemoteSpec :: [CDeclSpec] -> [CDeclSpec] +> filterOutRemoteSpec = filter (not . isRemoteSpec) + +> mkStubDecl :: String -> (CTypeSpec, [CDerivedDeclr]) -> [CDecl] -> CDecl +> mkStubDecl fname (retType, retDerived) params = mkFunDecl ("remote_" ++ fname) retType retDerived params + +> mkGSRetType :: NodeInfo -> CTypeSpec +> mkGSRetType ni = (CTypeDef (newIdent "gs_ret_t" ni) ni) + +> mkGSBufferType :: NodeInfo -> CTypeSpec +> mkGSBufferType ni = (CTypeDef (newIdent "gs_buffer_t" ni) ni) + +> mkSkelDecl :: NodeInfo -> String -> CDecl +> mkSkelDecl ni fname = mkFunDecl ("__service_"++fname) (mkGSRetType ni) [] [mkCDecl (mkGSBufferType ni) [(CPtrDeclr [] ni)] "buffer" ni] + +> checkRemoteParams :: NodeInfo -> [CDecl] -> RemoteT () +> checkRemoteParams ni [inputdecl, outputdecl] = do +> let inNI = nodeInfo inputdecl +> inName = identToString $ getCDeclName inputdecl +> outNI = nodeInfo outputdecl +> outName = identToString $ getCDeclName outputdecl +> when (not $ inRemoteStructs inputdecl) $ invalid ("input parameter '"++inName++"' cannot be encoded, must use a __remote type") inNI +> when (not $ inRemoteStructs outputdecl) $ invalid ("output parameter '"++outName++"' cannot be encoded, must use a __remote type") outNI +> let (CDecl specs initdeclrs ni) = outputdecl +> ptrs = filter isDerivedPtr $ join $ map getDerivedDeclrs initdeclrs +> when ((length ptrs) /= 1) $ invalid ("output parameter '"++outName++"' must be a pointer to type") outNI +> return () + +> checkRemoteParams ni _ = do +> invalid "only two parameters allowed for a __remote declaration" ni +> return () + +> isGSReturnType :: CTypeSpec -> Bool +> isGSReturnType (CTypeDef (Ident name _ _) _) = name == "gs_ret_t" + +> checkRemoteReturn :: (CTypeSpec, [CDerivedDeclr]) -> RemoteT () +> checkRemoteReturn (retType, retDerived) = do +> when (not $ isGSReturnType retType) $ invalid "__remote function must have a return type of gs_ret_t" (nodeInfo retType) +> return () + +> registerRemoteDecl :: CExtDecl -> RemoteT [CExtDecl] +> registerRemoteDecl e@(CDeclExt d@(CDecl specs inits ni)) + +> | isStructDecl d && (any isRemoteSpec specs) = transDecl e +> | isFunDecl d && (any isRemoteSpec specs) = do +> let (fname, returnType, params) = splitFunDecl d +> newspecs = filterOutRemoteSpec specs +> ni = nodeInfo e + +> -- only two params allowed right now: input and pointer to output +> checkRemoteParams ni params + +> checkRemoteReturn returnType + +> let [inputdecl, outputdecl] = params +> origDecl = CDeclExt $ (CDecl newspecs inits ni) +> stubDecl = CDeclExt $ addBlockingTQ $ mkStubDecl fname returnType params +> skelDecl = CDeclExt $ addBlockingTQ $ mkSkelDecl ni fname + +> return [origDecl, stubDecl, skelDecl] +> | otherwise = return [e] + +> registerRemoteDecl e = return [e] + +> registerRemoteDecls :: CTranslUnit -> RemoteT CTranslUnit +> registerRemoteDecls (CTranslUnit decls ni) = do +> newdecls <- liftM concat $ sequence $ map registerRemoteDecl decls +> return $ CTranslUnit newdecls ni + +> data ParserOpts = Pretty | Help | Include String | Report String | Outfile String | Header + +> getIncludes :: [ParserOpts] -> [String] +> getIncludes ((Include s):ps) = ("-I" ++ s):(getIncludes ps) +> getIncludes (_:ps) = getIncludes ps +> getIncludes [] = [] + +> getReportFilename :: [ParserOpts] -> Maybe String +> getReportFilename ((Report s):ps) = Just s +> getReportFilename (_:ps) = getReportFilename ps +> getReportFilename [] = Nothing + +> getOutfile :: [ParserOpts] -> Maybe String +> getOutfile ((Outfile s):ps) = Just s +> getOutfile (_:ps) = getOutfile ps +> getOutfile [] = Nothing + +> parserOpts :: [OptDescr ParserOpts] +> parserOpts = +> [ Option ['p'] ["pretty"] (NoArg Pretty) +> "output in pretty form without source line macros" +> , Option ['I'] ["include"] (ReqArg (\s -> Include s) "<include path>") +> "include path for preprocessor" +> , Option ['h','?'] ["help"] (NoArg Help) +> "help text" +> , Option ['r'] ["report"] (ReqArg (\s -> Report s) "<report filename>") +> "filename to use when reporting errors" +> , Option ['o'] ["outfile"] (ReqArg (\s -> Outfile s) "<output file>") +> "filename to write translated C code" +> , Option ['j'] ["header"] (NoArg Header) +> "parse header file instead of source" +> ] + +> optPretty :: ParserOpts -> Bool +> optPretty (Pretty) = True +> optPretty _ = False + +> optHelp :: ParserOpts -> Bool +> optHelp (Help) = True +> optHelp _ = False + +> optHeader :: ParserOpts -> Bool +> optHeader (Header) = True +> optHeader _ = False + +> parseRemoteHeader :: FilePath -> Maybe FilePath -> FilePath -> IO () +> parseRemoteHeader headerfile report outfuile = return () + +> mkStubBlock :: String -> String -> String -> String -> NodeInfo -> [CStat] +> mkStubBlock inTypeName inName outTypeName outName ni = mkStmtsFromCLines ni $ +> "{ \ +> \ ret = gs_encode_maxsize_"++inTypeName++"(&maxsize); \ +> \ if(ret != GS_SUCCESS) \ +> \ { \ +> \ return ret; \ +> \ } \ +> \ ret = gs_buffer_allocate(&buffer, maxsize); \ +> \ if(ret != GS_SUCCESS) \ +> \ { \ +> \ return ret; \ +> \ } \ +> \ ret = gs_encode_"++inTypeName++"(buffer, "++inName++"); \ +> \ if(ret != GS_SUCCESS) \ +> \ { \ +> \ gs_buffer_free(buffer); \ +> \ return ret; \ +> \ } \ +> \ ret = gs_decode_maxsize_"++outTypeName++"(&max_recvsize); \ +> \ if(ret != GS_SUCCESS) \ +> \ { \ +> \ gs_buffer_free(buffer); \ +> \ return ret; \ +> \ } \ +> \ ret = gs_buffer_allocate(&recv_buffer, max_recvsize); \ +> \ if(ret != GS_SUCCESS) \ +> \ { \ +> \ gs_buffer_free(buffer); \ +> \ return ret; \ +> \ } \ +> \ ret = gs_msg_send_recv(id, buffer, recv_buffer); \ +> \ if(ret != GS_SUCCESS) \ +> \ { \ +> \ gs_buffer_free(buffer); \ +> \ gs_buffer_free(recv_buffer); \ +> \ return ret; \ +> \ } \ +> \ ret = gs_decode_"++outTypeName++"(buffer, "++outName++"); \ +> \ gs_buffer_free(buffer); \ +> \ gs_buffer_free(recv_buffer); \ +> \ return ret; \ +> \}" + +> mkStubStmts :: [CDecl] -> NodeInfo -> CStat +> mkStubStmts params ni = +> let [inparam, outparam] = params +> (Ident inParamName _ _) = getCDeclName inparam +> (Ident outParamName _ _) = getCDeclName outparam +> inTypeName = canonCDecl inparam +> outTypeName = canonCDecl outparam + +> in mkCompoundWithDecls Nothing + +> -- declarations +> [genCDecl "gs_buffer_t" "buffer" ni, +> genCDecl "gs_buffer_t" "recv_buffer" ni, +> genCDecl "int" "maxsize" ni, +> genCDecl "gs_ret_t" "ret" ni] + +> (mkStubBlock inTypeName inParamName outTypeName outParamName ni) +> ni + +> mkStubFun :: CFunDef -> CExtDecl +> mkStubFun fundef = +> let fname = getFunDefName fundef +> params = getFunDefParams fundef +> ni = nodeInfo fundef +> in mkFunDef (CTypeDef (newIdent "gs_ret_t" ni) ni) -- return type +> (filterOutRemoteSpec $ getDeclSpecs fundef) -- get the storage specs for the function +> ("remote_" ++ fname) -- the function name for the stub +> ((genCDecl "gs_node_id" "id" ni) : params) -- parameters +> (mkStubStmts params ni) + +> mkSkelBlock :: String -> String -> String -> String -> String -> NodeInfo -> [CStat] +> mkSkelBlock fname inTypeName inName outTypeName outName ni = mkStmtsFromCLines ni $ +> "{ \ +> \ ret = gs_decode_"++inTypeName++"(buffer, "++inName++"); \ +> \ if(ret != GS_SUCCESS) \ +> \ { \ +> \ return ret; \ +> \ } \ +> \ ret = gs_encode_maxsize_"++outTypeName++"(&max_respsize); \ +> \ if(ret != GS_SUCCESS) \ +> \ { \ +> \ return ret; \ +> \ } \ +> \ ret = gs_buffer_allocate(resp_buffer, max_respsize); \ +> \ if(ret != GS_SUCCESS) \ +> \ { \ +> \ return ret; \ +> \ } \ +> \ ret = "++fname++"("++inName++", &"++outName++"); \ +> \ if(ret != GS_SUCCESS) \ +> \ { \ +> \ return ret; \ +> \ } \ +> \ ret = gs_encode_"++outTypeName++"(resp_buffer, "++outName++"); \ +> \ if(ret != GS_SUCCESS) \ +> \ { \ +> \ return ret; \ +> \ } \ +> \ return ret; \ +> \}" + +> mkSkelStmts :: String -> [CDecl] -> NodeInfo -> CStat +> mkSkelStmts fname params ni = +> let [inparam, outparam] = params +> (Ident inParamName _ _) = getCDeclName inparam +> (Ident outParamName _ _) = getCDeclName outparam +> inTypeName = canonCDecl inparam +> outTypeName = canonCDecl outparam + +> in mkCompoundWithDecls Nothing + +> -- declarations +> [genCDecl "int" "maxsize" ni, +> inparam, outparam, +> genCDecl "gs_ret_t" "ret" ni] + +> -- stmts +> (mkSkelBlock fname inTypeName inParamName outTypeName outParamName ni) +> ni + + +> mkSkelFun :: CFunDef -> CExtDecl +> mkSkelFun fundef = +> let fname = getFunDefName fundef +> params = getFunDefParams fundef +> ni = nodeInfo fundef +> in mkFunDef (CTypeDef (newIdent "gs_ret_t" ni) ni) -- return type +> (filterOutRemoteSpec $ getDeclSpecs fundef) -- get the storage specs for the function +> ("__service_" ++ fname) -- the function name for the stub +> [genCDecl "gs_buffer_t *" "buffer" ni, +> genCDecl "gs_buffer_t *" "resp_buffer" ni] +> (mkSkelStmts fname params ni) + +> transformRemote :: CExtDecl -> RemoteT [CExtDecl] +> transformRemote e@(CFDefExt funDef) +> | isRemoteFunDef funDef = do +> let re = removeRemoteSpecFromFunDef e +> stub = mkStubFun funDef +> rstub = removeRemoteSpecFromFunDef stub +> skel = mkSkelFun funDef +> rskel = removeRemoteSpecFromFunDef skel +> return [re, rstub, rskel] +> | otherwise = return [e] +> transformRemote e = return [e] + +> transformR :: CTranslUnit -> RemoteT CTranslUnit +> transformR (CTranslUnit decls ni) = do +> newdecls <- liftM concat $ sequence $ map transformRemote decls +> return $ CTranslUnit newdecls ni + +> generateAST :: FilePath -> IO CTranslUnit +> generateAST input_file = do +> input_stream <- readInputStream input_file +> let parse_result = parseC input_stream (position 0 input_file 1 1) +> case parse_result of +> Left parse_err -> error (show parse_err) +> Right ast -> return ast + +> parseRemote :: Bool -> [String] -> FilePath -> Maybe FilePath -> FilePath -> IO () +> parseRemote p includes outfile report f = do +> let r = if isJust report then fromJust report else f +> w <- newRemoteState r +> ctu <- generateAST f +> (ctuWithDecls, w) <- runStateT (registerRemoteDecls ctu) w +> (transCTU, w) <- runStateT (transformR ctuWithDecls) w +> if p then ((writeFile outfile) . show . pretty) transCTU +> else ((writeFile outfile) . show . serialize) transCTU +> appendFile outfile "\n\n" +> return () + +> main :: IO () +> main = do +> args <- getArgs +> let (opts, files, errs) = getOpt RequireOrder parserOpts args +> pretty = any optPretty opts +> help = any optHelp opts +> includes = getIncludes opts +> outfile = getOutfile opts +> pheader = any optHeader opts +> report = getReportFilename opts +> header = "Usage: gs-remote-parser [OPTIONS...] files..." +> +> when (not $ null errs) $ ioError $ userError ((concat errs) ++ +> (usageInfo header parserOpts)) +> +> when help $ do { putStrLn $ usageInfo header parserOpts ; exitWith (ExitFailure 1) } +> when (isNothing outfile) $ ioError $ userError "No output file specified." + +> when pheader $ do { mapM_ (\f -> parseRemoteHeader f report (fromJust outfile)) files ; exitWith (ExitSuccess) } +> mapM_ (parseRemote pretty includes (fromJust outfile) report) files + +vim: ts=8 sts=4 sw=4 expandtab diff --git a/code/src/gsl/parser/module.mk.in b/code/src/gsl/parser/module.mk.in index 4453ef1..ab1ed82 100644 --- a/code/src/gsl/parser/module.mk.in +++ b/code/src/gsl/parser/module.mk.in @@ -1,6 +1,6 @@ DIR := parser -HSSRC += $(DIR)/gs-parser.lhs \ +HSSRC += $(DIR)/gs-blocking-parser.lhs \ $(DIR)/CGen.lhs \ $(DIR)/CParse.lhs \ $(DIR)/CUtils.lhs \ @@ -8,9 +8,13 @@ HSSRC += $(DIR)/gs-parser.lhs \ $(DIR)/Walker.lhs \ $(DIR)/ContextGen.lhs \ $(DIR)/Serialize.hs \ - $(DIR)/Header.lhs + $(DIR)/Header.lhs \ + $(DIR)/gs-remote-parser.lhs -HSBINSRC += $(DIR)/gs-parser.lhs +HSBINSRC += $(DIR)/gs-blocking-parser.lhs $(DIR)/gs-remote-parser.lhs + +MODNAME_$(DIR)/gs-blocking-parser.lhs = BlockingParser +MODNAME_$(DIR)/gs-remote-parser.lhs = RemoteParser clean:: - rm -rf *.o *.hi gs-parser + rm -rf *.o *.hi gs-blocking-parser gs-remote-parser diff --git a/code/src/gsl/tests/correctness/funptrs.gs b/code/src/gsl/tests/correctness/funptrs.gs index 504a2ea..96e3766 100644 --- a/code/src/gsl/tests/correctness/funptrs.gs +++ b/code/src/gsl/tests/correctness/funptrs.gs @@ -15,6 +15,8 @@ typedef struct int b; } mytype; +typedef mytype ttype; + static __blocking int blocking1(int a) { int ret; @@ -37,6 +39,18 @@ static __blocking int do_mtype_blocking(mytype *t) return t->p->myfun(t->b); } +static __blocking int do_ttype_blocking(ttype *t) +{ + return t->p->myfun(t->b); +} + +typedef ttype atype; + +static __blocking int do_atype_blocking(atype *t) +{ + return t->p->myfun(t->b); +} + static int done = 0; static void *myptr; @@ -74,6 +88,27 @@ int main(int argc, char *argv[]) { gs_poll(NULL, 0); } + + done = 0; + t.p = &s; + t.b = 100; + do_ttype_blocking_post(&t, basic_cb, myptr, NULL, NULL, &id); + + while(done == 0) + { + gs_poll(NULL, 0); + } + + done = 0; + t.p = &s; + t.b = 100; + do_atype_blocking_post(&t, basic_cb, myptr, NULL, NULL, &id); + + while(done == 0) + { + gs_poll(NULL, 0); + } + btest_finalize(); free(myptr); diff --git a/code/src/gsl/tests/correctness/module.mk.in b/code/src/gsl/tests/correctness/module.mk.in index 0ea4a77..238abf2 100644 --- a/code/src/gsl/tests/correctness/module.mk.in +++ b/code/src/gsl/tests/correctness/module.mk.in @@ -34,7 +34,10 @@ GSTESTSRC += $(DIR)/icpfor.gs \ $(DIR)/twofors.gs \ $(DIR)/threefors.gs \ $(DIR)/funptrs.gs \ - $(DIR)/nbfun.gs + $(DIR)/nbfun.gs \ + $(DIR)/pprivate.gs \ + $(DIR)/pshared.gs \ + $(DIR)/pbranch-with-return.gs GSHDR += $(DIR)/btest.gsh hooks/post-receive -- Grayskull Repository