June 2009 - Triton-commits - mailman3.cels.anl.gov

[Gs-commits] r603 - trunk/code/src/gsl
by carns＠mcs.anl.gov 29 Jun '09

29 Jun '09

Author: carns Date: 2009-06-29 14:29:26 -0500 (Mon, 29 Jun 2009) New Revision: 603 Modified: trunk/code/src/gsl/configure.in Log: remove deprecated references to gscc from configure.in Modified: trunk/code/src/gsl/configure.in =================================================================== --- trunk/code/src/gsl/configure.in 2009-06-26 22:05:32 UTC (rev 602) +++ trunk/code/src/gsl/configure.in 2009-06-29 19:29:26 UTC (rev 603) @@ -4,7 +4,7 @@ dnl Process this file with autoconf to produce a configure script. dnl You may need to use autoheader as well if changing any DEFINEs -AC_INIT(parser/gscc.in) +AC_INIT(include/gs.h) AC_CONFIG_HEADER(gs-config.h) AC_CONFIG_AUX_DIR(maint/config) @@ -91,6 +91,5 @@ parser/module.mk resources/scheduling/module.mk resources/scheduling/test/module.mk -examples/module.mk -parser/gscc) +examples/module.mk)

1 0

[Gs-commits] r602 - in trunk/code/src/gsl: . parser resources/mpi/test
by slang＠mcs.anl.gov 26 Jun '09

26 Jun '09

