I have a program (no doubt pretty grotty - I'm still messing around learning Haskell) which causes GHC (4.04.19990916) to produce an executable which coredumps. The source is attached (and is quite small). I'm using a GHC binary package from Debian GNU/Linux, binary package version 4.04.19990916-0slink1 built by Michael Weber <[EMAIL PROTECTED]>. As soon as I get it to compile I'll try a compiler installation I built myself. -davenant:stalk> make XHCFLAGS=-dcore-lint ghc -syslib posix -syslib exts -syslib misc -dcore-lint -c XSM.hs ghc: module version changed to 1; reason: no old .hi file ghc -syslib posix -syslib exts -syslib misc -dcore-lint -c server.hs ghc: module version changed to 1; reason: no old .hi file ghc -syslib posix -syslib exts -syslib misc -dcore-lint -o nettlestalk server.o XSM.o -davenant:stalk> ./nettlestalk foo Segmentation fault (core dumped) -davenant:stalk> gcc -v Reading specs from /usr/lib/gcc-lib/i486-linux/egcs-2.91.66/specs gcc version egcs-2.91.66 Debian GNU/Linux (egcs-1.1.2 release) -davenant:stalk> dpkg -l 'ghc*' 'libc6*' 'gcc*' Desired=Unknown/Install/Remove/Purge | Status=Not/Installed/Config-files/Unpacked/Failed-config/Half-installed |/ Err?=(none)/Hold/Reinst-required/X=both-problems (Status,Err: uppercase=bad) ||/ Name Version Description +++-===============-==============-============================================ ii ghc4 4.04.19990916- GHC - the Glasgow Haskell Compilation system un ghc4-doc <none> (no description available) ii ghc4-libsrc 4.04.19990916- Library Sources of GHC - the Glasgow Haskell ii libc6 2.1.1-12 GNU C Library: Shared libraries and timezone ii libc6-dbg 2.1.1-12 GNU C Library: Libraries with debugging symb ii libc6-dev 2.1.1-12 GNU C Library: Development libraries and hea pn libc6-doc <none> (no description available) ii libc6-pic 2.1.1-12 GNU C Library: PIC archive library ii libc6-prof 2.1.1-12 GNU C Library: Profiling libraries. un libc6.1 <none> (no description available) ii gcc 2.91.66-2 The GNU (EGCS) C compiler. ii gcc-doc 2.95.1-2 Documentation for the GNU compilers (gcc, go pn gcc-docs <none> (no description available) pn gcc-i386-gnu <none> (no description available) pn gcc-m68k-linux <none> (no description available) un gcc-m68k-palmos <none> (no description available) un gcc-ss <none> (no description available) pn gccchecker <none> (no description available) -davenant:stalk> uname -av Linux davenant 2.2.12 #4 Sun Sep 19 23:27:21 BST 1999 i586 unknown -davenant:stalk> Ian.
-- X-war (Warcraft/Starcraft/C&C-alike) server prototype -- Copyright (C)1999 Ian Jackson <[EMAIL PROTECTED]> -- -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2, or (at your option) -- any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program; if not, write to the Free Software Foundation, -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- -- $Id: server.hs,v 1.7 1999/12/05 16:29:04 ian Exp $ import Int import FiniteMap import IOExts import XSM type UnitID = Int32 type Coord = Int type HitPoints = Int type PlayerNum = Int type Interval = Int {-ms-} data Orders = OrdersNone | OrdersAttack UnitID | OrdersMove { ordmvx, ordmvy::Int } instance Show Orders where showsPrec _ OrdersNone = ("None"++) showsPrec _ (OrdersAttack v) = ("Attack "++).(shows v) showsPrec _ (OrdersMove x y) = ("Move "++).(shows x).(" "++).(shows y) data UnitBase = UnitBase { ubpn :: PlayerNum, ubx, uby :: Coord, ubhp :: HitPoints, ubcloak :: Bool, uborders :: Orders } instance Show UnitBase where showsPrec _ (UnitBase pn x y hp cloak orders) = ( ("UnitBase { ubpn="++) . (shows pn) . (", ubx="++) . (shows x) . (", uby="++) . (shows y) . (", ubhp="++) . (shows hp) . (", ubcloak="++) . (shows cloak) . (", uborders="++) . (shows orders) . (" }++"++) ) data Unit = Unit UnitID UnitBase UnitType instance Show Unit where showsPrec _ (Unit ui ub ut) = ("u#"++) . (shows ui) . (": "++) . (shows ub) . (" "++) . (shows ut) data UnitType = Marine instance Show UnitType where showsPrec _ ut = ((utName ut)++) utName Marine = "Marine" initHP Marine = 100 notifReUnitType ub ut o = [] -- defaults from here onwards isDetector _ = False data Visibility = VisNone | VisNormal | VisDetect instance Show Visibility where showsPrec _ VisNone = ('-':) showsPrec _ VisNormal = ('o':) showsPrec _ VisDetect = ('*':) data Player = Player { plpn :: PlayerNum, plname :: String, plvis :: [[Visibility]], plshvis :: [PlayerNum] -- players we share vision with } instance Show Player where showsPrec _ pl = ( ("p#"++) . (shows $ plpn pl) . (": name=\""++) . ((plname pl) ++) . ("\" vis="++) . (shows $ plvis pl) . (" shvis="++) . (shows $ plshvis pl) ) emptyPlayer pn xsz ysz = Player { plpn = pn, plname = ("player "++(show pn)), plvis = replicate ysz (replicate xsz VisNormal), plshvis = [pn] } data GameState = GameState { gsnextuid :: UnitID, gsu :: FiniteMap UnitID Unit, gspl :: [Player] } instance Show GameState where showsPrec _ gs = ( ("nextuid="++) . (shows (gsnextuid gs)) . (" players="++) . (shows (gspl gs)) . (" nunits="++) . (shows (sizeFM (gsu gs))) . (foldr (\ (ui,u) o -> o . ("\n "++) . (shows u) ) id (fmToList (gsu gs))) ) emptyGameState nplayers xsz ysz = GameState { gsnextuid=1, gsu=emptyFM, gspl= [ emptyPlayer p xsz ysz | p <- [1..nplayers] ] } -- Game Monad type CallBack = (Interval, GM ()) data GameContext = GameContext GameState [CallBack] [Notification] instance Show GameContext where showsPrec _ (GameContext gs cbs notifs) = ("gamestate: "++) . (shows gs) . ("\ncallbacks: "++) . (shows (map callbackint cbs)) . ("\n"++) . (shownotifs notifs) where callbackint (i,acts) = i shownotifs [] = id shownotifs (n:ns) = (shows n) . ("\n"++) . (shownotifs ns) type GM rt = PureSM GameContext rt runGM :: GameState -> [CallBack] -> GM rt -> (rt, GameContext) runGM s0 cb0 acts = runPureSM (GameContext s0 cb0 []) acts readGM :: GM GameState readGM = do GameContext gs _ _ <- readXSM return gs updateGM :: (GameState -> GameState) -> GM () updateGM stf = updateXSM xstf where xstf (GameContext gs cbs nfs) = GameContext (stf gs) cbs nfs setGM :: GameState -> GM () setGM ngs = updateGM stf where stf _ = ngs afterGM :: Interval -> GM () -> GM () afterGM iv acts = do updateXSM xstf where xstf (GameContext gs cbs nfs) = GameContext gs ncbs nfs where ncbs = insertCallBack cbs (iv,acts) insertCallBack [] new = [new] insertCallBack existings new | firsti < newi = [first] ++ insertCallBack rest new | firsti >= newi = [new] ++ existings where (first:rest) = existings (firsti,_) = first (newi,_) = new notifyGM :: [Notification] -> GM () notifyGM news = updateXSM xstf where xstf (GameContext gs cbs olds) = GameContext gs cbs (olds++news) -- Notifications data NotifProp = NPropUnitID UnitID | NPropOrders Orders | NPropPlayer PlayerNum | NPropLocation Coord Coord | NPropHP HitPoints | NPropCloak Bool instance Show NotifProp where showsPrec _ (NPropUnitID v) = ("UnitID "++).(shows v) showsPrec _ (NPropOrders v) = ("Orders "++).(shows v) showsPrec _ (NPropPlayer v) = ("Player "++).(shows v) showsPrec _ (NPropLocation x y) = ("Location "++).(shows x).(" "++).(shows y) showsPrec _ (NPropHP v) = ("HP "++).(shows v) showsPrec _ (NPropCloak v) = ("Cloak "++).(shows v) data Notification = Notification PlayerNum NotifType [NotifProp] instance Show Notification where showsPrec _ (Notification pn nt nps) = head . showprops . tail where head = ("(Notification "++).(shows pn).(" "++).(shows nt) showprops = foldl addsp id nps tail = (")"++) addsp orgshows p = orgshows.(" ("++).(shows p).(")"++) data NotifType = NotifUnit instance Show NotifType where showsPrec _ NotifUnit = ("Unit"++) notifyReUnit u = do gs <- readGM notifyGM $ notifsReUnit u gs notifsReUnit :: Unit -> GameState -> [Notification] notifsReUnit u@(Unit ui ub ut) gs = concatMap n1 (gspl gs) where n1 pl = let tpn = plpn pl in nr1 tpn u gs (plvis pl !! uby ub !! ubx ub) (ubcloak ub) (tpn == (ubpn ub)) nr1 pn u gs VisNone _ False = [] nr1 pn u gs VisNormal True False = [] nr1 pn u@(Unit ui ub ut) gs _ _ own = [n] where unitnotifs = [NPropUnitID ui] ++ (nbase ub own) ++ (notifReUnitType ub ut own) n = Notification pn NotifUnit unitnotifs nbase ub True = (nbase ub False) ++ [NPropOrders (uborders ub)] nbase ub False = [ NPropPlayer (ubpn ub), NPropLocation (ubx ub) (uby ub), NPropHP (ubhp ub), NPropCloak (ubcloak ub) ] -- General unit handling stuff readUnit :: UnitID -> GM Unit readUnit ui = do gs <- readGM return $ lookupWithDefaultFM (gsu gs) undefined ui -- unitUpdateVisibility :: Unit -> GM () -- unitUpdateVisibility u@(_ ub _) = do -- gs <- readGM -- mapM [ findPlayer pn | pn <- ubpn ub gs setUnit :: Unit -> GM () setUnit u@(Unit ui _ _) = do updateGM $ \gs -> gs { gsu = addToFM (gsu gs) ui u } notifyReUnit u -- unitUpdateVisibility u updateUnit :: UnitID -> (Unit -> GameState -> Unit) -> GM () updateUnit ui stf = do gs <- readGM u <- readUnit ui setUnit (stf u gs) -- Specific stuff newUnitID :: GM UnitID newUnitID = do gs <- readGM let ui = gsnextuid gs in do let iu gs = gs { gsnextuid = ui+1 } in updateGM iu return (trace ("allocated unit ID "++(show ui)++"\n") ui) registerUnit :: PlayerNum -> Coord -> Coord -> UnitType -> GM UnitID registerUnit pn x y ut = do ui <- newUnitID setUnit $ Unit ui (UnitBase pn x y (initHP ut) False OrdersNone) ut return ui theGame = do m1 <- registerUnit 1 1 1 Marine m2 <- registerUnit 2 2 2 Marine return (m1,m2) startGame = emptyGameState 2 5 5 dumpGM_dbg gs = do inXSM $ putStr $ "game state: "++(show gs)++"\n" main :: IO () main = do putStr "foo\n" putStr (show r) where r = runGM startGame [] theGame
-- Extra State Monad -- Copyright (C)1999 Ian Jackson <[EMAIL PROTECTED]> -- -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2, or (at your option) -- any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program; if not, write to the Free Software Foundation, -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- -- $Id: XSM.hs,v 1.3 1999/12/05 16:29:04 ian Exp $ module XSM ( XSM(), inXSM, runXSM, readXSM, updateXSM, NullMonad(), runNullMonad, PureSM, runPureSM ) where data XSM st bm rt = XSM (st -> bm (rt,st)) instance Monad bm => Monad (XSM st bm) where XSM c1 >>= fc2 = XSM (\s0 -> do -- in the bm monad (rv1,s1) <- (c1 s0) let XSM c2 = (fc2 rv1) in (c2 s1) ) return rv = XSM (\s0 -> return (rv, s0)) inXSM :: Monad bm => bm rv -> XSM st bm rv inXSM ba = XSM (\s0 -> do rv <- ba return (rv,s0)) runXSM :: Monad bm => st -> XSM st bm rt -> bm rt runXSM s0 (XSM acts) = do (rv,st) <- acts s0 return rv readXSM :: Monad bm => XSM st bm st readXSM = XSM (\s0 -> return (s0, s0)) updateXSM :: Monad bm => (st -> st) -> XSM st bm () updateXSM tf = XSM (\s0 -> return ((), tf s0)) data NullMonad rt = NullMonad rt instance Monad NullMonad where return rv = NullMonad rv NullMonad v1 >>= fc2 = fc2 v1 runNullMonad :: NullMonad rt -> rt runNullMonad (NullMonad rv) = rv type PureSM st rt = XSM st NullMonad rt runPureSM :: st -> PureSM st rt -> (rt,st) runPureSM s0 (XSM stf) = runNullMonad (stf s0)