Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Make profiling possible by skipping the GHC API

Clean up signals after GHC API
  • Loading branch information...
commit be0007879dec69c62c52af609f6f53c2e1074fb4 1 parent a2b00c5
@cdsmith authored
View
2  .gitignore
@@ -5,3 +5,5 @@ tmp/*.hi
tmp/*.o
tmp/*.png
log
+gloss-web.hp
+gloss-web.prof
View
3  gloss-web.cabal
@@ -15,7 +15,8 @@ Cabal-version: >=1.2
Executable gloss-web
Hs-source-dirs: src
Main-is: Main.hs
- Ghc-options: -O2
+ Ghc-options: -O2 -rtsopts -auto-all
+ Ghc-prof-options: -DPROFILE_SUBST
Build-depends: aeson,
array,
base,
View
83 src/ProfileSubst.hs
@@ -0,0 +1,83 @@
+{-|
+ Versions of the picture, animation, and simulation code to substitute in
+ during profiling builds. When profiling is turned on, we can't use the
+ GHC API, so instead we directly build in the following implementations.
+
+ These are intentionally chosen to be somewhat demanding, in hopes that
+ we can get some good profiling data.
+-}
+module ProfileSubst (
+ picture,
+ animation,
+ simulation
+ )
+ where
+
+import Graphics.Gloss
+import GlossAdapters
+
+-----------------------------------------------------------------------
+
+picture = kochSnowflake 5
+
+kochSnowflake n = pictures [
+ rotate 0 (translate 0 (-sqrt 3 * 100 / 6) (kochLine 100 n)),
+ rotate 120 (translate 0 (-sqrt 3 * 100 / 6) (kochLine 100 n)),
+ rotate 240 (translate 0 (-sqrt 3 * 100 / 6) (kochLine 100 n))
+ ]
+
+kochLine k 0 = line [(-k/2, 0), (k/2, 0) ]
+kochLine k n = pictures [
+ translate ( k/3) 0 (kochLine (k/3) (n-1)),
+ translate (-k/3) 0 (kochLine (k/3) (n-1)),
+ translate (-k/12) (-sqrt 3 * k/12) (rotate 300 (kochLine (k/3) (n-1))),
+ translate ( k/12) (-sqrt 3 * k/12) (rotate 60 (kochLine (k/3) (n-1)))
+ ]
+
+-----------------------------------------------------------------------
+
+animation :: Float -> Picture
+animation time
+ = Scale 0.8 0.8 $ Translate 0 (-300)
+ $ tree 4 time (dim $ dim brown)
+
+stump :: Color -> Picture
+stump color
+ = Color color
+ $ Polygon [(30,0), (15,300), (-15,300), (-30,0)]
+
+tree :: Int
+ -> Float
+ -> Color
+ -> Picture
+
+tree 0 time color = stump color
+tree n time color
+ = let smallTree
+ = Rotate (sin time)
+ $ Scale 0.5 0.5
+ $ tree (n-1) (- time) (greener color)
+ in Pictures
+ [ stump color
+ , Translate 0 300 $ smallTree
+ , Translate 0 240 $ Rotate 20 smallTree
+ , Translate 0 180 $ Rotate (-20) smallTree
+ , Translate 0 120 $ Rotate 40 smallTree
+ , Translate 0 60 $ Rotate (-40) smallTree ]
+
+brown :: Color
+brown = makeColor8 139 100 35 255
+
+greener :: Color -> Color
+greener c = mixColors 1 10 green c
+
+-----------------------------------------------------------------------
+
+simulation = Simulation initial step draw
+
+data Ball = Ball Float Float
+
+initial = Ball 100 0
+step _ t (Ball x v) = Ball (x + v*t) (v - x*t)
+draw (Ball x v) = translate x 0 (circle 20)
+
View
61 src/ProtectHandlers.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE CPP #-}
+
+{-|
+ Save off signal handlers and such, so that they can be restored following
+ the use of the GHC API. Code shamelessly stolen from Snap.
+-}
+module ProtectHandlers (protectHandlers) where
+
+import Control.Exception
+
+#ifdef mingw32_HOST_OS
+
+{-
+ Win32 Version: Save the console handler using GHC primitives.
+-}
+
+import GHC.ConsoleHandler as C
+
+
+saveHandlers :: IO C.Handler
+saveHandlers = C.installHandler Ignore
+
+
+restoreHandlers :: C.Handler -> IO C.Handler
+restoreHandlers = C.installHandler
+
+#else
+
+{-
+ UNIX Version: Save signal handlers
+-}
+
+import qualified System.Posix.Signals as S
+
+
+helper :: S.Handler -> S.Signal -> IO S.Handler
+helper handler signal = S.installHandler signal handler Nothing
+
+
+signals :: [S.Signal]
+signals = [ S.sigQUIT
+ , S.sigINT
+ , S.sigHUP
+ , S.sigTERM
+ ]
+
+
+saveHandlers :: IO [S.Handler]
+saveHandlers = mapM (helper S.Ignore) signals
+
+
+restoreHandlers :: [S.Handler] -> IO [S.Handler]
+restoreHandlers h = sequence $ zipWith helper h signals
+#endif
+
+{-|
+ Run an IO action with handlers saved and restored.
+-}
+protectHandlers :: IO a -> IO a
+protectHandlers a = bracket saveHandlers restoreHandlers $ const a
+
View
48 src/Source.hs
@@ -36,50 +36,22 @@ import qualified DynFlags as GHC
import App
import GlossAdapters
+import ProtectHandlers
+#ifdef PROFILE_SUBST
-#ifdef mingw32_HOST_OS
-import GHC.ConsoleHandler as C
-
-
-saveHandlers :: IO C.Handler
-saveHandlers = C.installHandler Ignore
+import ProfileSubst
+getPicture :: App -> ByteString -> IO (Either [String] Picture)
+getPicture _ _ = return (Right picture)
-restoreHandlers :: C.Handler -> IO C.Handler
-restoreHandlers = C.installHandler
+getAnimation :: App -> ByteString -> IO (Either [String] (Float -> Picture))
+getAnimation _ _ = return (Right animation)
+getSimulation :: App -> ByteString -> IO (Either [String] Simulation)
+getSimulation _ _ = return (Right simulation)
#else
-import qualified System.Posix.Signals as S
-
-helper :: S.Handler -> S.Signal -> IO S.Handler
-helper handler signal = S.installHandler signal handler Nothing
-
-
-signals :: [S.Signal]
-signals = [ S.sigQUIT
- , S.sigINT
- , S.sigHUP
- , S.sigTERM
- ]
-
-
-saveHandlers :: IO [S.Handler]
-saveHandlers = mapM (helper S.Ignore) signals
-
-
-restoreHandlers :: [S.Handler] -> IO [S.Handler]
-restoreHandlers h = sequence $ zipWith helper h signals
-#endif
-
-{-|
- Save off signal handlers and such, so that they can be restored following
- the use of the GHC API. Code shamelessly stolen from Snap.
--}
-protectHandlers :: IO a -> IO a
-protectHandlers a = bracket saveHandlers restoreHandlers $ const a
-
getPicture :: App -> ByteString -> IO (Either [String] Picture)
getPicture app src = do
@@ -104,6 +76,8 @@ getSimulation app src = do
"Simulation"
src
+#endif
+
{-|
Base64 encodes a ByteString, and forms a filename from it. Since this is
a file name, we need to use '-' intead of '/'.
Please sign in to comment.
Something went wrong with that request. Please try again.