Author: slang Date: 2009-06-26 17:05:32 -0500 (Fri, 26 Jun 2009) New Revision: 602 Removed: trunk/code/src/gsl/parser/gscc Modified: trunk/code/src/gsl/Makefile.in trunk/code/src/gsl/README trunk/code/src/gsl/configure.in trunk/code/src/gsl/parser/CGen.lhs trunk/code/src/gsl/parser/CParse.lhs trunk/code/src/gsl/parser/ContextGen.lhs trunk/code/src/gsl/parser/Walker.lhs trunk/code/src/gsl/parser/gs-parser.lhs trunk/code/src/gsl/resources/mpi/test/pthread-compare.gs Log: preliminary support for __blocking function pointers used in structs, etc. Also get rid of gscc and usage in Makefile.in. Also fix pthread-compare.gs test that now breaks with better checking. Modified: trunk/code/src/gsl/Makefile.in =================================================================== --- trunk/code/src/gsl/Makefile.in 2009-06-24 18:18:54 UTC (rev 601) +++ trunk/code/src/gsl/Makefile.in 2009-06-26 22:05:32 UTC (rev 602) @@ -38,7 +38,6 @@ libdir = $(DESTDIR)@libdir@ VPATH = $(srcdir) -GSCC = $(srcdir)/parser/gscc GSPRETTY = GSDEBUG = ifneq (,@GSL_DEBUG@) @@ -177,8 +176,8 @@ MODLIBS_GS = $(call modlibs,$(patsubst %.o,%.gs,$(1))) MODLIBS_C = $(call modlibs,$(patsubst %.o,%.c,$(1))) -modcc = $(if $(MODCC_$(call canonname,$(1))), \ - $(MODCC_$(call canonname,$(1))),$(CC)) +modcc = $(if $(MODCC_$(1)), \ + $(MODCC_$(1)),$(CC)) MCC_GS = $(call modcc,$(patsubst %.o,%.gs,$(1))) MCC_C = $(call modcc,$(patsubst %.o,%.c,$(1))) @@ -209,6 +208,8 @@ # The C header files generated from .gsh files GSTRHDR=$(patsubst %.gsh,%.h,$(GSHDR)) +GSTRHDR_CPP=$(patsubst %.gsh,%.gsh.i,$(GSHDR)) +GSTRHDR_INTERM=$(patsubst %.gsh,%.gsh.s,$(GSHDR)) # The object files for the gs test library generated from .gs files GSTESTLIBOBJS=$(patsubst %.gs,%.o,$(GSTESTLIBSRC)) @@ -263,17 +264,11 @@ $(E)$(call MCC_GS,$<) -I$(srcdir)/include/ -x c -c -o $@ \ $(LIBCFLAGS) \ $(CFLAGS) $(CWARNS) $(call MODCFLAGS_GS,$<) $< -ifeq (,@GSL_DEBUG@) - $(E)rm $*.gs.s -endif -%.gs.s: %.gs.i parser +$(GSOBJS_INTERM): %.gs.s: %.gs.i parser $(E)$(builddir)/parser/gs-parser -o $@ -r $*.gs $(GSPRETTY) $*.gs.i - $(E)rm $*.gs.i -.PRECIOUS: %.gs.dummyobj %.gs.i - -%.gs.dummyobj: %.gs +$(GSOBJS_DUMMY): %.gs.dummyobj: %.gs $(Q) " GSCC $*" $(E)$(call MCC_GS,$<) -D__blocking="" \ -Dpwait="while(0)" -Dpbranch="" -Dpbreak="break"\ @@ -281,17 +276,21 @@ -Wall -Wno-implicit -Wno-unused -Werror \ $(CFLAGS) $(call MODCFLAGS_GS,$<) $< -%.gs.i: %.gs %.gs.dummyobj - $(E)rm $*.gs.dummyobj +$(GSOBJS_CPP): %.gs.i: %.gs %.gs.dummyobj $(E)$(call MCC_GS,$<) -I$(srcdir)/include/ -x c -E -o $*.gs.i \ - $(LIBCFLAGS) $(CFLAGS) $(CWARNS) $(call MODCFLAGS_GS,$<) $*.gs + $(LIBCFLAGS) $(CFLAGS) $(CWARNS) $(call MODCFLAGS_GS,$<) $(srcdir)/$*.gs -$(GSTRHDR): %.h: %.gsh parser +$(GSTRHDR_CPP): %.gsh.i: %.gsh $(Q) " GSCC $<" - $(E)$(GSCC) --compiler "$(call MCC_GS,$<)" \ - --genheader --outfile $@ \ - $(LIBCFLAGS) $(CFLAGS) $(CWARNS) $(call modcflags,$<) $< + $(E)$(call MCC_GS,$<) -I$(srcdir)/include/ -x c -E -o $*.gsh.i \ + $(LIBCFLAGS) $(CFLAGS) $(CWARNS) $(call MODCFLAGS_GS,$<) $(srcdir)/$*.gsh +$(GSTRHDR_INTERM): %.gsh.s: %.gsh.i parser + $(E)$(builddir)/parser/gs-parser -o $@ -r $*.gsh $*.gsh.i + +$(GSTRHDR): %.h: %.gsh.s + $(E)$(srcdir)/parser/gs-gen-header.sh $< $(srcdir)/$*.gsh > $@ + $(LIBOBJS): %.o: %.d $(Q) " CC $@" $(E)$(call MCC_C,$(patsubst %.d,%.c,$<)) -c -o $@ \ @@ -313,7 +312,10 @@ $(HSBIN): %: %.lhs $(HSSRC) $(Q) " GHC $@" - $(E)$(GHC) -i$(call dir,$<) -ilanguage-c-0.3.1/src --make $< + $(E)$(GHC) -odir $(call canonname,$<) \ + -hidir $(call canonname,$<) \ + -o $@ \ + -i$(call dir,$<) -ilanguage-c-0.3.1/src --make $< LIBRARIES=lib/libgs.a lib/libgstest.a Modified: trunk/code/src/gsl/README =================================================================== --- trunk/code/src/gsl/README 2009-06-24 18:18:54 UTC (rev 601) +++ trunk/code/src/gsl/README 2009-06-26 22:05:32 UTC (rev 602) @@ -1,7 +1,4 @@ -The gs-parser binary is included in the repo so that haskell -and extra libs aren't required to use it on x86 platforms. - If you want to build/install haskell and the necessary haskell libraries for gsl, you should follow these steps: @@ -18,3 +15,6 @@ * Download/Build/Install MTL from http://hackage.haskell.org/cgi-bin/hackage-scripts/package/mtl * Then run: setup-langc + +NOTE: Building by hand turns out to be a big PITA, its highly recommended +that you find a system where you can install the debian packages. Modified: trunk/code/src/gsl/configure.in =================================================================== --- trunk/code/src/gsl/configure.in 2009-06-24 18:18:54 UTC (rev 601) +++ trunk/code/src/gsl/configure.in 2009-06-26 22:05:32 UTC (rev 602) @@ -4,7 +4,7 @@ dnl Process this file with autoconf to produce a configure script. dnl You may need to use autoheader as well if changing any DEFINEs -AC_INIT(parser/gscc) +AC_INIT(parser/gscc.in) AC_CONFIG_HEADER(gs-config.h) AC_CONFIG_AUX_DIR(maint/config) @@ -91,5 +91,6 @@ parser/module.mk resources/scheduling/module.mk resources/scheduling/test/module.mk -examples/module.mk) +examples/module.mk +parser/gscc) Modified: trunk/code/src/gsl/parser/CGen.lhs =================================================================== --- trunk/code/src/gsl/parser/CGen.lhs 2009-06-24 18:18:54 UTC (rev 601) +++ trunk/code/src/gsl/parser/CGen.lhs 2009-06-26 22:05:32 UTC (rev 602) @@ -194,6 +194,11 @@ > let ni = nodeInfo retType > in mkCDecl retType (mkFunPtrDeclr params) name ni +> mkFunPtrDerivedDecl :: String -> CTypeSpec -> [CDerivedDeclr] -> [CDecl] -> CDecl +> mkFunPtrDerivedDecl name retType retDerived params = +> let ni = nodeInfo retType +> in mkCDecl retType ((mkFunPtrDeclr params) ++ retDerived) name ni + > mkVoidFunPtr :: String -> [CDecl] -> CDecl > mkVoidFunPtr name params = > let ni = nodeInfo $ head params Modified: trunk/code/src/gsl/parser/CParse.lhs =================================================================== --- trunk/code/src/gsl/parser/CParse.lhs 2009-06-24 18:18:54 UTC (rev 601) +++ trunk/code/src/gsl/parser/CParse.lhs 2009-06-26 22:05:32 UTC (rev 602) @@ -79,10 +79,17 @@ > getTypeSpec :: [CDeclSpec] -> CTypeSpec > getTypeSpec declspecs = getTypeSpecFromDeclSpec $ fromJust $ find isTypeSpec declspecs +> getTypeSpecFromDecl :: CDecl -> CTypeSpec +> getTypeSpecFromDecl (CDecl dspecs _ _) = getTypeSpec dspecs + > isDerivedPtr :: CDerivedDeclr -> Bool > isDerivedPtr (CPtrDeclr _ _) = True > isDerivedPtr _ = False +> getDerivedDeclrs :: (Maybe CDeclr, Maybe CInit, Maybe CExpr) -> [CDerivedDeclr] +> getDerivedDeclrs (Just (CDeclr _ derived _ _ _), _, _) = derived +> getDerivedDeclrs _ = [] + > getDerivedPtrs :: CDeclr -> [CDerivedDeclr] > getDerivedPtrs (CDeclr _ derivedDeclrs _ _ _) = filter isDerivedPtr derivedDeclrs @@ -188,6 +195,9 @@ > isFunDeclr (CFunDeclr _ _ _) = True > isFunDeclr _ = False +> isFunDecl :: CDecl -> Bool +> isFunDecl (CDecl specs drs _) = or $ map (any isFunDeclr) $ map getDerivedDeclrs drs + > blockItemIsDecl :: CBlockItem -> Bool > blockItemIsDecl (CBlockDecl _) = True > blockItemIsDecl _ = False Modified: trunk/code/src/gsl/parser/ContextGen.lhs =================================================================== --- trunk/code/src/gsl/parser/ContextGen.lhs 2009-06-24 18:18:54 UTC (rev 601) +++ trunk/code/src/gsl/parser/ContextGen.lhs 2009-06-26 22:05:32 UTC (rev 602) @@ -85,22 +85,25 @@ > return $ mkContextTree Nothing Nothing Nothing fctx > isBlockingCall :: CExpr -> WalkerT Bool -> isBlockingCall (CCall (CVar funId _) args _) = do -> res <- lookupBlocking $ identToString funId +> isBlockingCall (CCall v args _) = do +> res <- lookupBlocking v > if (isJust res) then (return True) else (return False) > isBlockingCall _ = return False > containsBlockingCall :: CStat -> WalkerT Bool > containsBlockingCall stmt = do > anyBlocking <- everything orElseMBool (mkQ (return False) isBlockingCall) $ stmt -> case stmt of -> (CPBranch stmts ni) | not anyBlocking -> do +> if not anyBlocking then +> case stmt of +> (CPBranch stmts ni) -> do > fstr <- getFilePosStr ni > error $ fstr ++ ": The pbranch block does not contain a blocking call" -> (CPWait stmts ni) | not anyBlocking -> do +> (CPWait stmts ni) -> do > fstr <- getFilePosStr ni > error $ fstr ++ ": The pwait block does not contain a blocking call" -> otherwise -> return anyBlocking +> _ -> return anyBlocking +> +> else return $ anyBlocking > splitAtBlocking :: [CStat] -> WalkerT ([Either CStat [CStat]]) > splitAtBlocking ls = do @@ -108,8 +111,8 @@ > return split > countBlocking :: CExpr -> WalkerT Int -> countBlocking (CCall (CVar funId _) _ _) = do -> res <- lookupBlocking $ identToString funId +> countBlocking (CCall e _ _) = do +> res <- lookupBlocking e > if (isJust res) then (return 1) else (return 0) > countBlocking _ = return 0 Modified: trunk/code/src/gsl/parser/Walker.lhs =================================================================== --- trunk/code/src/gsl/parser/Walker.lhs 2009-06-24 18:18:54 UTC (rev 601) +++ trunk/code/src/gsl/parser/Walker.lhs 2009-06-26 22:05:32 UTC (rev 602) @@ -13,138 +13,248 @@ > import Debug.Trace > import Control.Monad.State > import BlockingContext +> import CParse +> import CGen +> import Control.Monad.Error Registry for blocking operations. Once we see a function declaration with the __blocking specifier, we add it to the registry. > type ReturnType = (CTypeSpec, [CDerivedDeclr]) +> type FunDecl = (String, ReturnType, [CDecl]) -> type Registry = HashTable String (String, ReturnType, [CDecl]) -> newRegistry :: IO Registry -> newRegistry = Data.HashTable.new (==) Data.HashTable.hashString +> data FPType = FPFun { name :: String , ftype :: FunDecl } +> | FPStruct { name :: String , field :: String, inner :: FPType } +> type FPTypeRegistry = [FPType] + +> type VarMap = HashTable String CDecl + +> data VarRegistry = VarRegistry { locals :: VarMap , globals :: VarMap } + +> newVarRegistry :: IO VarRegistry +> newVarRegistry = do +> l <- Data.HashTable.new (==) Data.HashTable.hashString +> g <- Data.HashTable.new (==) Data.HashTable.hashString +> return $ VarRegistry l g + +> resetLocalVarsInRegistry :: VarRegistry -> IO VarRegistry +> resetLocalVarsInRegistry v = do +> l <- Data.HashTable.new (==) Data.HashTable.hashString +> return $ VarRegistry l (globals v) + +> insertGlobalDeclsToVarRegistry :: [CDecl] -> VarRegistry -> IO () +> insertGlobalDeclsToVarRegistry decls v = do +> let alldecls = concatMap splitDecls decls +> mapM_ (\d -> Data.HashTable.insert (globals v) (identToString . getCDeclName $ d) d) alldecls + +> insertLocalDeclsToVarRegistry :: [CDecl] -> VarRegistry -> IO () +> insertLocalDeclsToVarRegistry decls v = do +> let alldecls = concatMap splitDecls decls +> mapM_ (\d -> Data.HashTable.insert (locals v) (identToString . getCDeclName $ d) d) alldecls + +> lookupInVarRegistry :: String -> VarRegistry -> IO (Maybe CDecl) +> lookupInVarRegistry s v = do +> res <- Data.HashTable.lookup (locals v) s +> if isJust res +> then return res +> else Data.HashTable.lookup (globals v) s + The monad transformer that we thread through our functions -> type FunPtrRegistry = Registry - The Walker is the state that we pass around our functions as we walk the AST. It primarily holds the blocking call information, but is actually a tuple of: filename, prefix stack, blocking call registry, and blocking function pointer registry > data Walker = Walker { -> filename :: String, -> prefixes :: [String], -> errorWriter :: (ReturnType -> String -> NodeInfo -> CStat), -> pbranchDone :: (BlockingContext -> NodeInfo -> [CStat]), -> transExit :: (CStat -> CStat), -> blockingCalls :: Registry, -> fprBlockingCalls :: FunPtrRegistry } +> filename :: String, +> prefixes :: [String], +> errorWriter :: (ReturnType -> String -> NodeInfo -> CStat), +> pbranchDone :: (BlockingContext -> NodeInfo -> [CStat]), +> transExit :: (CStat -> CStat), +> fpTypeReg :: FPTypeRegistry, +> fpTypeLocalReg :: FPTypeRegistry, +> varReg :: VarRegistry +> } > newWalkerState :: String -> (ReturnType -> String -> NodeInfo -> CStat) -> (BlockingContext -> NodeInfo -> [CStat]) -> (CStat -> CStat) -> IO Walker > newWalkerState fname errorWriter pbranchDone transExit = do -> reg <- newRegistry -> fpreg <- newRegistry -> return $ Walker fname ["ctl"] errorWriter pbranchDone transExit reg fpreg +> varReg <- newVarRegistry +> return $ Walker fname ["ctl"] errorWriter pbranchDone transExit [] [] varReg > setErrorWriter :: (ReturnType -> String -> NodeInfo -> CStat) -> WalkerT () > setErrorWriter ew = do -> (Walker f ps _ pb t r fpr) <- get -> put (Walker f ps ew pb t r fpr) +> (Walker f ps _ pb t fr frl vr) <- get +> put (Walker f ps ew pb t fr frl vr) > getErrorWriter :: WalkerT (ReturnType -> String -> NodeInfo -> CStat) > getErrorWriter = do -> (Walker _ _ e _ _ _ _) <- get -> return e +> w <- get +> return $ errorWriter w > setPBDone :: (BlockingContext -> NodeInfo -> [CStat]) -> WalkerT () > setPBDone pb = do -> (Walker f ps ew _ t r fpr) <- get -> put (Walker f ps ew pb t r fpr) +> (Walker f ps ew _ t fr frl vr) <- get +> put (Walker f ps ew pb t fr frl vr) > getPBDone :: WalkerT (BlockingContext -> NodeInfo -> [CStat]) > getPBDone = do -> (Walker _ _ _ pb _ _ _) <- get -> return pb +> w <- get +> return $ pbranchDone w > setTransExit :: (CStat -> CStat) -> WalkerT () > setTransExit tr = do -> (Walker f ps e pb _ r fpr) <- get -> put (Walker f ps e pb tr r fpr) +> (Walker f ps e pb _ fr frl v) <- get +> put (Walker f ps e pb tr fr frl v) > getTransExit :: WalkerT (CStat -> CStat) > getTransExit = do -> (Walker _ _ _ _ tr _ _) <- get -> return tr +> w <- get +> return $ transExit w > pushPrefix :: String -> WalkerT () > pushPrefix s = do -> (Walker f ps e pb t r fpr) <- get -> put (Walker f (s:ps) e pb t r fpr) +> (Walker f ps e pb t fr frl v) <- get +> put (Walker f (s:ps) e pb t fr frl v) > popPrefix :: WalkerT () > popPrefix = do -> (Walker f (s:ps) e pb t r fpr) <- get -> put (Walker f ps e pb t r fpr) +> (Walker f (s:ps) e pb t fr frl v) <- get +> put (Walker f ps e pb t fr frl v) > getPrefix :: WalkerT String > getPrefix = do -> (Walker _ (s:ps) _ _ _ _ _) <- get -> return s +> w <- get +> return $ head $ prefixes w > type WalkerT = StateT Walker IO -> getRegistry :: WalkerT Registry -> getRegistry = do -> (Walker f s _ _ _ r fpr) <- get -> return r - > getFileName :: WalkerT String > getFileName = do -> (Walker f s _ _ _ r fpr) <- get -> return f +> w <- get +> return $ filename w > getFilePosStr :: NodeInfo -> WalkerT (String) > getFilePosStr (NodeInfo (Position _ r c) _) = do > fname <- getFileName > return (fname ++ ":" ++ (show r) ++ ":" ++ (show c)) -> getFunPtrRegistry :: WalkerT FunPtrRegistry -> getFunPtrRegistry = do -> (Walker f s _ _ _ r fpr) <- get -> return fpr +> clearLocalFunPtrRegistry :: WalkerT () +> clearLocalFunPtrRegistry = do +> (Walker s pn e pb t fr frl v) <- get +> put (Walker s pn e pb t fr [] v) -> clearFunPtrRegistry :: WalkerT () -> clearFunPtrRegistry = do -> (Walker s pn e pb t r n) <- get -> newreg <- liftIO newRegistry -> put (Walker s pn e pb t r newreg) +> resetLocals :: WalkerT () +> resetLocals = do +> (Walker f ps ew pb t fpr fr vr) <- get +> newvr <- liftIO $ resetLocalVarsInRegistry vr +> put (Walker f ps ew pb t fpr fr newvr) -> registerBlocking :: (String, ReturnType, [CDecl]) -> WalkerT () -> registerBlocking ((,,) fname return params) = do -> reg <- getRegistry -> liftIO $ Data.HashTable.insert reg fname (fname, return, params) +> addLocals :: [CDecl] -> WalkerT () +> addLocals ds = do +> w <- get +> liftIO $ insertLocalDeclsToVarRegistry ds $ varReg w -> lookupBlocking :: String -> WalkerT (Maybe (String, ReturnType, [CDecl])) -> lookupBlocking fcall = do -> fpreg <- getFunPtrRegistry -> fpres <- liftIO $ Data.HashTable.lookup fpreg fcall -> if isJust fpres then return fpres else do -> reg <- getRegistry -> res <- liftIO $ Data.HashTable.lookup reg fcall -> return res - -> isBlockingFunPtr :: String -> WalkerT Bool -> isBlockingFunPtr fcall = do -> fpreg <- getFunPtrRegistry -> fpres <- liftIO $ Data.HashTable.lookup fpreg fcall -> if isJust fpres then return True else return False +> addGlobals :: [CDecl] -> WalkerT () +> addGlobals ds = do +> w <- get +> liftIO $ insertGlobalDeclsToVarRegistry ds $ varReg w -> registerBlockingFunPtr :: (String, ReturnType, [CDecl]) -> WalkerT () -> registerBlockingFunPtr ((,,) fname return params) = do -> reg <- getFunPtrRegistry -> liftIO $ Data.HashTable.insert reg fname (fname, return, params) +Get the chain of variable references starting +at the outermost. i.e. +struct a a1; +struct b b1; +typedef struct c ct; +ct c1; +struct d d1; + +a1->b1->c1->d1 + +Turns into: + +(a, [b1, c1, d1]) + +> lookupVar :: CExpr -> WalkerT (Maybe [String]) +> lookupVar e@(CVar name _) = do +> w <- get +> d <- liftIO $ lookupInVarRegistry (identToString name) $ varReg w +> if isNothing d +> then return Nothing +> else do +> let t = getTypeSpecFromDecl $ fromJust d +> r = case t of +> (CTypeDef tname _) -> Just [identToString tname] +> (CSUType (CStruct _ (Just tname) _ _ _) _) -> Just [identToString tname] +> _ -> Nothing +> if isJust r +> then return r +> else if isFunDecl $ fromJust d +> then return $ Just [identToString $ getCDeclName $ fromJust d] +> else return Nothing + +> lookupVar (CMember expr name _ _) = do +> w <- get +> inner <- lookupVar expr +> if isNothing inner +> then return Nothing +> else return $ Just $ (fromJust inner) ++ [identToString name] + +> lookupVar e = do +> return Nothing + +> insertFP :: FPType -> WalkerT () +> insertFP fptype = do +> (Walker f ps ew pb t fr frl vr) <- get +> put (Walker f ps ew pb t (fptype:fr) frl vr) + +> registerBlocking :: FunDecl -> WalkerT () +> registerBlocking f = do +> let (n, (rt, rd), p) = f +> insertFP $ FPFun n f + +> let d = mkFunDecl n rt rd p +> addGlobals [d] + +> registerBlockingStruct :: String -> String -> FPType -> WalkerT () +> registerBlockingStruct s f n = insertFP $ FPStruct s f n + +> registerLocalBlocking :: FunDecl -> WalkerT () +> registerLocalBlocking fd = do +> (Walker f ps ew pb t fr frl vr) <- get +> let (n, _, _) = fd +> put (Walker f ps ew pb t fr ((FPFun n fd):frl) vr) + +> getAllBlocking :: WalkerT [FPType] +> getAllBlocking = do +> w <- get +> let bs = fpTypeReg w +> bls = fpTypeLocalReg w +> return $ bs ++ bls + +> matchFP :: [String] -> FPType -> Maybe FunDecl +> matchFP (s:seqs) (FPStruct n f t) = if s == n then matchiFP seqs t else Nothing +> matchFP s f = matchiFP s f + +> matchiFP :: [String] -> FPType -> Maybe FunDecl +> matchiFP [] _ = Nothing +> matchiFP (s:[]) (FPFun n t) = if s == n then Just t else Nothing +> matchiFP (s:seqs) (FPFun n t) = Nothing +> matchiFP (s:seqs) (FPStruct n f t) = if s == f then matchFP seqs t else Nothing + +> lookupBlocking :: CExpr -> WalkerT (Maybe FunDecl) +> lookupBlocking (CCall e _ _) = lookupBlocking e +> lookupBlocking c = do +> w <- get +> v <- lookupVar c +> if isNothing v +> then do +> return Nothing +> else do +> let fs = mapMaybe (matchFP $ fromJust v) $ fpTypeReg w +> if null fs then return Nothing else return $ Just $ head fs + Utility lift the print function into the WalkerT monad transformer > putStrLnW :: String -> WalkerT () Modified: trunk/code/src/gsl/parser/gs-parser.lhs =================================================================== --- trunk/code/src/gsl/parser/gs-parser.lhs 2009-06-24 18:18:54 UTC (rev 601) +++ trunk/code/src/gsl/parser/gs-parser.lhs 2009-06-26 22:05:32 UTC (rev 602) @@ -229,7 +229,7 @@ > fname = identToString f > (Just funDeclr) = find isFunDeclr derivedDeclrs > params = getCFunDeclrParams funDeclr -> registerBlockingFunPtr (fname, (retType, derivedDeclrs), params) +> registerLocalBlocking (fname, (retType, derivedDeclrs), params) > | otherwise = return () > translateBlockingFunParam :: CDecl -> CDecl @@ -333,8 +333,8 @@ > isValidPWait (CPWait stmts ni) = return () > getBlockingCallName :: CExpr -> WalkerT (Maybe String) -> getBlockingCallName (CCall (CVar funId _) args _) = do -> res <- lookupBlocking $ identToString funId +> getBlockingCallName (CCall e args _) = do +> res <- lookupBlocking e > case res of { (Just (bname, _, _)) -> return $ Just bname ; Nothing -> return Nothing } > getBlockingCallName _ = return Nothing @@ -343,8 +343,8 @@ > everything orElseMMaybe (mkQ (return Nothing) getBlockingCallName) $ stmt > getBlockingCallExpr :: CExpr -> WalkerT (Maybe CExpr) -> getBlockingCallExpr call@(CCall (CVar funId _) _ _) = do -> res <- lookupBlocking $ identToString funId +> getBlockingCallExpr call@(CCall e _ _) = do +> res <- lookupBlocking e > if isJust res then return $ Just call else return Nothing > getBlockingCallExpr _ = return Nothing @@ -352,23 +352,20 @@ > findBlockingCallExpr stmt = > everything orElseMMaybe (mkQ (return Nothing) getBlockingCallExpr) $ stmt -> isExprBlockingFunPtr :: CExpr -> WalkerT Bool -> isExprBlockingFunPtr (CCall (CVar funId _) _ _) = isBlockingFunPtr $ identToString funId - Split a statement with a blocking function call into a triple of (return expression, function name, parameter expressions). This function replaces the blocking call with a variable "ret", and returns that as the return expression. > replaceCallWithVar :: String -> CExpr -> WalkerT CExpr -> replaceCallWithVar varname call@(CCall (CVar funId ni) _ _) = do -> res <- lookupBlocking $ identToString funId +> replaceCallWithVar varname call@(CCall e _ ni) = do +> res <- lookupBlocking e > if isJust res then return (mkVar varname ni) else return call > replaceCallWithVar _ c = return c > findAndReplaceBlockingCall :: String -> CStat -> WalkerT CStat > -- if the statement is just the blocking call (the return value is ignored), we don't replace -> findAndReplaceBlockingCall s (CExpr (Just call@(CCall (CVar funId ni) _ _)) _) = do -> res <- lookupBlocking $ identToString funId +> findAndReplaceBlockingCall s (CExpr (Just call@(CCall e _ _)) ni) = do +> res <- lookupBlocking e > if isJust res then return (mkCompoundStmt (Just "__gs_result_expr") [] ni) else do > expr <- replaceCallWithVar s call > return (CExpr (Just expr) ni) @@ -475,9 +472,8 @@ > (bparams ++ pparams ++ > [fieldsDecl, paramsDecl] ++ pwaitDecls) ni -> mkPostFunName :: Bool -> String -> String -> String -> mkPostFunName True ctlName name = ctlName ++ "->" ++ name -> mkPostFunName False _ name = name ++ "_post" +> mkPostFunName :: String -> String -> String +> mkPostFunName ctlName name = name ++ "_post" Each callback function defined for a given blocking function must have a unique name. We use: @@ -665,21 +661,18 @@ > -- pull out just the blocking call from a complex expression > (Just blockingCall) <- findBlockingCallExpr $ stmt -> -- check if the blocking call is a function pointer -> fptr <- isExprBlockingFunPtr blockingCall - > -- generate the function name for the callback to past to the post call > let callbackFunName = (mkCallbackFunName (getParentName b) > (getCallName blockingCall) > (getCallNodeInfo blockingCall)) > -- get the return type of the blocking call -> (Just (_, parentRetType, _)) <- lookupBlocking (getParentName b) +> let parentRetType = getFunDefReturn $ funDef (getParent b) > -- get the current params prefix > pname <- getPrefix > errorWriter <- getErrorWriter -> return (mkPostCall b callbackFunName fptr pname blockingCall (\s -> errorWriter parentRetType s (getNI b))) +> return (mkPostCall b callbackFunName pname blockingCall (\s -> errorWriter parentRetType s (getNI b))) > generatePostStmts (Just (FunContext _ (first:stmts) _ _ _)) tracer = error "generatePostStmts(FunContext): Invalid" @@ -1048,11 +1041,11 @@ > | isLastContext b && parentIsPBranch b = findTransition $ getPWaitAncestor b > | otherwise = next b -> mkPostCall :: BlockingContext -> String -> Bool -> String -> CExpr -> (String -> CStat) -> [CStat] -> mkPostCall b fname fptr ctlName bcall errorHandler = +> mkPostCall :: BlockingContext -> String -> String -> CExpr -> (String -> CStat) -> [CStat] +> mkPostCall b fname ctlName bcall errorHandler = > let ni = nodeInfo bcall > in [mkFunCall (mkVar "__gs_postret" ni) -> (mkPostFunName fptr ctlName $ getCallName bcall) +> (mkPostFunName ctlName $ getCallName bcall) > ((map (fromJust . (trExpr ctlName b) . Just) $ getCallParams bcall) > ++ [mkVar fname ni, mkVar ctlName ni, > addStructPtr ctlName $ mkVar "hints" ni, @@ -1102,7 +1095,7 @@ > ni = getNI bctx > in mkFunDef (CTypeDef (newIdent "gs_ret_t" ni) ni) -- return type > (getStorageSpecs funDef) -- get the storage specifiers for the function -> (mkPostFunName False "params" $ getFunDefName funDef) -- function name +> (mkPostFunName "params" $ getFunDefName funDef) -- function name > (params ++ (mkBlockingParamsForPost funDef)) > (mkPostStmts prefix bctx funDef postStmts) -- statements @@ -1192,7 +1185,7 @@ > blockingCallReturnStmt <- findAndReplaceBlockingCall callbackRetParam $ stmt b > -- lookup the declaration of the blocking function call to get the return type and parameter types -> blockingFun <- lookupBlocking $ getCallName $ fromJust blockingCall +> blockingFun <- lookupBlocking $ fromJust blockingCall > assert (isJust blockingFun) return () > let (Just ((,,) bname retType params)) = blockingFun @@ -1225,7 +1218,7 @@ > -- verify that the blocking call exists > assert (isJust blockingCall) return () > -> blockingFun <- lookupBlocking $ getCallName $ fromJust blockingCall +> blockingFun <- lookupBlocking $ fromJust blockingCall > assert (isJust blockingFun) return () > > let (Just ((,,) bname retType params)) = blockingFun @@ -1262,8 +1255,8 @@ > generateCallbacks transFun b@(PBranchContext _ pwaitDef stmts before after _ _ _) = > liftM concat $ mapM (generateCallbacks transFun) stmts -> transformBlockingDef :: CExtDecl -> WalkerT [CExtDecl] -> transformBlockingDef (CFDefExt funDef) +> transformBlocking :: CExtDecl -> WalkerT [CExtDecl] +> transformBlocking (CFDefExt funDef) > -- A blocking function definition, so we transform it > | isBlockingFunDef funDef = do @@ -1306,39 +1299,37 @@ > [mkPostFunction prefix ctx funDef postStmts] > -- Clear the blocking function parameters registry -> clearFunPtrRegistry > return transformedDecls -> -- Not a blocking function, leave it as-is -> transformBlockingDef c = return [c] +> -- Not a blocking function, but may be a struct declaration with a blocking fun pointer +> -- or a global blocking fun pointer +> transformBlocking c = return [c] -> transformBlockingDefs :: CTranslUnit -> WalkerT CTranslUnit -> transformBlockingDefs (CTranslUnit decls ni) = do +> transform :: CTranslUnit -> WalkerT CTranslUnit +> transform (CTranslUnit decls ni) = do > -- map transformBlockingDef decls returns: [WalkerT [CExtDecl]] > -- sequence of that returns: WalkerT [[CExtDecl]] > -- so we lift concat into a monad so that we end up with WalkerT [CExtDecl] -> newdecls <- liftM concat $ sequence $ map transformBlockingDef decls +> newdecls <- liftM concat $ sequence $ map transformBlocking decls > return $ CTranslUnit newdecls ni > derivedToString :: CDerivedDeclr -> String > derivedToString (CPtrDeclr _ _) = " * " > derivedToString (CFunDeclr (Right (params, _)) _ _) = foldl1 (++) $ map (show . pretty) params -> printBlocking :: (String, (String, (CTypeSpec, [CDerivedDeclr]), [CDecl])) -> WalkerT () -> printBlocking (bname, (_, (rettype, derives), params)) = do -> liftIO $ print $ "REGISTERED BLOCKING: " ++ bname -> liftIO $ print " RETURN: " -> liftIO $ print $ pretty rettype -> liftIO $ mapM_ (print . derivedToString) derives -> liftIO $ print " PARAMS: " -> liftIO $ mapM_ (print . pretty) params +> printBlocking :: Int -> FPType -> WalkerT () +> printBlocking l (FPFun n f) = do +> let (bname, (rettype, derives), params) = f +> liftIO $ print $ (take l $ repeat ' ') ++ bname ++ "( " ++ (foldl1 (++) $ map (show . pretty) params) ++ " ) = " ++ (show . pretty $ rettype) +> printBlocking l (FPStruct n f i) = do +> liftIO $ print $ (take l $ repeat ' ') ++ "( " ++ n ++ " )->" ++ f +> printBlocking (l + 4) i > printRegisteredBlockingCalls :: WalkerT () > printRegisteredBlockingCalls = do -> reg <- getRegistry -> blockingOps <- liftIO $ toList reg -> liftIO $ print "BLOCKING OPS:" -> mapM_ printBlocking blockingOps +> blocking <- getAllBlocking +> liftIO $ print "BLOCKING FUNCTIONS:" +> mapM_ (printBlocking 0) blocking > generateAST :: FilePath -> IO CTranslUnit > generateAST input_file = do @@ -1361,7 +1352,7 @@ > w <- newWalkerState r mkErrorPostHandler mkPBranchPostDoneStmts transformFuncReturnStmts > ctu <- generateAST f > (ctuWithPostDecls, w) <- runStateT (registerBlockingFunDecls ctu) w -> (transCTU, w) <- runStateT (transformBlockingDefs ctuWithPostDecls) w +> (transCTU, w) <- runStateT (transform ctuWithPostDecls) w > if p then ((writeFile outfile) . show . pretty) transCTU > else ((writeFile outfile) . show . serialize) transCTU > return () @@ -1415,8 +1406,8 @@ > report = getReportFilename opts > outfile = getOutfile opts > header = "Usage: gs-parser [OPTIONS...] files..." -> when (not $ null errs) $ ioError $ userError (concat errs ++ -> usageInfo header parserOpts) +> when (not $ null errs) $ ioError $ userError ((concat errs) ++ +> (usageInfo header parserOpts)) > when (isNothing outfile) $ ioError $ userError "No output file specified." > when help $ do { putStrLn $ usageInfo header parserOpts ; exitWith (ExitFailure 1) } > mapM_ (parseFile pretty includes (fromJust outfile) report) files Deleted: trunk/code/src/gsl/parser/gscc =================================================================== --- trunk/code/src/gsl/parser/gscc 2009-06-24 18:18:54 UTC (rev 601) +++ trunk/code/src/gsl/parser/gscc 2009-06-26 22:05:32 UTC (rev 602) @@ -1,135 +0,0 @@ -#!/bin/sh - -basepath=$(echo $0 | sed -e "s|gscc$||") -GSINST=${basepath} -GSINC=${GSINST}include/ -GSBIN=${GSINST}/gs-parser - -genheader="" - -usage() -{ - echo "usage: gscc [OPTIONS] [COMPILER OPTIONS] <gs-file>" - echo "" - echo "OPTIONS:" - echo "" - echo " --help,--usage This message" - echo " --outfile <FILE> Output file to write" - echo " --genheader Generates a C header file from a gs" - echo " header file .gsh" - echo " --dontclean Do not remove temporary parsed files" - echo " --compiler <PATH> Path to the C preprocessor/compiler to use" - echo " --pretty Output translated .c source in pretty form" - echo " without source line macros" - echo "" - exit 1 -} - -while test -n "$1"; do - - case $1 in - --help|--usage) - usage - exit 0 - ;; - --outfile) - shift - outfile=$1 - shift - ;; - --genheader) - genheader=1 - shift - ;; - --dontclean) - shift - dontclean=1 - ;; - --compiler) - shift - compiler=$1 - shift - ;; - --pretty) - shift - pretty="-p" - ;; - *) - r=$1 - remaining_opts="$remaining_opts $r" - shift - ;; - esac -done - -tmp=$(mktemp) -tmpgsi=${tmp}.gsi -tmpi=${tmp}.i - -if test -n "$genheader"; then - gsfile=$(echo $remaining_opts | sed -e "s|.* $.*\.gsh$.*|\1|") -else - gsfile=$(echo $remaining_opts | sed -e "s|.* $.*\.gs$.*|\1|") -fi -tmpgsi=${outfile}.gsi -tmpi=${outfile}.i - -if test -z "$compiler"; then - compiler=gcc -fi - -$compiler -I${GSINC} -x c -E -o $tmpgsi $remaining_opts -res=$? -if test $res != 0; then - echo "gscc: preprocessing step failed!" 1>&2 - exit $res -fi - -${GSBIN} -o $tmpi $pretty $tmpgsi -res=$? -if test $res != 0; then - echo "gscc: parsing step failed!" 1>&2 - exit $res -fi - -if test -n "$genheader"; then - - gsh="" - for o in $remaining_opts; do - echo $o | grep -i "gsh$" >/dev/null - if test $? = 0; then - gsh=$o - break - fi - done - if test -z "$gsh"; then - echo "ERROR: The -g option can only be used for files with a gsh suffix" - exit 1 - fi - - hname=$(echo $gsh | sed -e "s|\.gsh|\.h|") - if test -n "$outfile"; then - hname=$outfile - fi - ${GSINST}/gs-gen-header.sh $tmpi $gsh > $hname -else - - # remove .gs file from $options - opts=$(echo $remaining_opts | sed -e "s|[^ ]*\.gs||") - - if test -z "$outfile"; then - # get outfile if not specified - outfile=$(echo $gsfile | sed -e "s|gs$|o|") - fi - $compiler -I${GSINC} -x c -c -o $outfile $opts $tmpi - res=$? - if test $res != 0; then - echo "compiling step failed!" 1>&2 - #rm $gsfile.gsi $gsfile.i - exit $res - fi -fi - -if test -z "$dontclean"; then - rm $tmpgsi $tmpi -fi Modified: trunk/code/src/gsl/resources/mpi/test/pthread-compare.gs =================================================================== --- trunk/code/src/gsl/resources/mpi/test/pthread-compare.gs 2009-06-24 18:18:54 UTC (rev 601) +++ trunk/code/src/gsl/resources/mpi/test/pthread-compare.gs 2009-06-26 22:05:32 UTC (rev 602) @@ -67,6 +67,7 @@ tpr = (struct t *)cb; MPI_Send(buff, 1024, MPI_CHAR, (tpr->r+tpr->i)%tpr->np, tpr->r, MPI_COMM_WORLD); + return NULL; } static void *recv_thread(void *cb) @@ -77,6 +78,7 @@ MPI_Status status; MPI_Recv(buff, 1024, MPI_CHAR, (tpr->np+tpr->r-tpr->i)%tpr->np, (tpr->np+tpr->r-tpr->i)%tpr->np, MPI_COMM_WORLD, &status); + return NULL; } static void thread_send_recv(int numprocs, int rank)

