Hello People,
Here is another interface-parse file error. I don't know if it is fixed due to my
other bug report or not. Running Solaris ghc-2.02.
Compile Dt.hs with: ghc-2.02 -fglasgow-exts -prof -auto -c -O Dt.hs
Compile Main.lhs with: ghc-2.02 -fglasgow-exts -prof -auto -c -O Main.lhs
If I take the -O out when compiling Dt.hs then it works fine.
Here is the error message (that you get when compiling Main.lhs):
panic! (the `impossible' happened): Interface-file parse error: line 1 toks=
[ITvarid "updateR", ITstring " (let { si9Y :: Dt.State = case si9t of {
PrelTup.(,,,,,,) si9X sia4 sia3 sia2 sia1 sia0 si9Z -> PrelTup.(,,,,,,) {_@_
Dt.CP _@_ Dt.Code _@_ Dt.DS _@_ Dt.Iffer _@_ Dt.Stack _@_ PrelBase.Bool _@_ Dt.Heap
sia5 sia4 sia3 sia2 sia1 sia0 si9Z};} } in PrelTup.(,) {_@_ Dt.State _@_ Dt.State
si9Y si9t}) } in _scc_ ", ITvarid "updateR", ITstring " (Dt.R _@_ Dt.State sia6)) }
in _scc_ ", ITvarid "setCP", ITstring " (Dt.d2EW _@_ Dt.State _@_ PrelBase.() siab
Dt.s7No) \NUL;\n10 setDS _:_ Dt.DS -> Dt.R PrelBase.() ;; _A_ 1 _U_ \\ sid3 :: Dt.DS
-> let { sid9 :: (Dt.R Dt.State) = _scc_ ", ITvarid "setDS", ITstring " (let { sid4 ::
(Dt.State -> (Dt.State, Dt.State)) = \\ sicr :: Dt.State -> _scc_ ", ITvarid
"updateR", ITstring " (let { sicW :: Dt.State = case sicr of { PrelTup.(,,,,,,) sicV
sid2 sid1 sid0 sicZ sicY sicX -> PrelTup.(,,,,,,) {_@_ Dt.CP _@_ Dt.Code _!
!
@_ Dt.DS _@_ Dt.Iffer _@_ Dt.Sta
ck _@_ PrelBase.Bool _@_ Dt.Heap si
cV sid2 sid3 sid0 sicZ sicY sicX};} } in PrelTup.(,) {_@_ Dt.State _@_ Dt.State sicW
sicr}) } in _scc_ "]
The Dt.hs and Main.lhs files follow at the SNIP's.
Thanks,
Jon
PS. While I am at it, please look at popST and tell me why the good is
good and the bad is bad :-) I am not sure whether this is still the case
with ghc-2.02 but it was with ghc-2.00
SNIP----------------------------------------------------------------------
--%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-- Dt.hs
--
-- Simple Abstract Machine instructions and state manipulation routines
--
-- Jon Mountjoy
--%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
module Dt (CP(..),DS,Code,Iffer,Heap(..), Cexpr (..),
incCP, getDS, getCP, setDS, setCP, pushST,
popST,setHeap, getHeap, getIFF, setStop, getR, getCurrentInstructionBlock,
setIFF, mustStop, setR, unR, R, Stack(..),State,
StackElem(..),updateR,setST,getST
) where
import Array
data StackElem = SE !Int deriving Show
data Stack = AST [StackElem] deriving Show
data CP = CP Int deriving Show
type DS = [Int]
type Code = Array Int Cexpr
type Iffer = Int
data Heap = H !(Array Int Int) deriving Show
-- A simple Stack like machine
data Cexpr = Push Int
| Add
| Sub -- Sub top of stack from second top of stack
| Call Int
| Ret
| Equal
| JumpNT Int
| Jump Int
| Assign
| Get
| Swap
| Exit
| Store -- store tos at location second top of stack
| Load -- load from address at tos
deriving Show
-- The state of the abstract machine
type State = (CP, Code, DS, Iffer, Stack, Bool,Heap)
----------------------------------------------------------------------
-- Monadic definitions:
----------------------------------------------------------------------
newtype R a = R (State -> (State,a) )
unR (R a ) = a
instance Functor R where
map f (R a) = R (\s -> case a s of
(s',v) -> (s',f v))
instance Monad R where
return x = R (\s -> (s,x))
(R a ) >>= f = R (\s -> case a s of
(s',v) -> unR (f v) s' )
instance MonadZero R where
zero = error "Should never be here! Zero!\n"
updateR :: (State -> State) -> R State
updateR f = R (\s -> (f s,s))
----------------------------------------------------------------------
-- State Manipulation Routines
----------------------------------------------------------------------
-- Rather boring....
getR :: R State
getR = do
a <- (updateR id)
return a
setR :: State -> R State
setR a = do
a <- updateR (\_ -> a)
return a
mustStop :: R Bool
mustStop = do
(c,cd,ds,iff,st,b,h) <- getR
return b
setStop :: R ()
setStop = do
updateR (\(c,cd,ds,iff,st,_,h) -> (c,cd,ds,iff,st,True,h))
return ()
setHeap :: Heap -> R ()
setHeap h' = do
updateR (\(c,cd,ds,iff,st,b,h) -> (c,cd,ds,iff,st,b,h'))
return ()
getCP :: R CP
getCP = do
(c,cd,ds,iff,st,b,h) <- getR
return c
getDS :: R DS
getDS = do
(c,cd,ds,iff,st,b,h) <- getR
return ds
getIFF :: R Int
getIFF = do
(c,cd,ds,iff,st,b,h) <- getR
return iff
getST :: R Stack
getST = do
(c,cd,ds,iff,st,b,h) <- getR
return st
getCode :: R Code
getCode = do
(c,cd,ds,iff,st,b,h) <- getR
return cd
getHeap :: R Heap
getHeap = do
(c,cd,ds,iff,st,b,h) <- getR
return h
getCurrentInstructionBlock
= do
(CP cp) <- getCP
code <- getCode
if inRange (bounds code) cp
then return (code!cp)
else error "*getCurrentInstructionBlock*"
setCP :: CP -> R ()
setCP c'= do updateR (\(c,cd,ds,iff,st,b,h)->(c',cd,ds,iff,st,b,h))
return ()
setIFF :: Int -> R ()
setIFF c'= do updateR (\(c,cd,ds,iff,st,b,h)->(c,cd,ds,c',st,b,h))
return ()
setDS :: DS -> R ()
setDS c'= do updateR (\(c,cd,ds,iff,st,b,h)->(c,cd,c',iff,st,b,h))
return ()
setST :: Stack -> R ()
setST c'= do updateR (\(c,cd,ds,iff,st,b,h)->(c,cd,ds,iff,c',b,h))
return ()
pushST :: Int -> R ()
pushST i=do
(AST s) <- getST
setST (AST ((SE i):s))
return ()
incCP :: R()
incCP = getCP >>= \(CP cp) ->
setCP (CP (cp+1))
----------------------------------------------------------------------
-- this is interesting
-- I get a very very bad space behaviour with the Bad code, and much better
-- with the good code. Any explanations? I guess the let version isn't as
-- strict but why does it hold on?
popST :: R Int
popST = do
{- Good -}
(AST (SE a:t)) <- getST
setST (AST t)
return a
{- Bad
(AST h) <- getST
let (SE a) = head h
setST (AST (tail h))
return (a)
-}
----------------------------------------------------------------------
-- End of Dt.hs
----------------------------------------------------------------------
SNIP----------------------------------------------------------------------
%P-------
-- Main.lhs
-- Interpreter
-- Jon Mountjoy
--%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
> module Main where
>
> import Dt
> import System
> import Array
define _scc_ (\x y-> y)
>
> main :: IO ()
> main = getArgs >>= \[x] ->
> putStr $ show (case (rloop (read x)) of
> (a,x,y) -> (x,y))
>
> --We interpret the rloop program, found below
>
> ----------------------------------------------------------------------
> -- runlin runs a piece of code in an initial environment
> -- returning a few components of the state
>
> runlin cod = let code = cod
> in
> case (unR boogieOn)
> (CP 0,code,[], 0,AST [], False, H(
> strict (array (1,5)) (zip [1..5] [1..5])) ) of
> ((c,cd,ds,iff,st,b,h),_) -> (st, c,ds)
>
> --boogieOn is the interpreter self
> --If we must stop, then do so returning the current state. If not,
> -- then get the next instruction, execute it, and repeat.
>
> boogieOn :: R State
> boogieOn = (
> mustStop >>= \ms ->
> if ms
> then getR
> else getCurrentInstructionBlock >>= \ci ->
> execBlock ci >>
> boogieOn)
>
> --here we dispatch
>
> execBlock :: Cexpr -> R ()
> execBlock e= case e of
> Ret -> _scc_ "RET" e_ret
> Get -> _scc_ "GET" e_get
> Swap -> _scc_ "SWAP" e_swap
> Push i -> _scc_ "PUSH" (e_push i)
> Store -> _scc_ "STORE" e_store
> Add -> _scc_ "ADD" e_add
> Sub -> _scc_ "SUB" e_sub
> Call i -> _scc_ "CALL" (e_call i)
> Equal -> _scc_ "EQUAL" e_equal
> JumpNT i -> _scc_ "JUMPNT" (e_jumpnt i)
> Jump i -> _scc_ "JUMP" (e_jump i)
> Assign -> _scc_ "ASSIGN" e_assign
> _ -> error "ExecBlock"
>
> ----------------------------------------------------------------------
> -- This is what each instruction does
>
> {-
> e_ret =do
> d <- getDS
> case null d of
> True -> setStop
> False -> do
> setCP (CP (head d))
> setDS (tail d)
> -}
>
> e_ret =do
> d <- getDS
> case d of
> [] -> setStop
> (a:as) -> do
> setCP (CP (head d))
> setDS (tail d)
>
> e_assign
> = do
> f <- popST
> setIFF f
> incCP
>
> e_get
> = do
> f <- getIFF
> pushST f
> incCP
>
> e_swap
> = do
> f <- popST
> f2 <- popST
> pushST f
> pushST f2
> incCP
>
> e_store --store tos at nttos
> = do
> f <- popST
> f2 <- popST
> (H h) <- getHeap
> case strict (h //) [(f2,f)] of
> newh -> setHeap (H newh)
> --setHeap ( h // [(f2,f)])
> --setHeap (h // [(f2,f)])
> incCP
>
> e_jumpnt i
> = do
> f <- popST
> if f == 1
> then incCP
> else setCP (CP i)
>
> e_jump i
> = do
> setCP (CP i)
>
> e_equal
> = do
> top <- popST
> nttop <- popST
> if (top == nttop)
> then do
> pushST 1
> incCP
> else do
> pushST 0
> incCP
>
> e_sub
> = do
> top <- popST
> nttop <- popST
> pushST (nttop-top)
> incCP
>
> e_add
> = do
> top <- popST
> nttop <- popST
> pushST (nttop+top)
> incCP
>
> e_push i
> = do
> pushST i
> incCP
> e_call i
> = do
> s <- getDS
> (CP c) <- getCP
> setDS ((c+1):s)
> setCP (CP i)
>
> ----------------------------------------------------------------------
>
> --rloop loops x times storing 100 at location 101 in the array
>
> rloop x = runlin (listArray (0,14) [Push x, Assign,
> Get , Push 0, Equal, JumpNT 7,
> --Is EQUAL
> Ret,
> --IS Not equal to zero
> Push 1,
> Push 100,
> Store,
> --do something
> Get, Push 1, Sub, Assign, Jump 2])
>
> nfib :: Int -> Code
> nfib x = (listArray (0,28))
> [Push x, Assign ,
> Get, Push 1, Equal, JumpNT 8, Push 1, Ret, -- x == 1
> Get, Push 0, Equal, JumpNT 14, Push 1, Ret, -- x == 2 //8
> Push 1, -- Number 1 //14
> Get,
> Get, Push 1, Sub, Assign, Call 2,
> Swap,Push 2, Sub, Assign, Call 2,
> Add, Add, Ret]
> rnfib x = runlin (nfib x)
>
> ----------------------------------------------------------------------
> --End of Main.hs
> ----------------------------------------------------------------------
