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)