1 0

[Gs-commits] r601 - trunk/wiki
by wozniak＠mcs.anl.gov 24 Jun '09

24 Jun '09

Author: wozniak Date: 2009-06-24 13:18:54 -0500 (Wed, 24 Jun 2009) New Revision: 601 Modified: trunk/wiki/Prototype-2009-1.odg trunk/wiki/Prototype-2009-1.png Log: Resized to save space. Modified: trunk/wiki/Prototype-2009-1.odg =================================================================== (Binary files differ) Modified: trunk/wiki/Prototype-2009-1.png =================================================================== (Binary files differ)

1 0

[Gs-commits] r600 - trunk/wiki
by wozniak＠mcs.anl.gov 24 Jun '09

24 Jun '09

Author: wozniak Date: 2009-06-24 13:12:11 -0500 (Wed, 24 Jun 2009) New Revision: 600 Modified: trunk/wiki/Prototype-2009-1.odg trunk/wiki/Prototype-2009-1.png Log: Reorg to show unified metadata&data cluster. Also faded out MPI-2 management hub nodes. Modified: trunk/wiki/Prototype-2009-1.odg =================================================================== (Binary files differ) Modified: trunk/wiki/Prototype-2009-1.png =================================================================== (Binary files differ)

1 0

[Gs-commits] r599 - trunk/wiki
by wozniak＠mcs.anl.gov 24 Jun '09

