I translated GlxGears to HOpenGl, and it runs a bit slower than C version. I was curious what optimizations could be made to run it faster, or other comments. I love the style of Haskell, it leads one down the road to strong cohesion and low coupling as the easiest path. Even if all out speed was a top concern, I think it would be faster/more effective to write it in Haskell, then convert it to C. Haskell Version on my laptop, FPS = 103 C Version on my laptop, FPS = 192 I've included the source as text. Enjoy-- all constructive criticism appreciated. Beware the line wrap... Shawn ----------------------------------------------------------------------------- -- -- -- Copyright (c) 2004 Shawn P. Garbett -- All rights reserved. -- -- Redistribution and use in sourse and binary forms are permitted -- provided that the above copyright notice and this paragraph are -- duplicated in all such forms and that any documentation, -- advertising materials, and other materials related to such -- distribution and use acknowledge that the software was developed -- by Shawn P. Garbett. The name of Shawn P. Garbett -- may not be used to endorse or promote products derived from this -- software without specific prior writte permission. -- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EPXRESS OR -- IMPLIED WARRANTIES, INCLUDING LIMITATION, THE IMPLIED -- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. -- ------------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- -- Author - -- Shawn P. Garbett -- eLucid Software -- March, 2004 -- Modifications - -- -- Status - -- Public Domain. Distribution Unlimited. -- -- Bugs - -- The -i option prints nothing -- Auto exit not complete -- Why is it so slow compared to C? 103 fps in Haskell versus 192 fps in C -- -- Compile: ghc -package GLUT -o Gears Gears.hs -- ------------------------------------------------------------------------------- import Graphics.UI.GLUT as GLUT import Graphics.Rendering.OpenGL as OpenGL import System.Exit import Data.IORef import GHC.Base (chr) import System.Console.GetOpt import System.Environment (getArgs) instance HasSetter IORef where ($=) var val = writeIORef var val instance HasGetter IORef where get var = readIORef var new = newIORef type Frames = IORef (Int, Int) type View = IORef (GLfloat, GLfloat, GLfloat) type ViewFunc = ((GLfloat->GLfloat),(GLfloat->GLfloat),(GLfloat->GLfloat)) pi :: GLfloat pi = 3.14159265 configure :: IO (DisplayList,DisplayList,DisplayList) configure = do position (Light 0) $= Vertex4 5.0 5.0 10.0 0.0 lighting $= Enabled light (Light 0) $= Enabled depthFunc $= Just Less g1 <- gear1 g2 <- gear2 g3 <- gear3 normalize $= Enabled return (g1, g2, g3) -- Command line options (that start with a dash) data Flag = GLInfo | Exit deriving Show options :: [OptDescr Flag] options = [ Option ['i'] ["info"] (NoArg GLInfo) "print gl information", Option ['e'] ["exit"] (NoArg Exit) "auto exit after 30 seconds" ] usageHeader :: String usageHeader = "Usage: Gears [-info] [-exit]" opts :: [String] -> IO [Flag] opts argv = case (getOpt Permute options argv) of (o,_,[]) -> return o (_,_,errs) -> ioError $ userError $ concat errs ++ usageInfo usageHeader options -- Print info about the GL renderer info' :: IO () info' = do rendererStr <- get renderer putStr "GL_RENDERER = " putStr rendererStr putStr "\n" vendorStr <- get vendor putStr "GL_VENDOR = " putStr vendorStr putStr "\n" versionStr <- get glVersion putStr "GL_VERSION = " putStr versionStr putStr "\n" extStr <- get glExtensions putStr "GL_EXTENSIONS = " putStr $ show extStr putStr "\n" -- Was the info flag given? info :: [Flag] -> IO () info (GLInfo:_) = info' info (_:fs) = info fs info _ = return () -- Main main :: IO () main = do (progName,args) <- getArgsAndInitialize flags <- opts args info flags initialDisplayMode $= [RGBMode, WithDepthBuffer, DoubleBuffered] -- View rotation variable (x,y,z) viewRot <- new (20.0::GLfloat, 30.0::GLfloat, 0.0::GLfloat) -- Gear angle variable angle <- new (0.0::GLfloat) -- Frames frames <- new (0, 0) -- Create the window createWindow progName gears <- configure -- Hook up callbacks displayCallback $= display gears frames viewRot angle reshapeCallback $= Just reshape keyboardMouseCallback $= Just (keyboard viewRot) visibilityCallback $= Just (visible angle) --go for it mainLoop -- Reshape event handling reshape :: Size -> IO () reshape s@(Size w h) = do let r = (fromIntegral h)/(fromIntegral w) viewport $= (Position 0 0, s) matrixMode $= Projection loadIdentity frustum (-1.0) 1.0 (-r) r 5.0 60.0 matrixMode $= Modelview 0 loadIdentity translate (Vector3 0 0 (-40.0::GLfloat)) -- Visibility event handling visible :: IORef GLfloat -> Visibility -> IO () visible angle Visible = idleCallback $= Just (idle angle) visible _ NotVisible = idleCallback $= Nothing -- Idle event handling idle :: IORef GLfloat -> IO () idle angle = do a <- get angle angle $= a + 2.0; postRedisplay Nothing -- Color constants red = Color4 0.8 0.1 0.0 1.0 green = Color4 0.0 0.8 0.2 1.0 blue = Color4 0.2 0.2 1.0 1.0 -- Front of gear face gearFront :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLint -> GLint -> IO () gearFront r0 r1 w da n t = do let angle = (fromIntegral n)*2.0*Main.pi/(fromIntegral t) vertex $ Vertex3 (r0*(cos angle)) (r0*(sin angle)) w vertex $ Vertex3 (r1*(cos angle)) (r1*(sin angle)) w if (n<t) then do vertex $ Vertex3 (r0*(cos angle)) (r0*(sin angle)) w vertex $ Vertex3 (r1*(cos (angle+3*da))) (r1*(sin (angle+3*da))) w gearFront r0 r1 w da (n+1) t else return () -- front side of teeth teethFront :: GLfloat->GLfloat->GLfloat->GLfloat->GLint->GLint->IO () teethFront r1 r2 w da n t = do if (n<t) then do let angle = (fromIntegral n)*2.0*Main.pi/(fromIntegral t) vertex $ Vertex3 (r1*(cos angle)) (r1*(sin angle)) w vertex $ Vertex3 (r2*(cos (angle+da))) (r2*(sin (angle+da))) w vertex $ Vertex3 (r2*(cos (angle+2.0*da))) (r2*(sin (angle+2.0*da))) w vertex $ Vertex3 (r1*(cos (angle+3.0*da))) (r1*(sin (angle+3.0*da))) w teethFront r1 r2 w da (n+1) t else return () --back side of gear gearBack :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLint -> GLint -> IO () gearBack r0 r1 w da n t = do let angle = (fromIntegral n)*2.0*Main.pi/(fromIntegral t) vertex $ Vertex3 (r1*(cos angle)) (r1*(sin angle)) w vertex $ Vertex3 (r0*(cos angle)) (r0*(sin angle)) w if (n<t) then do vertex $ Vertex3 (r1*(cos (angle+3*da))) (r1*(sin (angle+3*da))) w vertex $ Vertex3 (r0*(cos angle)) (r0*(sin angle)) w gearFront r0 r1 w da (n+1) t else return () -- back side of teeth teethBack :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLint -> GLint -> IO() teethBack r1 r2 w da n t = do if (n<t) then do let angle = (fromIntegral n)*2.0*Main.pi/(fromIntegral t) vertex $ Vertex3 (r1*(cos (angle+3.0*da))) (r1*(sin (angle+3.0*da))) w vertex $ Vertex3 (r2*(cos (angle+2.0*da))) (r2*(sin (angle+2.0*da))) w vertex $ Vertex3 (r2*(cos (angle+1.0*da))) (r2*(sin (angle+1.0*da))) w vertex $ Vertex3 (r1*(cos (angle+da))) (r1*(sin (angle+da))) w teethBack r1 r2 w da (n+1) t else return () -- Outward faces of teeth */ teethFace :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLint -> GLint -> IO () teethFace r1 r2 w da n t = if (n<t) then do let angle = (fromIntegral n)*2.0*Main.pi/(fromIntegral t) nw = (-w) u' = r2*(cos (angle+da)) - r1*(cos angle) v' = r2*(sin (angle+da)) - r1*(sin angle) len = sqrt (u'*u'+v'*v') u = u'/len v = v'/len u2 = r1*(cos (angle+3.0*da))-r2*(cos (angle+2.0*da)) v2 = r1*(sin (angle+3.0*da))-r2*(sin (angle+2.0*da)) vertex $ Vertex3 (r1*(cos angle)) (r1*(sin angle)) w vertex $ Vertex3 (r1*(cos angle)) (r1*(sin angle)) nw currentNormal $= Normal3 v (-u) 0.0 vertex $ Vertex3 (r2*(cos (angle+da))) (r2*(sin (angle+da))) w vertex $ Vertex3 (r2*(cos (angle+da))) (r2*(sin (angle+da))) nw currentNormal $= Normal3 (cos angle) (sin angle) 0.0 vertex $ Vertex3 (r2*(cos (angle+2.0*da))) (r2*(sin (angle+2.0*da))) w vertex $ Vertex3 (r2*(cos (angle+2.0*da))) (r2*(sin (angle+2.0*da))) nw currentNormal $= Normal3 v (-u) 0.0 vertex $ Vertex3 (r1*(cos (angle+3.0*da))) (r1*(sin (angle+3.0*da))) w vertex $ Vertex3 (r1*(cos (angle+3.0*da))) (r1*(sin (angle+3.0*da))) nw currentNormal $= Normal3 (cos angle) (sin angle) 0.0 teethFace r1 r2 w da (n+1) t else do vertex $ Vertex3 r1 0.0 w vertex $ Vertex3 r1 0.0 (-w) -- Inside Radius gearInside :: GLfloat -> GLfloat -> GLint -> GLint -> IO () gearInside r w n t = do let angle = (fromIntegral n)*2.0*Main.pi/(fromIntegral t) currentNormal $= Normal3 (-(cos angle)) (-(sin angle)) 0.0 vertex $ Vertex3 (r*(cos angle)) (r*(sin angle)) (-w) vertex $ Vertex3 (r*(cos angle)) (r*(sin angle)) w if (n<t) then gearInside r w (n+1) t else return () -- Gear drawing routine gear :: GLfloat -> GLfloat -> GLfloat -> GLint -> GLfloat -> IO () gear r0 o_radius width teeth depth = do let r1 = o_radius - depth / 2.0::GLfloat r2 = o_radius + depth / 2.0::GLfloat da = 2.0 * Main.pi / (fromIntegral teeth) / 4.0::GLfloat w = 0.5 * width shadeModel $= Flat currentNormal $= Normal3 0.0 0.0 (1.0::GLfloat) renderPrimitive QuadStrip $ gearFront r0 r1 w da 0 teeth renderPrimitive Quads $ teethFront r1 r2 w da 0 teeth renderPrimitive QuadStrip $ gearBack r0 r1 (-w) da 0 teeth renderPrimitive Quads $ teethBack r1 r2 (-w) da 0 teeth renderPrimitive QuadStrip $ teethFace r1 r2 w da 0 teeth shadeModel $= Smooth renderPrimitive QuadStrip $ gearInside r0 w 0 teeth return () -- Create the different gears gear1 :: IO DisplayList gear1 = defineNewList Compile $ do materialAmbientAndDiffuse Front $= red gear (1.0::GLfloat) (4.0::GLfloat) (1.0::GLfloat) (20::GLint) (0.7::GLfloat) gear2 :: IO DisplayList gear2 = defineNewList Compile $ do materialAmbientAndDiffuse Front $= green gear (0.5::GLfloat) (2.0::GLfloat) (2.0::GLfloat) (10::GLint) (0.7::GLfloat) gear3 :: IO DisplayList gear3 = defineNewList Compile $ do materialAmbientAndDiffuse Front $= blue gear (1.3::GLfloat) (2.0::GLfloat) (0.5::GLfloat) (10::GLint) (0.7::GLfloat) printFPS :: Frames -> IO () printFPS frame = do (f,et) <- get frame ms <- get elapsedTime if ((ms - et) > 5000) then do let seconds = (fromIntegral (ms - et))/1000.0 fps = (fromIntegral f) / seconds putStr $ show f putStr " frames in " putStr $ show seconds putStr " seconds = " putStr $ show fps putStr " FPS\n" frame $= (0, ms) else frame $= (f+1, et) -- Display event handling display :: (DisplayList,DisplayList,DisplayList) -> Frames -> View -> IORef GLfloat -> IO () display (g1,g2,g3) frames viewRot angle = do clear [ColorBuffer,DepthBuffer] (x,y,z) <- get viewRot a <- get angle printFPS frames preservingMatrix $ do rotate x $ Vector3 (1.0::GLfloat) 0 0 rotate y $ Vector3 0 (1.0::GLfloat) 0 rotate z $ Vector3 0 0 (1.0::GLfloat) -- Gear 1 preservingMatrix $ do translate $ Vector3 (-3.0::GLfloat) (-2.0::GLfloat) 0 rotate a $ Vector3 0 0 (1.0::GLfloat) callList g1 -- Gear 2 preservingMatrix $ do translate $ Vector3 (3.1::GLfloat) (-2.0::GLfloat) 0 rotate (-2.0 * a - 9.0) $ Vector3 0 0 (1.0::GLfloat) callList g2 -- Gear 3 preservingMatrix $ do translate $ Vector3 (-3.1::GLfloat) (4.2::GLfloat) 0 rotate (-2.0 * a - 25.0) $ Vector3 0 0 (1.0::GLfloat) callList g3 swapBuffers -- Keyboard event handling (modify view or exit) keyboard :: View -> Key -> KeyState -> Modifiers -> Position -> IO () keyboard view c _ _ _ = keyForPos view c keyForPos :: View -> Key -> IO () keyForPos _ (Char 'q') = exitWith ExitSuccess keyForPos _ (Char 'Q') = exitWith ExitSuccess keyForPos viewRot (Char 'z') = modRot viewRot (id, id, \x->x-5) keyForPos viewRot (Char 'Z') = modRot viewRot (id, id, (+)5) keyForPos viewRot (SpecialKey KeyLeft) = modRot viewRot (id, (+)5, id) keyForPos viewRot (SpecialKey KeyRight)= modRot viewRot (id, \x->x-5,id) keyForPos viewRot (SpecialKey KeyUp) = modRot viewRot ((+)5, id, id) keyForPos viewRot (SpecialKey KeyDown) = modRot viewRot (\x->x-5,id, id) keyForPos _ (Char c) = if (c == (chr 27)) then exitWith ExitSuccess else return () keyForPos _ _ = return () modRot :: View -> ViewFunc -> IO () modRot viewRot (fx,fy,fz) = do (x,y,z) <- get viewRot viewRot $= (fx x, fy y, fz z) postRedisplay Nothing
Shawn P. Garbett wrote:
[...] Haskell Version on my laptop, FPS = 103 C Version on my laptop, FPS = 192 [...]
I just gave your example a quick try on my PC, the results do not differ that much for my setup (SuSE x86 Linux 8.2, 3GHz P4, NVIDIA FX 5900): Haskell version: 6000 FPS C version: 7165 FPS Curiously, using -O for the Haskell compilation doesn't make any difference. I'll take a closer look with GHC's profiler and the ltrace tool when I get some time. Thanks for the conversion BTW, I'd like to place this example into GLUT'S "Misc" example directory, with a BSD-like license. Would that be OK? Cheers, S.
On Tuesday 16 March 2004 2:09 am, Sven Panne wrote:
Shawn P. Garbett wrote:
[...] Haskell Version on my laptop, FPS = 103 C Version on my laptop, FPS = 192 [...]
I just gave your example a quick try on my PC, the results do not differ that much for my setup (SuSE x86 Linux 8.2, 3GHz P4, NVIDIA FX 5900):
Haskell version: 6000 FPS C version: 7165 FPS
That's even better. The actual difference isn't x2 on a fast box, but much closer. So for a performing box, the speed difference is quite acceptable given the gains of working in Haskell. Good job to the HOpenGL folks.
Curiously, using -O for the Haskell compilation doesn't make any difference. I'll take a closer look with GHC's profiler and the ltrace tool when I get some time.
Thanks for the conversion BTW, I'd like to place this example into GLUT'S "Misc" example directory, with a BSD-like license. Would that be OK?
That was the intent of the copyright at the top. Maybe I got it wrong, but it's supposed to be a BSD style license. I really don't care how it's used, but I just wanted to show my support for the BSD code sharing method. I suspect that data marshalling is most of the speed difference. As I understand when a program misses a frame refresh window, OpenGL put's it in the next frame refresh window, so the actual speed difference may be quite small and it occasionally misses the refresh window. Shawn
I wrote:
Shawn P. Garbett wrote:
[...] Haskell Version on my laptop, FPS = 103 C Version on my laptop, FPS = 192 [...]
I just gave your example a quick try on my PC, the results do not differ that much for my setup (SuSE x86 Linux 8.2, 3GHz P4, NVIDIA FX 5900):
Haskell version: 6000 FPS C version: 7165 FPS [...]
I've just overhauled your example and it's now in the GLUT examples: http://cvs.haskell.org/cgi-bin/cvsweb.cgi/fptools/libraries/GLUT/examples/Mi... (Well, it's visible there when the mysterious cron job has done its job to update the anonymous CVS repository... :-P) The good news: It runs with 7162 FPS now, which is only 0.03% slower than the C version! :-) The problem with your version was that due to some minor buglets it rendered a slightly different scene, backface culling was not enabled, and some normals were missing. Using ltrace to compare the libGL/libglut library calls of the C version with the ones of the Haskell version was very helpful here. Furthermore, there was a small transient space leak (the frame counter). Note that I haven't even incorporated SimonM's hint of using strict unboxed constructor fields yet, but I'll do that probably soon, anyway. It might not only help performance, but also avoids some potential space leaks. Playing around with various window sizes, it becomes clear that in this example rasterization and framebuffer access dominates: The product of the number of window pixels and the FPS is nearly constant for my platform, but your mileage may vary here. For a nice introduction to performance tuning OpenGL apps see: http://developer.nvidia.com/docs/IO/8230/GDC2003_OGL_Performance.pdf Perhaps I should cross-post to the "Haskell performance" thread... :-)) Cheers, S.
I wrote:
[...] It runs with 7162 FPS now, which is only 0.03% slower than the C version! :-)
A small note: After a hint from SimonM, I've just made some minor performance tweaks to the OpenGL package (making some constructor fields strict and letting GHC unbox them automatically). The Haskell version is now *exactly* as fast as the C version. :-) Cheers, S.
On Sunday 21 March 2004 6:31 am, Sven Panne wrote:
I wrote:
[...] It runs with 7162 FPS now, which is only 0.03% slower than the C version! :-)
A small note: After a hint from SimonM, I've just made some minor performance tweaks to the OpenGL package (making some constructor fields strict and letting GHC unbox them automatically). The Haskell version is now *exactly* as fast as the C version.
I ran it on slow hardware, and got faster (just slightly) frame rates in Haskell than in C. All with the new version having 20% less code than C. Shawn
Hello, I am doing the implementation for my computer graphics research project in Haskell, I recently installed the last version of GHC (6.2.1) that comes with the new OpenGL binding. I was just starting to port my code to it, but I have trouble finding some basic functionnalities (like glTexImage2D for instance). Is that binding incomplete ? If yes when will it be finished ? If no when will the redbook examples be ported to it ? I am reduced to greping the code of the binding for calls to the C openGL functions and suspect that I am missing things. Thank you very much for your help, Yann Morvan
[ I'm cross-posting this, perhaps some kind soul has binary snapshots available. ] Yann Morvan wrote:
[...] I recently installed the last version of GHC (6.2.1) that comes with the new OpenGL binding. I was just starting to port my code to it, but I have trouble finding some basic functionnalities (like glTexImage2D for instance). Is that binding incomplete ?
Alas, no, the OpenGL binding on the release branch is not complete.
If yes when will it be finished ? If no when will the redbook examples be ported to it ?
The story is quite a bit different on the main branch, the binding is almost finished there, you get OpenGL 1.5 plus a few dozen extensions. The only missing bit is currently NURBS, but it's already halfway there. We generally don't merge new features onto the release branch, only bug fixes, hence the difference. Currently there are "official" releases including this, but if you can tell a bit about your intended platform, perhaps somebody else on the GHC/Hugs mailing lists can help (Linux, WinDoze, MacOS X and Solaris reportedly work). I can offer bleeding edge snapshots of Hugs and GHC including the latest and greatest OpenGL/GLUT binding compiled for x86 Linux (SuSE 9.1, don't know if the RPMs work on other platforms). Another option is building GHC and/or Hugs from CVS for yourself, which is not that hard nowadays (at least if you have enough GB and GHz :-), see: http://haskell.org/ghc/docs/latest/html/building/building-guide.html
I am reduced to greping the code of the binding for calls to the C openGL functions and suspect that I am missing things.
Thanks to Haddock, there is no need for grep-ing. I keep the docs on http://haskell.org/HOpenGL/newAPI/ fairly actual, and the GHC packages include similar documentation. Cheers, S.
participants (3)
-
Shawn P. Garbett -
Sven Panne -
Yann Morvan