24 Jun '09

Author: wozniak Date: 2009-06-24 13:00:10 -0500 (Wed, 24 Jun 2009) New Revision: 599 Added: trunk/wiki/Prototype-2009-1.odg trunk/wiki/Prototype-2009-1.png Log: Hopefully helpful prototype diagram. Added: trunk/wiki/Prototype-2009-1.odg =================================================================== (Binary files differ) Property changes on: trunk/wiki/Prototype-2009-1.odg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: trunk/wiki/Prototype-2009-1.png =================================================================== (Binary files differ) Property changes on: trunk/wiki/Prototype-2009-1.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

1 0

[Gs-commits] r598 - trunk/code/src/gsl/parser
by slang＠mcs.anl.gov 24 Jun '09

24 Jun '09

Author: slang Date: 2009-06-24 01:42:08 -0500 (Wed, 24 Jun 2009) New Revision: 598 Modified: trunk/code/src/gsl/parser/gs-parser.lhs Log: fix for pbreak7. Modified: trunk/code/src/gsl/parser/gs-parser.lhs =================================================================== --- trunk/code/src/gsl/parser/gs-parser.lhs 2009-06-24 00:03:12 UTC (rev 597) +++ trunk/code/src/gsl/parser/gs-parser.lhs 2009-06-24 06:42:08 UTC (rev 598) @@ -922,6 +922,37 @@ > tlAfter <- translateForCB b $ bcallReturn ++ (nbStmtsAfter b) > return $ swapBreak (mkCompoundStmt Nothing (breakStmts ++ [CReturn Nothing ni]) $ getNI b) tlAfter +> | (containsPBreak $ nbStmtsAfter b) && isLastContext b && parentIsPBranch b = do +> prefix <- getPrefix + +> let pwaitCtx = getPWaitAncestor b +> pbranchCtx = getPBranchAncestor b +> afterPWaitStmts <- generateAfterStmts pwaitCtx [] +> pbDone <- getPBDone + +> let fname = getParentName b +> ni = getNI b +> setDoneCtlStmt = [mkDoneCtlSetStmt prefix ni] +> (pbreakDecls, pbreakStmts) = mkPBreakStmts prefix fname ni +> (pbranchDecls, pbranchStart) = mkPBranchCallbackStartStmts prefix fname ni +> pbranchDelete = mkPBranchDeleteStmts ni +> pbranchDone = mkPBranchDoneStmts prefix fname ni +> pbCheckDone = pbDone pbranchCtx ni +> doneStmts = mkDoneStmts ni + +> tlAfter <- translateForCB b $ bcallReturn ++ (nbStmtsAfter b) +> let afterStmts = swapPBreak (mkCompoundWithDecls Nothing +> pbreakDecls +> (pbranchStart ++ pbreakStmts ++ pbranchDone ++ pbCheckDone ++ +> setDoneCtlStmt ++ afterPWaitStmts ++ doneStmts) +> $ getNI b) tlAfter + +> return $ [mkCompoundWithDecls Nothing pbranchDecls +> (pbranchStart ++ afterStmts ++ setDoneCtlStmt ++ +> pbranchDelete ++ pbranchDone ++ pbCheckDone ++ afterPWaitStmts) $ getNI b] + + + > | containsPBreak $ nbStmtsAfter b = do > prefix <- getPrefix

1 0

[Gs-commits] r597 - trunk/code/src/gsl/common
by slang＠mcs.anl.gov 23 Jun '09

23 Jun '09

Author: slang Date: 2009-06-23 19:03:12 -0500 (Tue, 23 Jun 2009) New Revision: 597 Modified: trunk/code/src/gsl/common/gs.c Log: allow NULL context to be passed to gs_poll Modified: trunk/code/src/gsl/common/gs.c =================================================================== --- trunk/code/src/gsl/common/gs.c 2009-06-23 23:35:17 UTC (rev 596) +++ trunk/code/src/gsl/common/gs.c 2009-06-24 00:03:12 UTC (rev 597) @@ -48,9 +48,9 @@ if(idx != (gs_resource_count -1)) { - /* this is not the last resource in the table; shift everything down */ - memmove(&gs_resource_entries[idx], &gs_resource_entries[idx+1], - (sizeof(struct gs_resource_entry) * (gs_resource_count-idx-1))); + /* this is not the last resource in the table; shift everything down */ + memmove(&gs_resource_entries[idx], &gs_resource_entries[idx+1], + (sizeof(struct gs_resource_entry) * (gs_resource_count-idx-1))); } gs_resource_count--; } @@ -80,7 +80,7 @@ if(resource_id == 0) { - ctl = (struct gs_ctl *)(intptr_t)gs_id_lookup(op_id, NULL); + ctl = (struct gs_ctl *)(intptr_t)gs_id_lookup(op_id, NULL); gs_mutex_lock(&ctl->mutex); if(ctl->cancelled) { @@ -91,9 +91,9 @@ ctl->cancelled = 1; if(ctl->in_pwait) - { + { /* cancel children */ - struct gs_list_link *entry; + struct gs_list_link *entry; struct gs_ctl *child_ctl; if(gs_list_empty(&ctl->children)) { @@ -116,7 +116,7 @@ ret = gs_cancel_op(context, ctl->current_op_id); } gs_mutex_unlock(&ctl->mutex); - return ret; + return ret; } ret = gs_resource_entries[ridx].resource->cancel(context, op_id); @@ -145,18 +145,18 @@ ctl = (struct gs_ctl *)ptr; if(gs_list_empty(&ctl->children)) { - return -EINVAL; + return -EINVAL; } gs_list_for_each(entry, &ctl->children) { - child_ctl = gs_list_get_entry(entry, typeof(*child_ctl), link); - ret = gs_cancel_op(context, child_ctl->current_op_id); - if(ret != 0) - { - /* cancel failed */ - return ret; - } + child_ctl = gs_list_get_entry(entry, typeof(*child_ctl), link); + ret = gs_cancel_op(context, child_ctl->current_op_id); + if(ret != 0) + { + /* cancel failed */ + return ret; + } } return 0; @@ -196,23 +196,42 @@ int resource_ms, i, ret; int rid, ridx; int resources_polled = 0; - - resource_ms = millisecs / context->resource_count; - - for(i = 0; i < context->resource_count; ++i) + + if(context) { - rid = context->resource_ids[i]; - ridx = GS_RESOURCE_ID2IDX(rid); - if(gs_resource_entries[ridx].resource->poll_context) + resource_ms = millisecs / context->resource_count; + for(i = 0; i < context->resource_count; ++i) { - ret = gs_resource_entries[ridx].resource->poll_context(context, resource_ms); - if(ret != 0) + rid = context->resource_ids[i]; + ridx = GS_RESOURCE_ID2IDX(rid); + if(gs_resource_entries[ridx].resource->poll_context) { - return ret; + ret = gs_resource_entries[ridx].resource->poll_context(context, resource_ms); + if(ret != 0) + { + return ret; + } + resources_polled++; } - resources_polled++; } } + else + { + resource_ms = millisecs / gs_resource_count; + for(i = 0; i < gs_resource_count; ++i) + { + if(gs_resource_entries[i].resource->poll_context) + { + ret = gs_resource_entries[i].resource->poll_context( + context, resource_ms); + if(ret != 0) + { + return ret; + } + resources_polled++; + } + } + } if(resources_polled == 0) { @@ -264,7 +283,7 @@ rname = va_arg(ap, char *); /* find the matching resource and register the context with that resource */ - + for(j = 0; j < gs_resource_count; ++j) { if(!strcmp(gs_resource_entries[j].resource->resource_name, rname)) @@ -296,11 +315,11 @@ *context = c; return 0; } - + int gs_context_destroy(gs_context_t context) { int rid, idx, i; - + for(i = 0; i < context->resource_count; ++i) { rid = context->resource_ids[i]; @@ -317,7 +336,11 @@ return 0; } - - - - +/* + * Local variables: + * c-indent-level: 4 + * c-basic-offset: 4 + * End: + * + * vim: ts=8 sts=4 sw=4 expandtab + */

1 0

[Gs-commits] r596 - in trunk/code/src/gsl: . examples parser tests/correctness
by slang＠mcs.anl.gov 23 Jun '09

23 Jun '09

Author: slang Date: 2009-06-23 18:35:17 -0500 (Tue, 23 Jun 2009) New Revision: 596 Added: trunk/code/src/gsl/tests/correctness/icpfor.gs trunk/code/src/gsl/tests/correctness/tcpfor.gs Modified: trunk/code/src/gsl/Makefile.in trunk/code/src/gsl/examples/module.mk.in trunk/code/src/gsl/examples/rpc-invoke.gs trunk/code/src/gsl/parser/gs-parser.lhs trunk/code/src/gsl/tests/correctness/afterwhile.gs trunk/code/src/gsl/tests/correctness/basic.gs trunk/code/src/gsl/tests/correctness/btest-impl.c trunk/code/src/gsl/tests/correctness/btest.gsh trunk/code/src/gsl/tests/correctness/forloop.gs trunk/code/src/gsl/tests/correctness/if.gs trunk/code/src/gsl/tests/correctness/ifnbelse.gs trunk/code/src/gsl/tests/correctness/ifnoelse.gs trunk/code/src/gsl/tests/correctness/ifnoelse2.gs trunk/code/src/gsl/tests/correctness/mixed.gs trunk/code/src/gsl/tests/correctness/module.mk.in trunk/code/src/gsl/tests/correctness/multif.gs trunk/code/src/gsl/tests/correctness/nested.gs trunk/code/src/gsl/tests/correctness/parallel1.gs trunk/code/src/gsl/tests/correctness/parallel2.gs trunk/code/src/gsl/tests/correctness/parallel3.gs trunk/code/src/gsl/tests/correctness/parallel4.gs trunk/code/src/gsl/tests/correctness/parallelfor.gs trunk/code/src/gsl/tests/correctness/params.gs trunk/code/src/gsl/tests/correctness/pbreak.gs trunk/code/src/gsl/tests/correctness/pbreak2.gs trunk/code/src/gsl/tests/correctness/pbreak3.gs trunk/code/src/gsl/tests/correctness/pbreak4.gs trunk/code/src/gsl/tests/correctness/pbreak5.gs trunk/code/src/gsl/tests/correctness/pbreak6.gs trunk/code/src/gsl/tests/correctness/pbreak7.gs trunk/code/src/gsl/tests/correctness/threefors.gs trunk/code/src/gsl/tests/correctness/twofors.gs trunk/code/src/gsl/tests/correctness/whilebreak.gs trunk/code/src/gsl/tests/correctness/whilebreak2.gs trunk/code/src/gsl/tests/correctness/whilebreak3.gs trunk/code/src/gsl/tests/correctness/whileloop.gs Log: add interfaces to btest resource to test immediate completion and threaded completioned where the callback gets called before the post call returns. Also removed declarations of btest_poll and btest_cancel and updated all the tests as appropriate. Modified: trunk/code/src/gsl/Makefile.in =================================================================== --- trunk/code/src/gsl/Makefile.in 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/Makefile.in 2009-06-23 23:35:17 UTC (rev 596) @@ -59,17 +59,18 @@ STRICT_CFLAGS = @STRICT_CFLAGS@ CFLAGS= -I$(srcdir)/include -I. -I$(srcdir) @CFLAGS@ @CPPFLAGS@ +CWARNS= ifneq (,$(STRICT_CFLAGS)) - CFLAGS += -Wcast-align -Wbad-function-cast - CFLAGS += -Wmissing-prototypes -Wmissing-declarations - CFLAGS += -Wundef -Wpointer-arith - CFLAGS += -Wnested-externs - CFLAGS += -Wredundant-decls + CWARNS += -Wcast-align -Wbad-function-cast + CWARNS += -Wmissing-prototypes -Wmissing-declarations + CWARNS += -Wundef -Wpointer-arith + CWARNS += -Wnested-externs + CWARNS += -Wredundant-decls # Very noisy, too strict - CFLAGS += -W -Wno-unused -Wno-sign-compare - CFLAGS += -Wcast-qual - CFLAGS += -Wshadow - CFLAGS += -Wwrite-strings + CWARNS += -W -Wno-unused -Wno-sign-compare + CWARNS += -Wcast-qual + CWARNS += -Wshadow + CWARNS += -Wwrite-strings endif LDFLAGS += @LDFLAGS@ @@ -245,11 +246,11 @@ $(GSOBJS_DEPENDS): %.d: %.gs $(Q) " DEP $@" - $(E)$(CC) -x c -MT $(patsubst %.d,%.o,$@) -MM -MG -MF $@ $< $(LIBCFLAGS) $(CFLAGS) $(call MODCFLAGS_GS,$<) + $(E)$(CC) -x c -MT $(patsubst %.d,%.o,$@) -MM -MG -MF $@ $< $(LIBCFLAGS) $(CFLAGS) $(CWARNS) $(call MODCFLAGS_GS,$<) $(LIBOBJS_DEPENDS) $(TESTLIBOBJS_DEPENDS): %.d: %.c $(Q) " DEP $@" - $(E)$(CC) -MT $(patsubst %.d,%.o,$@) -MM -MG -MF $@ $< $(LIBCFLAGS) $(CFLAGS) $(call MODCFLAGS,$<) + $(E)$(CC) -MT $(patsubst %.d,%.o,$@) -MM -MG -MF $@ $< $(LIBCFLAGS) $(CFLAGS) $(CWARNS) $(call MODCFLAGS,$<) $(GSTEST): %: %.o lib/libgs.a lib/libgstest.a $(Q) " LD $@" @@ -261,7 +262,7 @@ $(GSOBJS): %.o: %.gs.s $(E)$(call MCC_GS,$<) -I$(srcdir)/include/ -x c -c -o $@ \ $(LIBCFLAGS) \ - $(CFLAGS) $(call MODCFLAGS_GS,$<) $< + $(CFLAGS) $(CWARNS) $(call MODCFLAGS_GS,$<) $< ifeq (,@GSL_DEBUG@) $(E)rm $*.gs.s endif @@ -283,30 +284,30 @@ %.gs.i: %.gs %.gs.dummyobj $(E)rm $*.gs.dummyobj $(E)$(call MCC_GS,$<) -I$(srcdir)/include/ -x c -E -o $*.gs.i \ - $(LIBCFLAGS) $(CFLAGS) $(call MODCFLAGS_GS,$<) $*.gs + $(LIBCFLAGS) $(CFLAGS) $(CWARNS) $(call MODCFLAGS_GS,$<) $*.gs $(GSTRHDR): %.h: %.gsh parser $(Q) " GSCC $<" $(E)$(GSCC) --compiler "$(call MCC_GS,$<)" \ --genheader --outfile $@ \ - $(LIBCFLAGS) $(CFLAGS) $(call modcflags,$<) $< + $(LIBCFLAGS) $(CFLAGS) $(CWARNS) $(call modcflags,$<) $< $(LIBOBJS): %.o: %.d $(Q) " CC $@" $(E)$(call MCC_C,$(patsubst %.d,%.c,$<)) -c -o $@ \ - $(LIBCFLAGS) $(CFLAGS) \ + $(LIBCFLAGS) $(CFLAGS) $(CWARNS) \ $(call MODCFLAGS_C,$(patsubst %.d,%.c,$<)) \ $(srcdir)/$(patsubst %.d,%.c,$<) $(LIBOSDOBJS): %.o: %.c $(Q) " CC $@" - $(E)$(call MCC_C,$<) -c -o $@ $(LIBCFLAGS) $(CFLAGS) \ + $(E)$(call MCC_C,$<) -c -o $@ $(LIBCFLAGS) $(CFLAGS) $(CWARNS) \ $(call modcflags,$<) $< $(TESTLIBOBJS): %.o: %.d $(Q) " CC $@" $(E)$(call MCC_C,$(patsubst %.d,%.c,$<)) -c -o $@ \ - $(LIBCFLAGS) $(CFLAGS) \ + $(LIBCFLAGS) $(CFLAGS) $(CWARNS) \ $(call MODCFLAGS_C,$(patsubst %.d,%.c,$<)) \ $(srcdir)/$(patsubst %.d,%.c,$<) Modified: trunk/code/src/gsl/examples/module.mk.in =================================================================== --- trunk/code/src/gsl/examples/module.mk.in 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/examples/module.mk.in 2009-06-23 23:35:17 UTC (rev 596) @@ -1,3 +1,5 @@ DIR := examples GSTESTSRC += $(DIR)/rpc-invoke.gs + +MODLIBS_$(DIR) = -lpthread Modified: trunk/code/src/gsl/examples/rpc-invoke.gs =================================================================== --- trunk/code/src/gsl/examples/rpc-invoke.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/examples/rpc-invoke.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -3,27 +3,13 @@ #include "tests/correctness/btest.gsh" #include "resources/timer/gs-timer.gsh" -__blocking static int rpc_invoke(); - -__blocking static void invoke_many(int count) -{ - pwait - { - int i; - for(i = 0; i < count; ++i) - { - pbranch { rpc_invoke(); } - } - } -} - __blocking static int rpc_invoke() { int a = 0; - int rand, val, ret; + int randval, val, ret; - rand = btest_random(); - val = rand % 3; + randval = btest_random(); + val = randval % 3; printf("RANDOM VALUE: %d\n", val); if(0 == val) { @@ -40,9 +26,21 @@ assert(ret == 0); assert((a-1) == val); - return rand; + return randval; } +__blocking static void invoke_many(int count) +{ + pwait + { + int i; + for(i = 0; i < count; ++i) + { + pbranch { rpc_invoke(); } + } + } +} + static int running = 1; __blocking static void many_looping() Modified: trunk/code/src/gsl/parser/gs-parser.lhs =================================================================== --- trunk/code/src/gsl/parser/gs-parser.lhs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/parser/gs-parser.lhs 2009-06-23 23:35:17 UTC (rev 596) @@ -29,11 +29,11 @@ > mkErrorCBPostHandler :: ReturnType -> String -> NodeInfo -> CStat > mkErrorCBPostHandler retType ctlName ni = constructStmtFromC ni $ -> "gs_assert(\"Fatal Error: post call failed!\", __gs_postret == GS_POSTED);" +> "gs_assert(\"Fatal Error: post call failed!\", __gs_postret == GS_POSTED || __gs_postret == GS_COMPLETE);" > mkErrorPostHandler :: ReturnType -> String -> NodeInfo -> CStat > mkErrorPostHandler retType ctlName ni = constructStmtFromC ni $ -> "gs_assert(\"Fatal Error: post call failed!\", __gs_postret == GS_POSTED);" +> "gs_assert(\"Fatal Error: post call failed!\", __gs_postret == GS_POSTED || __gs_postret == GS_COMPLETE);" > mkPBreakStmts :: String -> String -> NodeInfo -> ([CDecl], [CStat]) > mkPBreakStmts prefix funName ni = @@ -92,13 +92,15 @@ > \ "++prefix++"->in_pwait = 1; \ > \}" -> mkPWaitFinishStmts :: String -> NodeInfo -> [CStat] -> mkPWaitFinishStmts prefix ni = mkStmtsFromCLines ni $ -> "{ \ -> \ gs_mutex_lock(&"++prefix++"->mutex); \ -> \ "++prefix++"->allposted = 1; \ -> \ gs_mutex_unlock(&"++prefix++"->mutex); \ -> \}" +> 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);", +> mkIfElseStmt (Just (constructExprFromC ni "__gs_pwait_done")) +> afterPWaitStmts []] ni] > mkPostFunInitStmts :: String -> NodeInfo -> [CStat] > mkPostFunInitStmts name ni = mkStmtsFromCLines ni $ @@ -846,7 +848,8 @@ > firstStmts <- translateForCB w (pwaitDeclInits ++ nbStmts) > pStmts <- liftM concat $ mapM (\b -> (getParallelStmts b tr)) waitStmts > p <- getPrefix -> return $ (mkPWaitInitStmts p $ getNI pw) ++ firstStmts ++ pStmts ++ (mkPWaitFinishStmts p $ getNI pw) +> afterPWaitStmts <- generateAfterStmts pw tr +> return $ (mkPWaitInitStmts 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 Modified: trunk/code/src/gsl/tests/correctness/afterwhile.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/afterwhile.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/afterwhile.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -45,7 +45,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } assert(here == 1); Modified: trunk/code/src/gsl/tests/correctness/basic.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/basic.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/basic.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -40,7 +40,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/btest-impl.c =================================================================== --- trunk/code/src/gsl/tests/correctness/btest-impl.c 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/btest-impl.c 2009-06-23 23:35:17 UTC (rev 596) @@ -8,6 +8,7 @@ #include "include/gs-oplist.h" #include "include/gs-opcache.h" #include "tests/correctness/btest.h" +#include "pthread.h" static int btest_resource_id; @@ -36,6 +37,52 @@ static gs_opcache_t test_opcache; static gs_opcache_t sleep_opcache; +gs_ret_t ictest1_post(int *a, + void (*callback)(void *ptr, int ret), + void *up, + gs_hints_t hints, + gs_context_t ctx, + gs_op_id_t *op_id) +{ + ++(*a); + callback(up, 0); + return GS_COMPLETE; +} + +static void *tctest1_threadfun(void *ptr) +{ + struct gs_op *op; + struct btest_op *bop; + op = (struct gs_op *)ptr; + bop = gs_op_entry(op, struct btest_op, op); + *(bop->value) += 1; + gs_invoke_callback(&bop->op, 0); + gs_opcache_put(test_opcache, &bop->op); + return NULL; +} + +gs_ret_t tctest1_post(int *a, + void (*callback)(void *ptr, int ret), + void *up, + gs_hints_t hints, + gs_context_t ctx, + gs_op_id_t *op_id) +{ + pthread_t tid; + struct gs_op *op; + struct btest_op *bop; + op = gs_opcache_get(test_opcache); + gs_op_fill(op, callback, up, hints, ctx); + bop = gs_op_entry(op, struct btest_op, op); + bop->value = a; + bop->id = gs_id_gen(btest_resource_id, (uint64_t)(op->cache_id)); + *op_id = bop->id; + pthread_create(&tid, NULL, tctest1_threadfun, op); + usleep(1000); + + return GS_POSTED; +} + gs_ret_t btest1_post(int *a, void (*callback)(void *ptr, int ret), void *up, @@ -182,7 +229,7 @@ return NULL; } -int btest_poll(gs_context_t context, int ms) +static int btest_poll(gs_context_t context, int ms) { struct btest_op *b; struct bsleep_op *s; @@ -235,7 +282,7 @@ return 0; } -int btest_cancel(gs_context_t ctx, gs_op_id_t op_id) +static int btest_cancel(gs_context_t ctx, gs_op_id_t op_id) { struct gs_op *t, *tmp; struct btest_op *b; Modified: trunk/code/src/gsl/tests/correctness/btest.gsh =================================================================== --- trunk/code/src/gsl/tests/correctness/btest.gsh 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/btest.gsh 2009-06-23 23:35:17 UTC (rev 596) @@ -6,16 +6,50 @@ #include "include/gs.h" #include "include/gs-op.h" +/* These interfaces are used to test the gsl code for correctness. They + * emulate a basic resource with blocking functions, using different completion + * techniques (queue/polling, threads, immediate completion). + */ + +/* These three functions increment the integer pointer by 1, 2, and 3 respectively, + * by first storing the operation on a queue and completing the operation through + * a poll call. + */ + __blocking int btest1(int *a); __blocking int btest2(int *b); __blocking int btest3(int *c); + +/* This function sleeps for the specified seconds. This is implemented by putting + * the operation on queue, and performing the sleep() call at polling time. + */ __blocking int btest_sleep(int secs); + +/* This function is a blocking function that never returns, but can be cancelled. + * The operation is placed on a queue, and if a call to gs_cancel occurs the operation + * is completed, otherwise the operation remains on the queue indefinitely. + */ __blocking int btest_forever(); + +/* This function simply returns a random value. The operation is first placed + * on a queue, and during polling the random value is calculated and the operation + * completed. + */ __blocking int btest_random(); -int btest_poll(gs_context_t ctx, int ms); -int btest_cancel(gs_context_t ctx, gs_op_id_t op_id); +/* This function tests immediate completion. It increments the parameter passed in + * directly in the post function and calls the callback from the post function, returning + * the GS_COMPLETE value instead of GS_POSTED. + */ +__blocking int ictest1(int *a); +/* This function tests completion in a separate thread, where the completion callback may + * be called before the post call actually completes. The post call starts a thread that + * increments the value and calls the callback. After the post call starts the thread it + * sleeps for 1000 microseconds before returning GS_POSTED. + */ +__blocking int tctest1(int *a); + int btest_init(void); int btest_finalize(void); Modified: trunk/code/src/gsl/tests/correctness/forloop.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/forloop.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/forloop.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -45,7 +45,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); free(myptr); Added: trunk/code/src/gsl/tests/correctness/icpfor.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/icpfor.gs (rev 0) +++ trunk/code/src/gsl/tests/correctness/icpfor.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -0,0 +1,56 @@ +#include "include/gs.h" +#include "tests/correctness/btest.gsh" + +static __blocking void run_parfor(void) +{ + int a[100]; + int ret[100]; + + memset(a, 0, sizeof(int)*100); + memset(ret, 0, sizeof(int)*100); + + pwait + { + int i, j; + for(i = 0; i < 100; ++i) + { + pbranch + { + j = i; + a[i] = i; + ret[i] = ictest1(&a[i]); + assert(ret[i] == 0); + assert(a[i] == (i+1)); + } + } + } + + printf("pwait done\n"); +} + +static int done = 0; +static void basic_cb(void *ptr) +{ + printf("%p\n", ptr); + printf("done\n"); + done = 1; +} + +int main(int argc, char *argv[]) +{ + gs_op_id_t op_id; + void *myptr = malloc(1); + + btest_init(); + printf("%p\n", myptr); + run_parfor_post(basic_cb, myptr, NULL, NULL, &op_id); + + while(done == 0) + { + gs_poll(NULL, 0); + } + + btest_finalize(); + free(myptr); + return 0; +} Modified: trunk/code/src/gsl/tests/correctness/if.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/if.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/if.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -57,7 +57,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/ifnbelse.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/ifnbelse.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/ifnbelse.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -47,7 +47,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/ifnoelse.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/ifnoelse.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/ifnoelse.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -43,7 +43,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/ifnoelse2.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/ifnoelse2.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/ifnoelse2.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -45,7 +45,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/mixed.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/mixed.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/mixed.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -93,7 +93,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); free(myptr); Modified: trunk/code/src/gsl/tests/correctness/module.mk.in =================================================================== --- trunk/code/src/gsl/tests/correctness/module.mk.in 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/module.mk.in 2009-06-23 23:35:17 UTC (rev 596) @@ -1,6 +1,8 @@ DIR := tests/correctness -GSTESTSRC += $(DIR)/afterwhile.gs \ +GSTESTSRC += $(DIR)/icpfor.gs \ + $(DIR)/tcpfor.gs \ + $(DIR)/afterwhile.gs \ $(DIR)/basic.gs \ $(DIR)/params.gs \ $(DIR)/forloop.gs \ @@ -34,6 +36,8 @@ TESTLIBSRC += $(DIR)/btest-impl.c +MODLIBS_$(DIR) = -lpthread + TESTPARAMS_$(DIR)/if = 0 1 2 3 4 TESTPARAMS_$(DIR)/ifnoelse = 0 1 TESTPARAMS_$(DIR)/ifnoelse2 = 0 1 Modified: trunk/code/src/gsl/tests/correctness/multif.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/multif.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/multif.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -84,7 +84,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/nested.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/nested.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/nested.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -40,7 +40,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } assert(here == 1); Modified: trunk/code/src/gsl/tests/correctness/parallel1.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/parallel1.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/parallel1.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -56,7 +56,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/parallel2.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/parallel2.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/parallel2.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -65,7 +65,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/parallel3.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/parallel3.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/parallel3.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -83,7 +83,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/parallel4.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/parallel4.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/parallel4.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -81,7 +81,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/parallelfor.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/parallelfor.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/parallelfor.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -56,7 +56,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/params.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/params.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/params.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -37,7 +37,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/pbreak.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/pbreak.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/pbreak.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -65,7 +65,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/pbreak2.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/pbreak2.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/pbreak2.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -59,7 +59,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/pbreak3.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/pbreak3.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/pbreak3.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -68,7 +68,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/pbreak4.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/pbreak4.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/pbreak4.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -77,7 +77,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/pbreak5.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/pbreak5.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/pbreak5.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -73,7 +73,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/pbreak6.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/pbreak6.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/pbreak6.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -67,7 +67,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/pbreak7.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/pbreak7.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/pbreak7.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -83,7 +83,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Added: trunk/code/src/gsl/tests/correctness/tcpfor.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/tcpfor.gs (rev 0) +++ trunk/code/src/gsl/tests/correctness/tcpfor.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -0,0 +1,56 @@ +#include "include/gs.h" +#include "tests/correctness/btest.gsh" + +static __blocking void run_parfor(void) +{ + int a[100]; + int ret[100]; + + memset(a, 0, sizeof(int)*100); + memset(ret, 0, sizeof(int)*100); + + pwait + { + int i, j; + for(i = 0; i < 100; ++i) + { + pbranch + { + j = i; + a[i] = i; + ret[i] = tctest1(&a[i]); + assert(ret[i] == 0); + assert(a[i] == (i+1)); + } + } + } + + printf("pwait done\n"); +} + +static int done = 0; +static void basic_cb(void *ptr) +{ + printf("%p\n", ptr); + printf("done\n"); + done = 1; +} + +int main(int argc, char *argv[]) +{ + gs_op_id_t op_id; + void *myptr = malloc(1); + + btest_init(); + printf("%p\n", myptr); + run_parfor_post(basic_cb, myptr, NULL, NULL, &op_id); + + while(done == 0) + { + gs_poll(NULL, 0); + } + + btest_finalize(); + free(myptr); + return 0; +} Modified: trunk/code/src/gsl/tests/correctness/threefors.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/threefors.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/threefors.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -106,7 +106,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/twofors.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/twofors.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/twofors.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -91,7 +91,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); free(myptr); Modified: trunk/code/src/gsl/tests/correctness/whilebreak.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/whilebreak.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/whilebreak.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -43,7 +43,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/whilebreak2.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/whilebreak2.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/whilebreak2.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -41,7 +41,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/whilebreak3.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/whilebreak3.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/whilebreak3.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -48,7 +48,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize(); Modified: trunk/code/src/gsl/tests/correctness/whileloop.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/whileloop.gs 2009-06-23 19:34:49 UTC (rev 595) +++ trunk/code/src/gsl/tests/correctness/whileloop.gs 2009-06-23 23:35:17 UTC (rev 596) @@ -44,7 +44,7 @@ while(done == 0) { - btest_poll(NULL, 0); + gs_poll(NULL, 0); } btest_finalize();

1 0

[Gs-commits] r595 - in trunk/code/src/gsl: . parser tests/correctness
by slang＠mcs.anl.gov 23 Jun '09

23 Jun '09

Author: slang Date: 2009-06-23 14:34:49 -0500 (Tue, 23 Jun 2009) New Revision: 595 Added: trunk/code/src/gsl/tests/correctness/afterwhile.gs Modified: trunk/code/src/gsl/Makefile.in trunk/code/src/gsl/parser/gs-parser.lhs trunk/code/src/gsl/parser/gscc trunk/code/src/gsl/tests/correctness/nested.gs Log: Changed parser to require output file, and report an error if a blocking function with a return type doesn't end in a return statement. add afterwhile test. Modified: trunk/code/src/gsl/Makefile.in =================================================================== --- trunk/code/src/gsl/Makefile.in 2009-06-23 18:37:58 UTC (rev 594) +++ trunk/code/src/gsl/Makefile.in 2009-06-23 19:34:49 UTC (rev 595) @@ -267,7 +267,7 @@ endif %.gs.s: %.gs.i parser - $(E)$(builddir)/parser/gs-parser $(GSPRETTY) $*.gs.i > $@ + $(E)$(builddir)/parser/gs-parser -o $@ -r $*.gs $(GSPRETTY) $*.gs.i $(E)rm $*.gs.i .PRECIOUS: %.gs.dummyobj %.gs.i Modified: trunk/code/src/gsl/parser/gs-parser.lhs =================================================================== --- trunk/code/src/gsl/parser/gs-parser.lhs 2009-06-23 18:37:58 UTC (rev 594) +++ trunk/code/src/gsl/parser/gs-parser.lhs 2009-06-23 19:34:49 UTC (rev 595) @@ -175,11 +175,14 @@ > in mkBlockingParams (\s -> mkRetDecl (tSpec, derivedPtrs) s $ nodeInfo c) > (getCFunDeclrParams funDeclr) (nodeInfo c) -> addReturnToVoid :: CFunDef -> CFunDef -> addReturnToVoid f@(CFunDef specs declarator decls (CCompound idents stmts cni) ni) +> checkForReturn :: CFunDef -> WalkerT CFunDef +> checkForReturn f@(CFunDef specs declarator decls (CCompound idents stmts cni) ni) > | (isVoidType $ getFunDefReturn f) && (not $ isReturnStmt $ fromJust $ getBlockStmt $ last stmts) = -> (CFunDef specs declarator decls (CCompound idents (stmts ++ [CBlockStmt (CReturn Nothing ni)]) cni) ni) -> | otherwise = f +> return $ (CFunDef specs declarator decls (CCompound idents (stmts ++ [CBlockStmt (CReturn Nothing ni)]) cni) ni) +> | (not $ isVoidType $ getFunDefReturn f) && (not $ isReturnStmt $ fromJust $ getBlockStmt $ last stmts) = do +> invalid ("The blocking function: " ++ (getFunDefName f) ++ " does not have a final return statement\n") ni +> return f +> | otherwise = return f > getLocals :: BlockingContext -> [CDecl] > getLocals (FunContext funDef _ _ _ _) = getFuncLocalDecls funDef @@ -1240,7 +1243,7 @@ > -- before generating the context, we add a return; statement at the end if its > -- a void function and doesn't have a return -> let fDefWReturn = addReturnToVoid funDef +> fDefWReturn <- checkForReturn funDef > -- Generate the blocking tree of BlockingContext nodes > ctx <- generateContext fDefWReturn @@ -1318,23 +1321,34 @@ > Left p -> error (show p) > Right ast -> return ast -> parseFile :: Bool -> [String] -> FilePath -> IO () -> parseFile p includes f = do -> w <- newWalkerState f mkErrorPostHandler mkPBranchPostDoneStmts transformFuncReturnStmts +> parseFile :: Bool -> [String] -> FilePath -> Maybe FilePath -> FilePath -> IO () +> parseFile p includes outfile report f = do +> let r = if isJust report then fromJust report else f +> w <- newWalkerState r mkErrorPostHandler mkPBranchPostDoneStmts transformFuncReturnStmts > ctu <- generateAST f > (ctuWithPostDecls, w) <- runStateT (registerBlockingFunDecls ctu) w > (transCTU, w) <- runStateT (transformBlockingDefs ctuWithPostDecls) w -> if p then (print . pretty) transCTU -> else (print . serialize) transCTU +> if p then ((writeFile outfile) . show . pretty) transCTU +> else ((writeFile outfile) . show . serialize) transCTU > return () -> data ParserOpts = Pretty | Help | Include String +> data ParserOpts = Pretty | Help | Include String | Report String | Outfile String > 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) @@ -1343,6 +1357,10 @@ > "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" > ] > optPretty :: ParserOpts -> Bool @@ -1360,8 +1378,11 @@ > pretty = any optPretty opts > help = any optHelp opts > includes = getIncludes opts +> report = getReportFilename opts +> outfile = getOutfile opts > header = "Usage: gs-parser [OPTIONS...] files..." > when (not $ null errs) $ ioError $ userError (concat errs ++ > usageInfo header parserOpts) +> when (isNothing outfile) $ ioError $ userError "No output file specified." > when help $ do { putStrLn $ usageInfo header parserOpts ; exitWith (ExitFailure 1) } -> mapM_ (parseFile pretty includes) files +> mapM_ (parseFile pretty includes (fromJust outfile) report) files Modified: trunk/code/src/gsl/parser/gscc =================================================================== --- trunk/code/src/gsl/parser/gscc 2009-06-23 18:37:58 UTC (rev 594) +++ trunk/code/src/gsl/parser/gscc 2009-06-23 19:34:49 UTC (rev 595) @@ -85,7 +85,7 @@ exit $res fi -${GSBIN} $pretty $tmpgsi > $tmpi +${GSBIN} -o $tmpi $pretty $tmpgsi res=$? if test $res != 0; then echo "gscc: parsing step failed!" 1>&2 Added: trunk/code/src/gsl/tests/correctness/afterwhile.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/afterwhile.gs (rev 0) +++ trunk/code/src/gsl/tests/correctness/afterwhile.gs 2009-06-23 19:34:49 UTC (rev 595) @@ -0,0 +1,55 @@ +#include "include/gs.h" +#include "tests/correctness/btest.gsh" + +static int here = 0; + +static __blocking int run_afterwhile(void) +{ + int i, ret; + int a = 0; + + i = 100; + while(i > 0) + { + ret = btest1(&a); + assert(ret == 0); + assert(a == ((100-i)+1)); + --i; + } + return 0; +} + +static __blocking void run_outer(void) +{ + run_afterwhile(); + here = 1; +}; + +static int done = 0; + +static void basic_cb(void *ptr) +{ + printf("%p\n", ptr); + printf("done\n"); + done = 1; +} + +int main(int argc, char *argv[]) +{ + gs_op_id_t op_id; + void *myptr = malloc(1); + + btest_init(); + printf("%p\n", myptr); + run_outer_post(basic_cb, myptr, NULL, NULL, &op_id); + + while(done == 0) + { + btest_poll(NULL, 0); + } + + assert(here == 1); + btest_finalize(); + free(myptr); + return 0; +} Modified: trunk/code/src/gsl/tests/correctness/nested.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/nested.gs 2009-06-23 18:37:58 UTC (rev 594) +++ trunk/code/src/gsl/tests/correctness/nested.gs 2009-06-23 19:34:49 UTC (rev 595) @@ -3,7 +3,7 @@ static int here = 0; -static __blocking void run_inner(void) +static __blocking int run_inner(void) { int ret; int a = 0; @@ -11,6 +11,7 @@ ret = btest1(&a); assert(ret == 0); assert(a == 1); + return 0; } static __blocking void run_outer(void)

1 0

[Gs-commits] r594 - in trunk/code/src/gsl: . parser tests/correctness
by slang＠mcs.anl.gov 23 Jun '09

23 Jun '09

Author: slang Date: 2009-06-23 13:37:58 -0500 (Tue, 23 Jun 2009) New Revision: 594 Added: trunk/code/src/gsl/tests/correctness/nested.gs Modified: trunk/code/src/gsl/Makefile.in trunk/code/src/gsl/parser/gs-parser.lhs Log: Fix blocking funcions that return void (nothing). Added test case. Modified: trunk/code/src/gsl/Makefile.in =================================================================== --- trunk/code/src/gsl/Makefile.in 2009-06-23 18:07:25 UTC (rev 593) +++ trunk/code/src/gsl/Makefile.in 2009-06-23 18:37:58 UTC (rev 594) @@ -277,7 +277,7 @@ $(E)$(call MCC_GS,$<) -D__blocking="" \ -Dpwait="while(0)" -Dpbranch="" -Dpbreak="break"\ -I$(srcdir)/include/ -x c -c -o $@ $(LIBCFLAGS) \ - -Wall -Wno-implicit -Wno-unused-function -Werror \ + -Wall -Wno-implicit -Wno-unused -Werror \ $(CFLAGS) $(call MODCFLAGS_GS,$<) $< %.gs.i: %.gs %.gs.dummyobj Modified: trunk/code/src/gsl/parser/gs-parser.lhs =================================================================== --- trunk/code/src/gsl/parser/gs-parser.lhs 2009-06-23 18:07:25 UTC (rev 593) +++ trunk/code/src/gsl/parser/gs-parser.lhs 2009-06-23 18:37:58 UTC (rev 594) @@ -1097,27 +1097,33 @@ > ++ nextBlockingPostStmts > ++ [mkLabel "__gs_callback_end" [] $ getNI bctx]) $ getNI bctx +> mkCallbackReturnParamDecl :: (CTypeSpec, [CDerivedDeclr]) -> String -> NodeInfo -> [CDecl] +> mkCallbackReturnParamDecl ret@(retType, derives) name ni = +> -- no parameter if the return type is void +> if isVoidType ret then [] else +> [mkCDecl retType (filter (not . isDerivedFun) derives) (mkCallbackRetParam name ni) ni] + function definition, blocking call, return expression, statements after blocking call up to next blocking, optional next blocking call > mkCallbackDecl :: BlockingContext -> CExpr -> (CTypeSpec, [CDerivedDeclr]) -> CExtDecl -> mkCallbackDecl bctx blockingCall (lBretType, lBDerives) = +> mkCallbackDecl bctx blockingCall returnType = > let fname = getCallName blockingCall > params = getCallParams blockingCall > ni = getCallNodeInfo blockingCall > in mkStaticFunDecl (CVoidType ni) -- return type > (mkCallbackFunName (getParentName bctx) fname ni) -- function name -> [constructDeclFromC ni "void *__gs_ptr;", -- parameters -> mkCDecl lBretType (filter (not . isDerivedFun) lBDerives) (mkCallbackRetParam fname ni) ni] +> ([constructDeclFromC ni "void *__gs_ptr;"] ++ -- parameter for control state +> (mkCallbackReturnParamDecl returnType fname ni)) -- parameter for return type of blocking function > mkCallback :: String -> BlockingContext -> CExpr -> (CTypeSpec, [CDerivedDeclr]) -> [CStat] -> [CStat] -> CExtDecl -> mkCallback prefix bctx blockingCall (lBretType, lBDerives) stmts nextBlockingPostStmts = +> mkCallback prefix bctx blockingCall returnType stmts nextBlockingPostStmts = > let fname = getCallName blockingCall > params = getCallParams blockingCall > ni = getCallNodeInfo blockingCall > in mkStaticFunDef (CVoidType ni) -- return type > (mkCallbackFunName (getParentName bctx) fname ni) -- function name -> [constructDeclFromC ni "void *__gs_ptr;", -- parameters -> mkCDecl lBretType (filter (not . isDerivedFun) lBDerives) (mkCallbackRetParam fname ni) ni] +> ([constructDeclFromC ni "void *__gs_ptr;"] ++ -- parameter for control state +> (mkCallbackReturnParamDecl returnType fname ni)) -- parameter for return type of blocking function > (mkCallbackStmts prefix bctx stmts nextBlockingPostStmts) -- statements Take a blocking statement and a list of statements that follow Added: trunk/code/src/gsl/tests/correctness/nested.gs =================================================================== --- trunk/code/src/gsl/tests/correctness/nested.gs (rev 0) +++ trunk/code/src/gsl/tests/correctness/nested.gs 2009-06-23 18:37:58 UTC (rev 594) @@ -0,0 +1,49 @@ +#include "include/gs.h" +#include "tests/correctness/btest.gsh" + +static int here = 0; + +static __blocking void run_inner(void) +{ + int ret; + int a = 0; + + ret = btest1(&a); + assert(ret == 0); + assert(a == 1); +} + +static __blocking void run_outer(void) +{ + run_inner(); + here = 1; +} + +static int done = 0; + +static void basic_cb(void *ptr) +{ + printf("%p\n", ptr); + printf("done\n"); + done = 1; +} + +int main(int argc, char *argv[]) +{ + gs_op_id_t op_id; + void *myptr = malloc(1); + + btest_init(); + printf("%p\n", myptr); + run_outer_post(basic_cb, myptr, NULL, NULL, &op_id); + + while(done == 0) + { + btest_poll(NULL, 0); + } + + assert(here == 1); + btest_finalize(); + free(myptr); + return 0; +}

1 0