├── Setup.hs
├── .gitignore
├── Main.hs
├── atoms.txt
├── README.md
├── tests
    ├── simple.erl
    └── Simple.hs
├── pingpong.erl
├── other.erl
├── herl.cabal
├── ex.erl
├── ETerm.hs
├── AtomTable.hs
├── AtomTableErlang.hs
├── EModule.hs
├── ExtTerm.hs
├── mkAtomTable.hs
├── LICENSE
├── Beam.hs
└── Process.hs


/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | .cabal-sandbox
2 | dist
3 | *.beam
4 | erjang-master
5 | cabal.sandbox.config
6 | 


--------------------------------------------------------------------------------
/Main.hs:
--------------------------------------------------------------------------------
 1 | 
 2 | {-# LANGUAGE OverloadedStrings #-}
 3 | module Main where
 4 | 
 5 | import           ETerm
 6 | import           Process
 7 | 
 8 | main :: IO ()
 9 | main = print =<< runBeam ["other.beam"] "other" "fib_slow" [EInteger 21]
10 | 
11 | main2 :: IO ()
12 | main2 = print =<< runBeam ["pingpong.beam"] "pingpong" "foo" []
13 | 


--------------------------------------------------------------------------------
/atoms.txt:
--------------------------------------------------------------------------------
 1 | # List of atoms used in erlang.
 2 | # One or two words, separated with a space.
 3 | # If one word, it's the name of the atom in erlang,
 4 | # and in herl the function will be called am_<word>.
 5 | # If two words, the first is the name in herl, second is the atom in erlang.
 6 | exit
 7 | EXIT
 8 | throw
 9 | error
10 | nocatch
11 | badmatch
12 | case_clause
13 | try_clause
14 | badfun
15 | badarity
16 | undef
17 | erlang
18 | now
19 | get_stacktrace
20 | sign_plus +
21 | sign_minus -
22 | sign_mult *
23 | spawn
24 | io
25 | format


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | herl
 2 | ====
 3 | 
 4 | _Erlang BEAM emulator in Haskell_
 5 | 
 6 | Introduction
 7 | ------------
 8 | 
 9 | This project aims to implement an emulator to run Erlang's BEAM code.
10 | The emulator itself is implemented in Haskell.
11 | I've used various sources to figure out what the different BEAM codes do,
12 | and the current implementation is not complete in any way.
13 | 
14 | BEAM
15 | ----
16 | 
17 | Some links regarding BEAM;
18 | 
19 | - http://synrc.com/publications/cat/Functional%20Languages/Erlang/beam.txt
20 | - [Erlang on Xen](http://erlangonxen.org/more/beam)
21 | - and of course the [official erl emulator](https://github.com/erlang/otp) itself.


--------------------------------------------------------------------------------
/tests/simple.erl:
--------------------------------------------------------------------------------
 1 | -module(simple).
 2 | 
 3 | -export([test1/0, test2/0, test3/0, inc/1, adder5/5, test_string/0, test_if/1, simple_fun/0, fun_in_fun/1, test_fun/0]).
 4 | 
 5 | test1() -> 700.
 6 | 
 7 | adder5(A,B,C,D,E) -> A + B + C + D + E.
 8 | 
 9 | test2() -> adder5(1, 2, 3, 4 ,5).
10 | 
11 | test3() -> tre_mult(3).
12 | 
13 | inc(N) -> N + 1.
14 | 
15 | tre_mult(N) -> inc(N) * inc(N) * inc(N).
16 | 
17 | test_string() -> "hello_world_strings".
18 | 
19 | test_if(N) ->
20 |   if N > 100 -> ok100;
21 |      N > 4 -> ok4;
22 |      N < 2 -> ok2;
23 |      true -> ok_true
24 |   end.
25 | 
26 | simple_fun() ->
27 |   A = fun(Arg) -> Arg + 42 end,
28 |   A(8).
29 | 
30 | fun_in_fun(A) ->
31 |   B = fun(C) -> 5 + C() + A() end,
32 |   3 + B(A).
33 | 
34 | test_fun() ->
35 |   fun_in_fun(fun() -> 42 end).
36 | 


--------------------------------------------------------------------------------
/pingpong.erl:
--------------------------------------------------------------------------------
 1 | -module(pingpong).
 2 | 
 3 | -export([start/0, ping/2, pong/0, foo/0, foo_started/0]).
 4 | 
 5 | ping(0, Pong_PID) ->
 6 |   Pong_PID ! finished,
 7 |   io:format("ping finished~n", []);
 8 | 
 9 | ping(N, Pong_PID) ->
10 |   Pong_PID ! {ping, self()},
11 |   receive
12 |     pong -> io:format("Ping received pong~n", [])
13 |   end,
14 |   ping(N - 1, Pong_PID).
15 | 
16 | pong() ->
17 |   receive
18 |     finished ->
19 |       io:format("Pong finished~n", []);
20 |     {ping, Ping_PID} ->
21 |       io:format("Pong received ping~n", []),
22 |       Ping_PID ! pong,
23 |       pong()
24 |   end.
25 | 
26 | start() ->
27 |   Pong_PID = spawn(pingpong, pong, []),
28 |   spawn(pingpong, ping, [3, Pong_PID]).
29 | 
30 | foo_started() ->
31 |   io:format("foo started~n").
32 | 
33 | foo() ->
34 |   spawn(pingpong, foo_started, []).


--------------------------------------------------------------------------------
/other.erl:
--------------------------------------------------------------------------------
 1 | -module(other).
 2 | 
 3 | -export([remote/0, remote_foo/0, failer/0, failer2/0, fib/1, fac/1, nyling/0, fib_slow/1, tuplish/1, listish/1]).
 4 | 
 5 | -import(simple, [tok/0, fun_with_fun/0]).
 6 | 
 7 | remote() -> 42.
 8 | 
 9 | remote_foo() -> simple:foo(1) * 2.
10 | 
11 | failer() ->
12 |   simple:wazaa_dont_exist().
13 | 
14 | failer2() ->
15 |   A = fun (Arg1, 0) -> Arg1 + 1;
16 |   	      (Arg1, _Arg2) -> Arg1 + 2 end,
17 |   A(1).
18 | 
19 | fib(N) -> fib_helper(N,0,1).
20 | 
21 | fib_helper(Stop, A, _B) when A > Stop -> [];
22 | fib_helper(Stop, A, B) -> [ A | fib_helper(Stop, B, A+B) ].
23 | 
24 | fib_slow(0) -> 1;
25 | fib_slow(1) -> 1;
26 | fib_slow(N) -> fib_slow(N-2) + fib_slow(N-1).
27 | 
28 | fac(0) -> 1;
29 | fac(N) -> N * fac(N-1).
30 | 
31 | nyling() ->
32 |   Pid = erlang:spawn(other, fac, [5]),
33 |   Pid.
34 | 
35 | tuplish(N) -> {N, N*2, N*3}.
36 | 
37 | listish(N) -> [N, N*2, N*3].


--------------------------------------------------------------------------------
/tests/Simple.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings #-}
 2 | module Main where
 3 | 
 4 | import qualified Data.ByteString as B
 5 | import           System.Exit
 6 | 
 7 | import           ETerm
 8 | import           Process
 9 | 
10 | 
11 | main :: IO ()
12 | main = do
13 |   runAssert "test1" [] (EInteger 700)
14 |   runAssert "test2" [] (EInteger 15)
15 |   runAssert "test3" [] (EInteger 64)
16 |   runAssert "inc" [EInteger 1] (EInteger 2)
17 |   runAssert "inc" [EInteger 100] (EInteger 101)
18 |   runAssert "inc" [EInteger 1000] (EInteger 1001)
19 |   runAssert "inc" [EInteger 987654321] (EInteger 987654322)
20 |   runAssert "adder5" (map EInteger [101..105]) (EInteger 515)
21 |   runAssert "test_if" [EInteger 101] (EAtom (AtomNo 31))
22 |   runAssert "test_if" [EInteger 5] (EAtom (AtomNo 30))
23 |   runAssert "test_if" [EInteger 1] (EAtom (AtomNo 29))
24 |   runAssert "test_if" [EInteger 3] (EAtom (AtomNo 28))
25 |   runAssert "simple_fun" [] (EInteger 50)
26 |   runAssert "test_fun" [] (EInteger 92)
27 | 
28 | runAssert :: B.ByteString -> [ETerm] -> ETerm -> IO ()
29 | runAssert fun args expected = do
30 |   putStrLn $ "Function " ++ show fun ++ " with args " ++ show args
31 |   actual <- runBeam ["tests/simple.beam"] "simple" fun args
32 |   if actual == Just expected
33 |     then putStrLn "ok."
34 |     else do
35 |       putStrLn $ "In " ++ show fun ++ ", " ++ show args ++ ": Expected " ++ show expected ++ " but got " ++ show actual
36 |       exitFailure


--------------------------------------------------------------------------------
/herl.cabal:
--------------------------------------------------------------------------------
 1 | -- Initial herl.cabal generated by cabal init.  For further documentation, 
 2 | -- see http://haskell.org/cabal/users-guide/
 3 | 
 4 | name:                herl
 5 | version:             0.1.0.0
 6 | synopsis:            Erlang VM in Haskell
 7 | -- description:         
 8 | license:             Apache-2.0
 9 | license-file:        LICENSE
10 | author:              Lennart Kolmodin
11 | maintainer:          kolmodin@gmail.com
12 | copyright:           Lennart Kolmodin 2013-2014
13 | category:            System
14 | build-type:          Simple
15 | -- extra-source-files:  
16 | cabal-version:       >=1.10
17 | 
18 | library
19 |   exposed-modules:
20 |     AtomTable,
21 |     AtomTableErlang,
22 |     Beam,
23 |     EModule,
24 |     ETerm,
25 |     ExtTerm,
26 |     Process
27 |   other-extensions:    BangPatterns, DeriveDataTypeable, OverloadedStrings, RecordWildCards, RankNTypes
28 |   build-depends:       base ==4.6.*, bytestring ==0.10.*, binary ==0.7.*, zlib ==0.5.*, pretty-show ==1.6.*, uniplate ==1.6.*, mtl, vector==0.10.*
29 |   default-language:    Haskell2010
30 | 
31 | executable mkAtomTable
32 |   main-is: mkAtomTable.hs
33 |   other-extensions:    OverloadedStrings
34 |   build-depends:       base ==4.6.*, bytestring ==0.10.*, haskell-src-exts
35 |   default-language:    Haskell2010
36 | 
37 | test-suite test-simple
38 |   type:       exitcode-stdio-1.0
39 |   main-is:    simple.hs
40 |   hs-source-dirs: tests
41 |   build-depends: base, bytestring, herl
42 |   default-language:    Haskell2010
43 | 


--------------------------------------------------------------------------------
/ex.erl:
--------------------------------------------------------------------------------
 1 | -module(ex).
 2 | 
 3 | -export([th/0, safe/0, ctch_safe/0, ctch_throw/0, ctch_case/1, try_it/1, stacker/0, stackhelper/0, failing_case/1, safely/1, safely_failing_case/0, joker2/1]).
 4 | 
 5 | th() ->
 6 |   throw({detta, fran, throw}).
 7 | 
 8 | safe() -> {'hejsan svejsan', 42}.
 9 | 
10 | ctch_safe() ->
11 |   catch safe().
12 | 
13 | ctch_throw() ->
14 |   catch th().
15 | 
16 | ctch_case(N) ->
17 |   catch case N of
18 |     foo -> ok
19 |   end.
20 | 
21 | stacker() ->
22 |   A = 5,
23 |   B = stacker(A),
24 |   {A,B}.
25 | stacker(N) ->
26 |   St = erlang:get_stacktrace(),
27 |   {"hello", St, N}.
28 | 
29 | stackhelper() -> {stacker(), 5}.
30 | 
31 | joker(N) ->
32 |   if N == 1 -> throw("denna strang kastas");
33 |      N == 2 -> erlang:exit("the exit term");
34 |      N == 3 -> erlang:error('the error term');
35 |      true -> {ok, N}
36 |   end.
37 | 
38 | joker2(N) ->
39 |   if N == 1 -> throw("denna strang kastas");
40 |      N == 2 -> erlang:exit("the exit term");
41 |      N == 3 -> erlang:error('the error term')
42 |   end.
43 | 
44 | try_it(N) ->
45 |   try joker(N) of
46 |     A -> A
47 |   catch
48 |     throw:Term -> {'thrown', 'term', Term};
49 |     exit:Reason -> {'exit', 'reason', Reason};
50 |     error:Reason -> {'error', 'reason', Reason}
51 |   end.
52 | 
53 | safely(F) ->
54 |   try F() of
55 |     R -> R
56 |   catch
57 |     error:Reason -> {"caught error with reason", Reason, erlang:get_stacktrace()}
58 |   end.
59 | 
60 | safely_failing_case() -> safely(fun() -> failing_case(wazaa) end).
61 | 
62 | failing_case(N) ->
63 |   case N of
64 |     ok -> {ok, N};
65 |     neok -> {neok, N}
66 |   end.
67 | 


--------------------------------------------------------------------------------
/ETerm.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE DeriveDataTypeable #-}
 2 | {-# OPTIONS_GHC -funbox-strict-fields #-}
 3 | module ETerm where
 4 | 
 5 | import Data.Int
 6 | import qualified Data.ByteString as B
 7 | import qualified Data.ByteString.Lazy as BL
 8 | 
 9 | import Data.Data
10 | 
11 | 
12 | newtype AtomNo = AtomNo { unAtomNo :: Int32 } deriving (Show, Eq, Data, Typeable)
13 | 
14 | data ETerm
15 |     = EInteger !Integer
16 |     | ETuple [ETerm]
17 |     | EString B.ByteString
18 |     | ENil
19 |     | EList !ETerm !ETerm
20 |     | EBinary BL.ByteString
21 |     | EAtom !AtomNo
22 |     | EFun
23 |         { funIp :: !Int
24 |         , funFree :: [ETerm]
25 |         , funMod :: B.ByteString
26 |         , etfunArity :: !Int32
27 |         , funName :: B.ByteString
28 |         }
29 |     | ENonValue
30 |     deriving (Show, Eq, Data, Typeable)
31 | 
32 | isEtermEq :: ETerm -> ETerm -> Bool
33 | isEtermEq = (==)
34 | 
35 | isList :: ETerm -> Bool
36 | isList (EList _ _) = True
37 | isList ENil = True
38 | isList (EString _) = True
39 | isList _ = False
40 | 
41 | toErlangList :: [ETerm] -> ETerm
42 | toErlangList [] = ENil
43 | toErlangList (x:xs) = EList x (toErlangList xs)
44 | 
45 | fromErlangList :: ETerm -> [ETerm]
46 | fromErlangList (EList hd tl) = hd : fromErlangList tl
47 | fromErlangList ENil = []
48 | fromErlangList (EString bs) = map (EInteger . fromIntegral ) (B.unpack bs)
49 | 
50 | isAtom :: ETerm -> Bool
51 | isAtom (EAtom _) = True
52 | isAtom _ = False
53 | 
54 | isNonValue :: ETerm -> Bool
55 | isNonValue ENonValue = True
56 | isNonValue _ = False
57 | 
58 | isFunction :: ETerm -> Bool
59 | isFunction (EFun {}) = True
60 | isFunction _ = False
61 | 


--------------------------------------------------------------------------------
/AtomTable.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings #-}
 2 | 
 3 | module AtomTable
 4 |   ( AtomTable
 5 |   , empty
 6 |   , fromList
 7 |   , add
 8 |   , merge
 9 |   , listNames
10 |   , lookupByName
11 |   , lookupByCode
12 |   ) where
13 | 
14 | import qualified Data.ByteString as B
15 | import           Data.Int
16 | import           Data.List       as List
17 | 
18 | import           ETerm           (AtomNo (..))
19 | 
20 | data AtomTable = AT !Int32 [(B.ByteString, AtomNo)] deriving Show
21 | 
22 | empty :: AtomTable
23 | empty = AT 0 []
24 | 
25 | fromList :: [B.ByteString] -> AtomTable
26 | fromList lst = merge empty (AT (fromIntegral (length lst)) (zip lst (map AtomNo [0..])))
27 | 
28 | add :: AtomTable -> B.ByteString -> AtomTable
29 | add at@(AT no xs) name =
30 |   case lookupByNameM at name of
31 |     Just _ -> at
32 |     Nothing -> AT (no+1) ((name, AtomNo no):xs)
33 | 
34 | merge :: AtomTable -> AtomTable -> AtomTable
35 | merge at1 at2 = foldl' add at1 (listNames at2)
36 | 
37 | listNames :: AtomTable -> [B.ByteString]
38 | listNames (AT _ xs) = map fst xs
39 | 
40 | lookupByNameM :: AtomTable -> B.ByteString -> Maybe AtomNo
41 | lookupByNameM (AT _ xs) name = List.lookup name xs
42 | 
43 | lookupByName :: AtomTable -> B.ByteString -> AtomNo
44 | lookupByName at name =
45 |   case lookupByNameM at name of
46 |     Just no -> no
47 |     Nothing -> error $ "AT.lookupByName: atom not found: " ++ show name
48 | 
49 | lookupByCodeM :: AtomTable -> AtomNo -> Maybe B.ByteString
50 | lookupByCodeM (AT _ xs) code = List.lookup code (map (\(x,y) -> (y,x)) xs)
51 | 
52 | lookupByCode :: AtomTable -> AtomNo -> B.ByteString
53 | lookupByCode at no =
54 |   case lookupByCodeM at no of
55 |     Just bs -> bs
56 |     Nothing -> error $ "AT.lookupByCode: atom not found: " ++ show no
57 | 


--------------------------------------------------------------------------------
/AtomTableErlang.hs:
--------------------------------------------------------------------------------
 1 | -- Generated by mkAtomName.hs, don't edit.
 2 | 
 3 | {-# LANGUAGE OverloadedStrings #-}
 4 | module AtomTableErlang
 5 |        (basic, am_exit, am_EXIT, am_throw, am_error, am_nocatch,
 6 |         am_badmatch, am_case_clause, am_try_clause, am_badfun, am_badarity,
 7 |         am_undef, am_erlang, am_now, am_get_stacktrace, am_sign_plus,
 8 |         am_sign_minus, am_sign_mult, am_spawn, am_io, am_format)
 9 |        where
10 | import AtomTable
11 | import ETerm (AtomNo(..))
12 |  
13 | basic :: AtomTable
14 | basic
15 |   = fromList
16 |       ["exit", "EXIT", "throw", "error", "nocatch", "badmatch",
17 |        "case_clause", "try_clause", "badfun", "badarity", "undef",
18 |        "erlang", "now", "get_stacktrace", "+", "-", "*", "spawn", "io",
19 |        "format"]
20 |  
21 | am_exit :: AtomNo
22 | am_exit = AtomNo 0
23 |  
24 | am_EXIT :: AtomNo
25 | am_EXIT = AtomNo 1
26 |  
27 | am_throw :: AtomNo
28 | am_throw = AtomNo 2
29 |  
30 | am_error :: AtomNo
31 | am_error = AtomNo 3
32 |  
33 | am_nocatch :: AtomNo
34 | am_nocatch = AtomNo 4
35 |  
36 | am_badmatch :: AtomNo
37 | am_badmatch = AtomNo 5
38 |  
39 | am_case_clause :: AtomNo
40 | am_case_clause = AtomNo 6
41 |  
42 | am_try_clause :: AtomNo
43 | am_try_clause = AtomNo 7
44 |  
45 | am_badfun :: AtomNo
46 | am_badfun = AtomNo 8
47 |  
48 | am_badarity :: AtomNo
49 | am_badarity = AtomNo 9
50 |  
51 | am_undef :: AtomNo
52 | am_undef = AtomNo 10
53 |  
54 | am_erlang :: AtomNo
55 | am_erlang = AtomNo 11
56 |  
57 | am_now :: AtomNo
58 | am_now = AtomNo 12
59 |  
60 | am_get_stacktrace :: AtomNo
61 | am_get_stacktrace = AtomNo 13
62 |  
63 | am_sign_plus :: AtomNo
64 | am_sign_plus = AtomNo 14
65 |  
66 | am_sign_minus :: AtomNo
67 | am_sign_minus = AtomNo 15
68 |  
69 | am_sign_mult :: AtomNo
70 | am_sign_mult = AtomNo 16
71 |  
72 | am_spawn :: AtomNo
73 | am_spawn = AtomNo 17
74 |  
75 | am_io :: AtomNo
76 | am_io = AtomNo 18
77 |  
78 | am_format :: AtomNo
79 | am_format = AtomNo 19
80 | 


--------------------------------------------------------------------------------
/EModule.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE BangPatterns      #-}
 2 | {-# LANGUAGE OverloadedStrings #-}
 3 | {-# LANGUAGE RankNTypes        #-}
 4 | {-# LANGUAGE RecordWildCards   #-}
 5 | module EModule where
 6 | 
 7 | -- hp
 8 | import qualified Data.ByteString             as B
 9 | import           Data.Int
10 | 
11 | -- 3rd party
12 | import           Data.Generics.Uniplate.Data
13 | import           Data.Vector                 (Vector)
14 | import qualified Data.Vector                 as V
15 | 
16 | -- this project
17 | import           AtomTable                   (AtomTable)
18 | import qualified AtomTable                   as AT
19 | import           Beam
20 | import           ETerm
21 | 
22 | data EModule =
23 |   EModule
24 |     { emodName         :: B.ByteString
25 |     , emodModNameAtom  :: AtomNo
26 |     , emodCode         :: Code
27 |     , emodImports      :: Vector (AtomNo {- mod -}, AtomNo {- fun -}, Arity)
28 |     , emodExports      :: [(AtomNo {- fun -}, Arity, Int32 {- label -})]
29 |     , emodLabelToIp    :: [(Int32, Int)]
30 |     , emodLiteralTable :: [Literal]
31 |     , emodFunctions    :: [Lambda]
32 |     } deriving (Show)
33 | 
34 | newtype Code = Code { unCode :: Vector Op }
35 | 
36 | instance Show Code where
37 |   show (Code v) = show (V.toList v)
38 |   showsPrec i (Code v) = showsPrec i (V.toList v)
39 |   showList vs = showList (map unCode vs)
40 | 
41 | opAtIp :: Code -> Int -> Op
42 | opAtIp (Code v) ix = v V.! ix
43 | 
44 | makeCode :: [Op] -> Code
45 | makeCode ops = Code (V.fromList ops)
46 | 
47 | beamToModule :: Beam -> AtomTable -> (EModule, AtomTable, Beam)
48 | beamToModule bm0@(Beam _ new_atom_names0 _ _ _ _ _ _) at = (emod, at', bm')
49 |   where
50 |     bm'@(Beam modName _ ops _ imps exps lambdas literal) = transformBi updateAtoms bm0
51 |     new_atom_names = [ name | AtomName name <- new_atom_names0 ]
52 |     at' = AT.merge at (AT.fromList new_atom_names)
53 |     emod = EModule
54 |       { emodName = modName
55 |       , emodModNameAtom = AT.lookupByName at' modName
56 |       , emodCode = makeCode ops
57 |       , emodImports = V.fromList [ (emod, fun, arity) | Import emod fun arity <- imps ]
58 |       , emodExports = [ (fun, arity, label) | Export fun arity label <- exps ]
59 |       , emodLabelToIp = [ (label, ip) | (Label label, ip) <- zip ops [0..] ]
60 |       , emodLiteralTable = literal
61 |       , emodFunctions = lambdas
62 |       }
63 |     updateAtoms (AtomNo nr) = AT.lookupByName at' (new_atom_names !! (fromIntegral nr - 1))
64 | 


--------------------------------------------------------------------------------
/ExtTerm.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE DeriveDataTypeable #-}
 2 | {-# OPTIONS_GHC -funbox-strict-fields #-}
 3 | module ExtTerm where
 4 | 
 5 | import Data.Int
 6 | import qualified Data.ByteString as B
 7 | import qualified Data.ByteString.Lazy as BL
 8 | 
 9 | import Data.Binary.Get
10 | import Data.Binary
11 | 
12 | import Control.Monad
13 | import Control.Applicative
14 | 
15 | import Data.Data
16 | 
17 | import ETerm
18 | 
19 | data ExtTerm
20 |     = ExtSmallInt !Int8
21 |     | ExtInt !Int32
22 |     | ExtTuple [ExtTerm]
23 |     | ExtString B.ByteString
24 |     | ExtNil
25 |     | ExtList [ExtTerm] ExtTerm
26 |     | ExtBinary BL.ByteString
27 |     | ExtAtom B.ByteString
28 |     deriving (Show, Eq, Data, Typeable)
29 | 
30 | isExtTermEq :: ExtTerm -> ExtTerm -> Bool
31 | isExtTermEq = (==)
32 | 
33 | extTermToETerm :: ExtTerm -> ETerm
34 | extTermToETerm e =
35 |   case e of
36 |     ExtSmallInt i -> EInteger (fromIntegral i)
37 |     ExtInt i -> EInteger (fromIntegral i)
38 |     ExtTuple t -> ETuple (map extTermToETerm t)
39 |     ExtString s -> EString s
40 |     ExtNil -> ENil
41 |     ExtList lst tl -> foldr (\hd tl' -> EList (extTermToETerm hd) tl') (extTermToETerm tl) lst
42 |     ExtBinary bin -> EBinary bin
43 |     ExtAtom _ -> error "extTermToETerm: need to be in the PM monad to translate atoms" --  EAtom a
44 | 
45 | decodeExtTerm :: Bool -> BL.ByteString -> ExtTerm
46 | decodeExtTerm versionNumber input =
47 |   runGet getTerm input
48 |   where
49 |     getTerm = do
50 |       vers
51 |       dec
52 |     vers = do
53 |       when versionNumber $ do
54 |         131 <- getWord8
55 |         return ()
56 |     dec = do
57 |       tag <- getWord8
58 |       case tag of
59 |         97 -> ExtSmallInt <$> get
60 |         98 -> ExtInt <$> get
61 |         100 -> ExtAtom <$> do
62 |           len <- getWord16be
63 |           getByteString (fromIntegral len)
64 |         104 -> ExtTuple <$> (do
65 |           noOfElements <- getWord8
66 |           replicateM (fromIntegral noOfElements) dec)
67 |         105 -> ExtTuple <$> (do
68 |           noOfElements <- getWord32be
69 |           replicateM (fromIntegral noOfElements) dec)
70 |         106 -> return ExtNil
71 |         107 -> ExtString <$> (do
72 |           noOfElements <- getWord16be
73 |           getByteString (fromIntegral noOfElements))
74 |         108 -> do
75 |           noOfElements <- getWord32be
76 |           hd <- replicateM (fromIntegral noOfElements) dec
77 |           tl <- dec
78 |           return $ ExtList hd tl
79 |         109 -> ExtBinary <$> (do
80 |           noOfElements <- getWord32be
81 |           getLazyByteString (fromIntegral noOfElements))
82 |         _ -> error ("decodeExtTerm: unknown tag; " ++ show tag)


--------------------------------------------------------------------------------
/mkAtomTable.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE OverloadedStrings #-}
  2 | module Main where
  3 | 
  4 | import           Control.Applicative
  5 | import           Data.List             as List
  6 | import           Data.Maybe            as Maybe
  7 | 
  8 | import           Language.Haskell.Exts hiding (name, sym)
  9 | 
 10 | 
 11 | main :: IO ()
 12 | main = writeBasic
 13 | 
 14 | writeBasic :: IO ()
 15 | writeBasic = writeToFile "AtomTableErlang.hs" =<< readTable "atoms.txt"
 16 | 
 17 | data AtomName = AN
 18 |   { atName :: String -- name without am_ prefix
 19 |   , atSymbol   :: String -- symbol
 20 |   } deriving (Show, Eq)
 21 | 
 22 | readTable :: String -> IO [AtomName]
 23 | readTable fileName = Maybe.catMaybes . map mkAtomName . lines <$> readFile fileName
 24 | 
 25 | mkAtomName :: String -> Maybe AtomName
 26 | mkAtomName "" = Nothing
 27 | mkAtomName ('#':_) = Nothing
 28 | mkAtomName line =
 29 |   case break (==' ') line of
 30 |     (name, ' ':sym) -> Just (AN name sym)
 31 |     (name, "") -> Just (AN name name)
 32 | 
 33 | writeToFile :: String -> [AtomName] -> IO ()
 34 | writeToFile fileName names = do
 35 |   writeFile fileName $
 36 |     unlines [ "-- Generated by mkAtomName.hs, don't edit.","",
 37 |               (prettyPrint (modu names))]
 38 | 
 39 | modu :: [AtomName] -> Module
 40 | modu names0 =
 41 |   Module
 42 |     srcloc
 43 |     (ModuleName "AtomTableErlang")
 44 |     [ LanguagePragma srcloc [ Ident "OverloadedStrings" ] ]
 45 |     Nothing
 46 |     (exportSpec am_names)
 47 |     impDecl
 48 |     (mkBasic symbols ++ am_functions am_names)
 49 |   where
 50 |     names = List.nub names0
 51 |     am_names = map (("am_" ++) . atName) names
 52 |     symbols = map atSymbol names
 53 | 
 54 | exportSpec :: [String] -> Maybe [ExportSpec]
 55 | exportSpec names = Just (EVar (UnQual (Ident "basic")) : map (EVar . UnQual . Ident) names)
 56 | 
 57 | impDecl :: [ImportDecl]
 58 | impDecl =
 59 |   [ ImportDecl
 60 |      { importLoc = srcloc
 61 |      , importModule = ModuleName "AtomTable"
 62 |      , importQualified = False
 63 |      , importSrc = False
 64 |      , importPkg = Nothing
 65 |      , importAs = Nothing
 66 |      , importSpecs = Nothing
 67 |      }
 68 |   , ImportDecl
 69 |      { importLoc = srcloc
 70 |      , importModule = ModuleName "ETerm"
 71 |      , importQualified = False
 72 |      , importSrc = False
 73 |      , importPkg = Nothing
 74 |      , importAs = Nothing
 75 |      , importSpecs = Just ( False , [ IThingAll (Ident "AtomNo") ] )
 76 |      }
 77 |   ]
 78 | 
 79 | am_functions :: [String] -> [Decl]
 80 | am_functions names = concatMap (\(name, ix) -> am_function name ix) (zip names [0..])
 81 | 
 82 | am_function :: String -> Integer -> [Decl]
 83 | am_function name atomNo =
 84 |   [ TypeSig
 85 |       srcloc
 86 |       [ Ident name ]
 87 |       (TyCon (UnQual (Ident "AtomNo")))
 88 |   , PatBind
 89 |       srcloc
 90 |       (PVar (Ident name))
 91 |       Nothing
 92 |       (UnGuardedRhs (App (Con (UnQual (Ident "AtomNo"))) (Lit (Int atomNo))))
 93 |       (BDecls [])]
 94 | 
 95 | mkBasic :: [String] -> [Decl]
 96 | mkBasic names =
 97 |   [ TypeSig
 98 |       srcloc
 99 |       [ Ident "basic" ]
100 |       (TyCon (UnQual (Ident "AtomTable")))
101 |   , PatBind
102 |       srcloc
103 |       (PVar (Ident "basic"))
104 |       Nothing
105 |       (UnGuardedRhs
106 |          (App
107 |             (Var (UnQual (Ident "fromList")))
108 |             (List lst)))
109 |       (BDecls [])]
110 |  where
111 |   lst = map (Lit . String) names
112 | 
113 | srcloc :: SrcLoc
114 | srcloc = SrcLoc "" 0 0
115 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
  1 | 
  2 |                                  Apache License
  3 |                            Version 2.0, January 2004
  4 |                         http://www.apache.org/licenses/
  5 | 
  6 |    TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
  7 | 
  8 |    1. Definitions.
  9 | 
 10 |       "License" shall mean the terms and conditions for use, reproduction,
 11 |       and distribution as defined by Sections 1 through 9 of this document.
 12 | 
 13 |       "Licensor" shall mean the copyright owner or entity authorized by
 14 |       the copyright owner that is granting the License.
 15 | 
 16 |       "Legal Entity" shall mean the union of the acting entity and all
 17 |       other entities that control, are controlled by, or are under common
 18 |       control with that entity. For the purposes of this definition,
 19 |       "control" means (i) the power, direct or indirect, to cause the
 20 |       direction or management of such entity, whether by contract or
 21 |       otherwise, or (ii) ownership of fifty percent (50%) or more of the
 22 |       outstanding shares, or (iii) beneficial ownership of such entity.
 23 | 
 24 |       "You" (or "Your") shall mean an individual or Legal Entity
 25 |       exercising permissions granted by this License.
 26 | 
 27 |       "Source" form shall mean the preferred form for making modifications,
 28 |       including but not limited to software source code, documentation
 29 |       source, and configuration files.
 30 | 
 31 |       "Object" form shall mean any form resulting from mechanical
 32 |       transformation or translation of a Source form, including but
 33 |       not limited to compiled object code, generated documentation,
 34 |       and conversions to other media types.
 35 | 
 36 |       "Work" shall mean the work of authorship, whether in Source or
 37 |       Object form, made available under the License, as indicated by a
 38 |       copyright notice that is included in or attached to the work
 39 |       (an example is provided in the Appendix below).
 40 | 
 41 |       "Derivative Works" shall mean any work, whether in Source or Object
 42 |       form, that is based on (or derived from) the Work and for which the
 43 |       editorial revisions, annotations, elaborations, or other modifications
 44 |       represent, as a whole, an original work of authorship. For the purposes
 45 |       of this License, Derivative Works shall not include works that remain
 46 |       separable from, or merely link (or bind by name) to the interfaces of,
 47 |       the Work and Derivative Works thereof.
 48 | 
 49 |       "Contribution" shall mean any work of authorship, including
 50 |       the original version of the Work and any modifications or additions
 51 |       to that Work or Derivative Works thereof, that is intentionally
 52 |       submitted to Licensor for inclusion in the Work by the copyright owner
 53 |       or by an individual or Legal Entity authorized to submit on behalf of
 54 |       the copyright owner. For the purposes of this definition, "submitted"
 55 |       means any form of electronic, verbal, or written communication sent
 56 |       to the Licensor or its representatives, including but not limited to
 57 |       communication on electronic mailing lists, source code control systems,
 58 |       and issue tracking systems that are managed by, or on behalf of, the
 59 |       Licensor for the purpose of discussing and improving the Work, but
 60 |       excluding communication that is conspicuously marked or otherwise
 61 |       designated in writing by the copyright owner as "Not a Contribution."
 62 | 
 63 |       "Contributor" shall mean Licensor and any individual or Legal Entity
 64 |       on behalf of whom a Contribution has been received by Licensor and
 65 |       subsequently incorporated within the Work.
 66 | 
 67 |    2. Grant of Copyright License. Subject to the terms and conditions of
 68 |       this License, each Contributor hereby grants to You a perpetual,
 69 |       worldwide, non-exclusive, no-charge, royalty-free, irrevocable
 70 |       copyright license to reproduce, prepare Derivative Works of,
 71 |       publicly display, publicly perform, sublicense, and distribute the
 72 |       Work and such Derivative Works in Source or Object form.
 73 | 
 74 |    3. Grant of Patent License. Subject to the terms and conditions of
 75 |       this License, each Contributor hereby grants to You a perpetual,
 76 |       worldwide, non-exclusive, no-charge, royalty-free, irrevocable
 77 |       (except as stated in this section) patent license to make, have made,
 78 |       use, offer to sell, sell, import, and otherwise transfer the Work,
 79 |       where such license applies only to those patent claims licensable
 80 |       by such Contributor that are necessarily infringed by their
 81 |       Contribution(s) alone or by combination of their Contribution(s)
 82 |       with the Work to which such Contribution(s) was submitted. If You
 83 |       institute patent litigation against any entity (including a
 84 |       cross-claim or counterclaim in a lawsuit) alleging that the Work
 85 |       or a Contribution incorporated within the Work constitutes direct
 86 |       or contributory patent infringement, then any patent licenses
 87 |       granted to You under this License for that Work shall terminate
 88 |       as of the date such litigation is filed.
 89 | 
 90 |    4. Redistribution. You may reproduce and distribute copies of the
 91 |       Work or Derivative Works thereof in any medium, with or without
 92 |       modifications, and in Source or Object form, provided that You
 93 |       meet the following conditions:
 94 | 
 95 |       (a) You must give any other recipients of the Work or
 96 |           Derivative Works a copy of this License; and
 97 | 
 98 |       (b) You must cause any modified files to carry prominent notices
 99 |           stating that You changed the files; and
100 | 
101 |       (c) You must retain, in the Source form of any Derivative Works
102 |           that You distribute, all copyright, patent, trademark, and
103 |           attribution notices from the Source form of the Work,
104 |           excluding those notices that do not pertain to any part of
105 |           the Derivative Works; and
106 | 
107 |       (d) If the Work includes a "NOTICE" text file as part of its
108 |           distribution, then any Derivative Works that You distribute must
109 |           include a readable copy of the attribution notices contained
110 |           within such NOTICE file, excluding those notices that do not
111 |           pertain to any part of the Derivative Works, in at least one
112 |           of the following places: within a NOTICE text file distributed
113 |           as part of the Derivative Works; within the Source form or
114 |           documentation, if provided along with the Derivative Works; or,
115 |           within a display generated by the Derivative Works, if and
116 |           wherever such third-party notices normally appear. The contents
117 |           of the NOTICE file are for informational purposes only and
118 |           do not modify the License. You may add Your own attribution
119 |           notices within Derivative Works that You distribute, alongside
120 |           or as an addendum to the NOTICE text from the Work, provided
121 |           that such additional attribution notices cannot be construed
122 |           as modifying the License.
123 | 
124 |       You may add Your own copyright statement to Your modifications and
125 |       may provide additional or different license terms and conditions
126 |       for use, reproduction, or distribution of Your modifications, or
127 |       for any such Derivative Works as a whole, provided Your use,
128 |       reproduction, and distribution of the Work otherwise complies with
129 |       the conditions stated in this License.
130 | 
131 |    5. Submission of Contributions. Unless You explicitly state otherwise,
132 |       any Contribution intentionally submitted for inclusion in the Work
133 |       by You to the Licensor shall be under the terms and conditions of
134 |       this License, without any additional terms or conditions.
135 |       Notwithstanding the above, nothing herein shall supersede or modify
136 |       the terms of any separate license agreement you may have executed
137 |       with Licensor regarding such Contributions.
138 | 
139 |    6. Trademarks. This License does not grant permission to use the trade
140 |       names, trademarks, service marks, or product names of the Licensor,
141 |       except as required for reasonable and customary use in describing the
142 |       origin of the Work and reproducing the content of the NOTICE file.
143 | 
144 |    7. Disclaimer of Warranty. Unless required by applicable law or
145 |       agreed to in writing, Licensor provides the Work (and each
146 |       Contributor provides its Contributions) on an "AS IS" BASIS,
147 |       WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
148 |       implied, including, without limitation, any warranties or conditions
149 |       of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
150 |       PARTICULAR PURPOSE. You are solely responsible for determining the
151 |       appropriateness of using or redistributing the Work and assume any
152 |       risks associated with Your exercise of permissions under this License.
153 | 
154 |    8. Limitation of Liability. In no event and under no legal theory,
155 |       whether in tort (including negligence), contract, or otherwise,
156 |       unless required by applicable law (such as deliberate and grossly
157 |       negligent acts) or agreed to in writing, shall any Contributor be
158 |       liable to You for damages, including any direct, indirect, special,
159 |       incidental, or consequential damages of any character arising as a
160 |       result of this License or out of the use or inability to use the
161 |       Work (including but not limited to damages for loss of goodwill,
162 |       work stoppage, computer failure or malfunction, or any and all
163 |       other commercial damages or losses), even if such Contributor
164 |       has been advised of the possibility of such damages.
165 | 
166 |    9. Accepting Warranty or Additional Liability. While redistributing
167 |       the Work or Derivative Works thereof, You may choose to offer,
168 |       and charge a fee for, acceptance of support, warranty, indemnity,
169 |       or other liability obligations and/or rights consistent with this
170 |       License. However, in accepting such obligations, You may act only
171 |       on Your own behalf and on Your sole responsibility, not on behalf
172 |       of any other Contributor, and only if You agree to indemnify,
173 |       defend, and hold each Contributor harmless for any liability
174 |       incurred by, or claims asserted against, such Contributor by reason
175 |       of your accepting any such warranty or additional liability.
176 | 
177 |    END OF TERMS AND CONDITIONS
178 | 
179 |    APPENDIX: How to apply the Apache License to your work.
180 | 
181 |       To apply the Apache License to your work, attach the following
182 |       boilerplate notice, with the fields enclosed by brackets "[]"
183 |       replaced with your own identifying information. (Don't include
184 |       the brackets!)  The text should be enclosed in the appropriate
185 |       comment syntax for the file format. We also recommend that a
186 |       file or class name and description of purpose be included on the
187 |       same "printed page" as the copyright notice for easier
188 |       identification within third-party archives.
189 | 
190 |    Copyright 2013 Lennart Kolmodin
191 | 
192 |    Licensed under the Apache License, Version 2.0 (the "License");
193 |    you may not use this file except in compliance with the License.
194 |    You may obtain a copy of the License at
195 | 
196 |        http://www.apache.org/licenses/LICENSE-2.0
197 | 
198 |    Unless required by applicable law or agreed to in writing, software
199 |    distributed under the License is distributed on an "AS IS" BASIS,
200 |    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
201 |    See the License for the specific language governing permissions and
202 |    limitations under the License.
203 | 


--------------------------------------------------------------------------------
/Beam.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE BangPatterns       #-}
  2 | {-# LANGUAGE DeriveDataTypeable #-}
  3 | {-# LANGUAGE OverloadedStrings  #-}
  4 | {-# OPTIONS_GHC -funbox-strict-fields #-}
  5 | 
  6 | module Beam
  7 |   ( Beam(..)
  8 |   , ModuleName
  9 |   , Strings
 10 |   , AtomName(..)
 11 |   , Arity(..)
 12 |   , OperandLabl(..)
 13 |   , AllocList(..)
 14 |   , Import(..)
 15 |   , Export(..)
 16 |   , Lambda(..)
 17 |   , Literal(..)
 18 |   , Destination(..)
 19 |   , Source(..)
 20 |   , SelectList(..)
 21 |   , YReg(..)
 22 |   , Operand(..)
 23 |   , Op(..)
 24 |   , readBeamFile
 25 |   , getBeam
 26 |   , operandToETerm
 27 |   ) where
 28 | 
 29 | -- hp
 30 | import           Control.Applicative
 31 | import           Control.Monad
 32 | import           Data.Binary            (get)
 33 | import           Data.Binary.Get
 34 | import           Data.Bits
 35 | import qualified Data.ByteString        as B
 36 | import qualified Data.ByteString.Lazy   as BL
 37 | import           Data.Data
 38 | import           Data.Int
 39 | import           Data.Word
 40 | import           Debug.Trace
 41 | import           Numeric
 42 | import           Text.Show              (showListWith)
 43 | 
 44 | -- 3rd party
 45 | import qualified Codec.Compression.Zlib as Zlib
 46 | --import           Text.Show.Pretty
 47 | 
 48 | -- project
 49 | import           ETerm
 50 | import           ExtTerm
 51 | 
 52 | data Beam = Beam ModuleName [AtomName] [Op] Strings [Import] [Export] [Lambda] [Literal] deriving (Show, Data, Typeable)
 53 | type ModuleName = B.ByteString
 54 | type Strings = B.ByteString
 55 | 
 56 | newtype AtomName = AtomName B.ByteString deriving (Show, Data, Typeable)
 57 | newtype Arity = Arity { unArity :: Int32 } deriving (Show, Eq, Data, Typeable)
 58 | newtype OperandLabl = OperandLabl Int32 deriving (Show, Data, Typeable)
 59 | 
 60 | newtype AllocList = AllocList { unAllocList :: [(Int32, Int32)] } deriving (Eq, Show, Data, Typeable)
 61 | 
 62 | data Import = Import !AtomNo !AtomNo !Arity deriving (Show, Data, Typeable)
 63 | data Export = Export !AtomNo !Arity !Int32 deriving (Show, Data, Typeable)
 64 | data Lambda =
 65 |   Lambda
 66 |     { funAtom     :: !AtomNo
 67 |     , funArity    :: !Int32
 68 |     , funLabel    :: !Int32
 69 |     , funIndex    :: !Int32
 70 |     , funFreeVars :: !Int32
 71 |     , funOldUniq  :: !Int32
 72 |     } deriving (Show, Data, Typeable)
 73 | 
 74 | data Literal = Literal !ExtTerm deriving (Show, Data, Typeable)
 75 | 
 76 | newtype Destination = Destination Operand deriving (Show, Data, Typeable)
 77 | newtype Source = Source Operand deriving (Show, Data, Typeable)
 78 | newtype SelectList = SelectList [(Operand, OperandLabl)] deriving (Show, Data, Typeable)
 79 | newtype YReg = YReg { unYReg :: Int32 } deriving (Eq, Show, Data, Typeable)
 80 | 
 81 | data Operand
 82 |     = OperandInt !Int32
 83 |     | OperandAtom !AtomNo
 84 |     | OperandXReg !Int32
 85 |     | OperandYReg !Int32
 86 |     | OperandLabel !Int32
 87 |     | OperandTableLiteral !Int32
 88 |     | OperandAllocList ![(Int32, Int32)]
 89 |     | OperandFReg !Int32
 90 |     | OperandNil
 91 |     | OperandSelectList [(Operand, OperandLabl)]
 92 |     deriving (Show, Data, Typeable)
 93 | 
 94 | operandToETerm :: Operand -> ETerm
 95 | operandToETerm (OperandInt int) = EInteger (fromIntegral int)
 96 | operandToETerm (OperandAtom no) = EAtom no
 97 | operandToETerm op = error $ "operandToETerm: not implemented: " ++ show op
 98 | 
 99 | data Op
100 |     = {- 0x01 -} Label !Int32
101 |     | {- 0x02 -} FuncInfo !AtomNo !AtomNo !Int32
102 |     | {- 0x03 -} IntCodeEnd
103 |     | {- 0x04 -} Call !Int32 !OperandLabl
104 |     | {- 0x05 -} CallLast !Int32 !OperandLabl !Int32
105 |     | {- 0x06 -} CallOnly !Int32 !OperandLabl
106 |     | {- 0x07 -} CallExt !Int32 !Int32
107 |     | {- 0x08 -} CallExtLast !Arity !Int32 !Int32
108 |     | {- 0x09 -} Bif0 !(Maybe Int32) !Int32 {-ext_fun_ref-} !Destination
109 |     | {- 0x0c -} Allocate !Int32 !Int32
110 |     | {- 0x0e -} AllocateZero !Int32 !Int32
111 |     | {- 0x07 -} AllocateHeapZero !Int32 !AllocList !Int32
112 |     | {- 0x10 -} TestHeap !AllocList !Int32
113 |     | {- 0x11 -} Init !Destination
114 |     | {- 0x12 -} Deallocate !Int32
115 |     | {- 0x13 -} KReturn
116 |     | {- 0x14 -} Send
117 |     | {- 0x15 -} RemoveMessage
118 |     | {- 0x17 -} LoopRec !OperandLabl !Destination
119 |     | {- 0x18 -} LoopRecEnd !OperandLabl
120 |     | {- 0x19 -} Wait !OperandLabl
121 |     | {- 0x27 -} IsLt !OperandLabl !Source !Source
122 |     | {- 0x28 -} IsGe !OperandLabl !Source !Source
123 |     | {- 0x29 -} IsEq !OperandLabl !Source !Source
124 |     | {- 0x2a -} IsNe !OperandLabl !Source !Source
125 |     | {- 0x2b -} IsEqExact !OperandLabl !Source !Source
126 |     | {- 0x2c -} IsNeExact !OperandLabl !Source !Source
127 |     | {- 0x2d -} IsInteger !OperandLabl !Source --erjang uses Destination?!
128 |     | {- 0x30 -} IsAtom !OperandLabl !Source --erjang uses Destination?!
129 |     | {- 0x39 -} IsTuple !OperandLabl !Destination
130 |     | {- 0x3a -} TestArity !OperandLabl !Destination !Int32
131 |     | {- 0x3b -} SelectVal !Source !OperandLabl !SelectList
132 |     | {- 0x3d -} Jump !OperandLabl
133 |     | {- 0x3e -} Catch !YReg !OperandLabl
134 |     | {- 0x3f -} CatchEnd !YReg
135 |     | {- 0x40 -} Move !Source !Destination
136 |     | {- 0x42 -} GetTupleElement !Source !Int32 !Destination
137 |     | {- 0x45 -} PutList !Source !Source !Destination
138 |     | {- 0x46 -} PutTuple !Int32 !Destination
139 |     | {- 0x47 -} Put !Source
140 |     | {- 0x49 -} IfEnd
141 |     | {- 0x4a -} CaseEnd !Source
142 |     | {- 0x4b -} CallFun !Int32
143 |     | {- 0x4e -} CallExtOnly !Int32 !Int32
144 |     | {- 0x5e -} FClearError
145 |     | {- 0x5f -} FCheckError !OperandLabl
146 |     | {- 0x60 -} FMove !Source Destination
147 |     | {- 0x61 -} FConv !Source !Destination
148 |     | {- 0x65 -} FDiv !OperandLabl !Source !Source !Destination
149 |     | {- 0x67 -} MakeFun2 !Int32
150 |     | {- 0x68 -} Try !YReg !OperandLabl
151 |     | {- 0x69 -} TryEnd !Destination
152 |     | {- 0x6a -} TryCase !Destination
153 |     | {- 0x6c -} Raise !Source !Source
154 |     | {- 0x7d -} GcBif2 !(Maybe Int32) !Int32 !Int32 !Source !Source !Destination
155 |     | {- 0x88 -} Trim !Int32 !Int32
156 |     | {- 0x99 -} Line  !Int32
157 |         deriving (Show, Data, Typeable)
158 | 
159 | class Opp a where
160 |   readOp :: a -> Get Op
161 | 
162 | instance Opp Op where
163 |   readOp = return
164 | 
165 | instance (Arg a, Opp b) => Opp (a -> b) where
166 |   readOp f = readOp =<< (f <$> readArg)
167 | 
168 | class Arg a where
169 |   readArg :: Get a
170 | 
171 | instance Arg Int32 where
172 |   readArg = readCodeInteger
173 | 
174 | instance Arg AtomNo where
175 |   readArg = readAtom
176 | 
177 | instance Arg Destination where
178 |   readArg = fmap Destination readOperand
179 | 
180 | instance Arg Source where
181 |   readArg = fmap Source readOperand
182 | 
183 | instance Arg OperandLabl where
184 |   readArg = readLabel
185 | 
186 | instance Arg AllocList where
187 |   readArg = readAllocList
188 | 
189 | instance Arg SelectList where
190 |   readArg = readSelectList
191 | 
192 | instance Arg Arity where
193 |   readArg = Arity <$> readCodeInteger
194 | 
195 | instance Arg YReg where
196 |   readArg = readYReg
197 | 
198 | readBeamFile :: String -> IO Beam
199 | readBeamFile fileName = runGet getBeam <$> BL.readFile fileName
200 | 
201 | getBeam :: Get Beam
202 | getBeam = do
203 |   "FOR1" <- getByteString 4
204 |   skip 4
205 |   "BEAM" <- getByteString 4
206 |   (modName, atoms) <- getAtoms
207 |   code <- getCode
208 |   strs <- getStrings
209 |   impt <- getImpt
210 |   expt <- getExpt
211 |   funt <- getFunT
212 |   litt <- getLitT
213 |   !_ <- skipper
214 |   --True <- isEmpty
215 |   return (Beam modName atoms code strs impt expt funt litt)
216 | 
217 | getAtoms :: Get (ModuleName, [AtomName])
218 | getAtoms =
219 |   readTag "Atom" $ do
220 |     numAtoms <- get :: Get Int32
221 |     atoms@(AtomName modName:_) <- replicateM (fromIntegral numAtoms) getAtom
222 |     return (modName, atoms)
223 | 
224 | getAtom :: Get AtomName
225 | getAtom = do
226 |   len <- getWord8
227 |   AtomName <$> getByteString (fromIntegral len)
228 | 
229 | getCode :: Get [Op]
230 | getCode =
231 |   readTag "Code" $ do
232 |     skip 20
233 |     decodeInstructions
234 | getStrings :: Get B.ByteString
235 | getStrings =
236 |   readOptionalTagWithSize "StrT" B.empty $ \csize ->
237 |     getByteString (fromIntegral csize)
238 | 
239 | getImpt :: Get [Import]
240 | getImpt =
241 |   readTag "ImpT" $ do
242 |     noOfEntries <- get :: Get Int32
243 |     replicateM (fromIntegral noOfEntries) $ do
244 |       mod_ <- get :: Get Int32
245 |       fun <- get :: Get Int32
246 |       arity <- get :: Get Int32
247 |       return (Import (AtomNo mod_) (AtomNo fun) (Arity arity))
248 | 
249 | getExpt :: Get [Export]
250 | getExpt =
251 |   readTag "ExpT" $ do
252 |     noOfEntries <- get :: Get Int32
253 |     replicateM (fromIntegral noOfEntries) $ do
254 |       fun <- get :: Get Int32
255 |       arity <- get :: Get Int32
256 |       label <- get :: Get Int32
257 |       return (Export (AtomNo fun) (Arity arity) label)
258 | 
259 | getFunT :: Get [Lambda]
260 | getFunT =
261 |   readOptionalTag "FunT" [] $ do
262 |     noOfEntries <- get :: Get Int32
263 |     replicateM (fromIntegral noOfEntries) $ do
264 |       fun <- fmap AtomNo get
265 |       arity <- get
266 |       label <- get
267 |       index <- get
268 |       freeVars <- get
269 |       oldUniq <- get
270 |       return (Lambda fun arity label index freeVars oldUniq)
271 | 
272 | getLitT :: Get [Literal]
273 | getLitT =
274 |   readOptionalTagWithSize "LitT" [] $ \csize -> do
275 |     skip 4
276 |     block <- getLazyByteString (fromIntegral csize - 4)
277 |     let deflated = Zlib.decompress block
278 |     return $ runGet go deflated
279 |   where
280 |     go = do
281 |       noOfEntries <- get :: Get Int32
282 |       replicateM (fromIntegral noOfEntries) $ do
283 |         len <- get :: Get Int32
284 |         arr <- getLazyByteString (fromIntegral len)
285 |         return (Literal (decodeExtTerm True arr))
286 | 
287 | decodeInstructions :: Get [Op]
288 | decodeInstructions = do
289 |   e <- isEmpty
290 |   if e
291 |     then return []
292 |     else do
293 |       inst <- decodeInstruction
294 |       -- btrace $ "finished instr " ++ show inst
295 |       insts <- decodeInstructions
296 |       return (inst:insts)
297 | 
298 | btrace :: (Monad m) => String -> m ()
299 | btrace str = trace str $ return ()
300 | 
301 | decodeInstruction :: Get Op
302 | decodeInstruction = do
303 |   op <- getWord8
304 |   -- btrace $ showString "working on op 0x" . showHex op $ []
305 |   case op of
306 |     0x01 -> readOp Label
307 |     0x02 -> readOp FuncInfo
308 |     0x03 -> readOp IntCodeEnd
309 |     0x04 -> readOp Call
310 |     0x05 -> readOp CallLast
311 |     0x06 -> readOp CallOnly
312 |     0x07 -> readOp CallExt
313 |     0x08 -> readOp CallExtLast
314 |     0x09 -> readOp =<< (Bif0 <$> readOptionalLabel)
315 |     0x0c -> readOp Allocate
316 |     0x0e -> readOp AllocateZero
317 |     0x0f -> readOp AllocateHeapZero
318 |     0x10 -> readOp TestHeap
319 |     0x11 -> readOp Init
320 |     0x12 -> readOp Deallocate
321 |     0x13 -> readOp KReturn
322 |     0x14 -> readOp Send
323 |     0x15 -> readOp RemoveMessage
324 |     0x17 -> readOp LoopRec
325 |     0x18 -> readOp LoopRecEnd
326 |     0x19 -> readOp Wait
327 |     0x27 -> readOp IsLt
328 |     0x28 -> readOp IsGe
329 |     0x29 -> readOp IsEq
330 |     0x2a -> readOp IsNe
331 |     0x2b -> readOp IsEqExact
332 |     0x2c -> readOp IsNeExact
333 |     0x2d -> readOp IsInteger
334 |     0x30 -> readOp IsAtom
335 |     0x39 -> readOp IsTuple
336 |     0x3a -> readOp TestArity
337 |     0x3b -> readOp SelectVal
338 |     0x3d -> readOp Jump
339 |     0x3e -> readOp Catch
340 |     0x3f -> readOp CatchEnd
341 |     0x40 -> readOp Move
342 |     0x42 -> readOp GetTupleElement
343 |     0x45 -> readOp PutList
344 |     0x46 -> readOp PutTuple
345 |     0x47 -> readOp Put
346 |     0x49 -> readOp IfEnd
347 |     0x4a -> readOp CaseEnd
348 |     0x4b -> readOp CallFun
349 |     0x4e -> readOp CallExtOnly
350 |     0x5e -> readOp FClearError
351 |     0x5f -> readOp FCheckError
352 |     0x60 -> readOp FMove
353 |     0x61 -> readOp FConv
354 |     0x65 -> readOp FDiv
355 |     0x67 -> readOp MakeFun2
356 |     0x68 -> readOp Try
357 |     0x69 -> readOp TryEnd
358 |     0x6a -> readOp TryCase
359 |     0x6c -> readOp Raise
360 |     0x88 -> readOp Trim
361 |     0x99 -> readOp Line
362 |     0x7d -> do
363 |       optLabel <- readOptionalLabel
364 |       readOp (GcBif2 optLabel)
365 |     _ -> do
366 |       next <- getByteString 10 <|> return B.empty
367 |       error $
368 |         showString "unknown op code: 0x" .
369 |         showHex op . showString " named " .
370 |         showString (opNames !! fromIntegral op) .
371 |         showString ", next 10 bytes: " .
372 |         showListWith showHex (B.unpack next) $ []
373 | 
374 | readAtom :: Get AtomNo
375 | readAtom = do
376 |   operand <- readOperand
377 |   case operand of
378 |     OperandAtom a -> return a
379 | 
380 | readCodeInteger :: Get Int32
381 | readCodeInteger = do
382 |   w <- getWord8
383 |   let t = w .&. 7
384 |   if t == codeInt4_tag
385 |     then readSmallIntValue w
386 |     else error (showString "not a code int: " . showHex w $ [])
387 | 
388 | codeInt4_tag :: Word8
389 | codeInt4_tag = 0
390 | 
391 | _codeInt12_tag :: Word8
392 | _codeInt12_tag = 8
393 | 
394 | readSmallIntValue :: Word8 -> Get Int32
395 | readSmallIntValue w0 = do
396 |   let !tag = w0 .&. 0x0F
397 |       !hdata = w0 `shiftR` 4
398 |   case () of
399 |     _ | tag .&. 0x08 == 0 -> return (fromIntegral hdata)
400 |     _ | hdata .&. 1 == 0 -> do -- need 1 more byte
401 |           w1 <- getWord8
402 |           let w0' = fromIntegral (hdata `shiftL` 7)
403 |           let w = (w0' + fromIntegral w1) :: Word32
404 |           -- !_ <- btrace ("w0=" ++ show w0 ++ ", w1=" ++ show w1)
405 |           -- !_ <-btrace ("readSmallIntValue: tag=" ++ show tag ++ ", hdata=" ++ show hdata ++ ", w0=" ++ show w0 ++ ", w1= " ++ show w1 ++ ", w=" ++ show w)
406 |           return (fromIntegral w)
407 |     _ -> do
408 |       let len = 2 + (hdata `shiftR` 1)
409 |       bytes <- getByteString (fromIntegral len)
410 |       -- big endian
411 |       let !value = B.foldl' (\acc new -> (acc `shiftL` 8) + fromIntegral new) 0 bytes :: Word32
412 |       return (fromIntegral value)
413 |       --error $
414 |       --   showString "unimplemented case of readSmallIntValue; w0=0x" . showHex w0 .
415 |       --   showString ", tag=0x" . showHex tag .
416 |       --   showString ", hdata=0x" . showHex hdata .
417 |       --   showString ", len=" . shows len .
418 |       --   showString ", data=" . shows (B.unpack bytes) .
419 |       --   showString ", value=" . shows value $ []
420 | 
421 | readOperand :: Get Operand
422 | readOperand = do
423 |   w0 <- getWord8
424 |   let !tag = w0 .&. 0x07
425 |   case tag of
426 |     0x00 -> OperandInt <$> readSmallIntValue w0
427 |     0x01 ->
428 |       if w0 .&. 0x08 == 0
429 |         then fmap OperandInt (readSmallIntValue w0)
430 |         else do
431 |           let hdata = w0 `shiftR` 4
432 |           if (hdata .&. 0x01) == 0
433 |             then do
434 |               w1 <- getWord8
435 |               let w = ((fromIntegral hdata) `shiftL` 7) + fromIntegral w1
436 |               return (OperandInt w)
437 |             else do
438 |               let len | hdata < 15 = return $ 2 + (fromIntegral hdata `shiftR` 1)
439 |                       | otherwise = do
440 |                           w2 <- fmap fromIntegral readCodeInteger
441 |                           return $ 2 + (fromIntegral hdata `shiftR` 1) + w2
442 |               bytes <- len >>= getByteString
443 |               let !value = B.foldl' (\acc new -> (acc `shiftL` 8) + fromIntegral new) 0 bytes
444 |               let _types = value :: Word32
445 |               return (OperandInt (fromIntegral value))
446 |     0x02 ->
447 |       (\no -> if no == 0
448 |                 then OperandNil
449 |                 else OperandAtom (AtomNo no)) <$> readSmallIntValue w0
450 |     0x03 -> OperandXReg <$> readSmallIntValue w0
451 |     0x04 -> OperandYReg <$> readSmallIntValue w0
452 |     0x05 -> OperandLabel <$> readSmallIntValue w0
453 |     0x07 -> do -- extended
454 |       let moretag = w0 `shiftR` 4
455 |       case moretag of
456 |         0x01 -> OperandSelectList <$> do
457 | 	  noOfEntries <- readCodeInteger
458 | 	  -- assert noOfEntries % 2 == 0
459 | 	  replicateM (fromIntegral (noOfEntries `div` 2)) $
460 | 	    (,) <$> readOperand <*> readLabel
461 |         0x02 -> OperandFReg <$> (getWord8 >>= readSmallIntValue)
462 |         0x03 -> OperandAllocList <$> do
463 |           noOfEntries <- readCodeInteger
464 |           replicateM (fromIntegral noOfEntries) ((,) <$> readCodeInteger <*> readCodeInteger)
465 |         0x04 -> OperandTableLiteral <$> (getWord8 >>= readSmallIntValue)
466 |         _ -> error $ showString "unimplemneted extended operand (tag == 0x" . showHex tag . showString ", moretag == 0x" . showHex moretag . showString ")" $ []
467 |     0x13 -> OperandLabel <$> readSmallIntValue w0
468 |     _ -> error $ showString "unknown operand 0x" . showHex w0 . showString " with tag 0x" . showHex tag $ []
469 | 
470 | readOptionalLabel :: Get (Maybe Int32)
471 | readOptionalLabel = optLabel <|> return Nothing
472 |   where
473 |     optLabel = do
474 |       operand <- readOperand
475 |       case operand of
476 |         OperandLabel nr -> return (Just nr)
477 |         _ -> fail "not a label" -- unconsumes input
478 | 
479 | readLabel :: Get OperandLabl
480 | readLabel = do
481 |   op <- readOperand
482 |   case op of
483 |     OperandLabel lbl -> return (OperandLabl lbl)
484 |     _ -> error ("readLabel confused, " ++ show op)
485 | 
486 | readAllocList :: Get AllocList
487 | readAllocList = do
488 |   op <- readOperand
489 |   case op of
490 |     OperandAllocList list -> return (AllocList list)
491 |     OperandInt int -> return (AllocList [(0, int)])
492 |     _ -> error ("readAllocList confused; " ++ show op)
493 | 
494 | readSelectList :: Get SelectList
495 | readSelectList = do
496 |   op <- readOperand
497 |   case op of
498 |     OperandSelectList lst -> return (SelectList lst)
499 |     _ -> error ("readSelectList confused; " ++ show op)
500 | 
501 | readYReg :: Get YReg
502 | readYReg = do
503 |   op <- readOperand
504 |   case op of
505 |     OperandYReg reg -> return $! (YReg reg)
506 |     _ -> error ("readYreg confused; " ++ show op)
507 | 
508 | readTag :: B.ByteString -> Get b -> Get b
509 | readTag tag dec = readOptionalTagWithSize tag (error "readTag") (const dec)
510 | 
511 | readOptionalTag :: B.ByteString -> b -> Get b -> Get b
512 | readOptionalTag tag fallback dec =
513 |   readOptionalTagWithSize tag fallback (const dec)
514 | 
515 | readOptionalTagWithSize :: B.ByteString -> b -> (Int32 -> Get b) -> Get b
516 | readOptionalTagWithSize tag fallback dec = do
517 |   tagMatch <- readTag' <|> return False
518 |   case tagMatch of
519 |     False -> return fallback
520 |     True -> do
521 |       csize <- get :: Get Int32
522 |       block <- getLazyByteString (fromIntegral csize)
523 |       -- account for padding
524 |       let padding = (4 - (fromIntegral csize `mod` 4)) `mod` 4
525 |       skip padding
526 |       return (runGet (dec csize) block)
527 |   where
528 |     readTag' = do
529 |       tag' <- getByteString 4
530 |       unless (tag == tag') $ do
531 |         !_ <- btrace ("expected other tag, got " ++ show tag' ++ " but wanted " ++ show tag)
532 |         fail "wrong tag"
533 |       return True
534 | 
535 | skipTag :: B.ByteString -> Get ()
536 | skipTag tag = go <|> btrace ("no tag: " ++ show tag)
537 |   where
538 |   go =
539 |     readOptionalTagWithSize tag () $ \ csize -> do
540 |       _bs <- getByteString (fromIntegral csize)
541 |       return ()
542 | 
543 | skipper :: Get ()
544 | skipper = do
545 |   !_ <- skipTag "LocT"
546 |   !_ <- skipTag "Attr"
547 |   !_ <- skipTag "CInf"
548 |   !_ <- skipTag "Abst"
549 |   !_ <- skipTag "Line"
550 |   return ()
551 | 
552 | opNames :: [String]
553 | opNames = ["NOP","label/1","func_info/3","int_code_end/0","call/2","call_last/3","call_only/2","call_ext/2","call_ext_last/3","bif0/2","bif1/4", "bif2/5","allocate/2","allocate_heap/3","allocate_zero/2","allocate_heap_zero/3","test_heap/2","init/1","deallocate/1","return/0","send/0", "remove_message/0","timeout/0","loop_rec/2","loop_rec_end/1","wait/1","wait_timeout/2","m_plus/4","m_minus/4","m_times/4","m_div/4","int_div/4", "int_rem/4","int_band/4","int_bor/4","int_bxor/4","int_bsl/4","int_bsr/4","int_bnot/3","is_lt/3","is_ge/3","is_eq/3","is_ne/3","is_eq_exact/3", "is_ne_exact/3","is_integer/2","is_float/2","is_number/2","is_atom/2","is_pid/2","is_reference/2","is_port/2","is_nil/2","is_binary/2","is_constant/2", "is_list/2","is_nonempty_list/2","is_tuple/2","test_arity/3","select_val/3","select_tuple_arity/3","jump/1","catch/2","catch_end/1","move/2","get_list/3", "get_tuple_element/3","set_tuple_element/3","put_string/3","put_list/3","put_tuple/2","put/1","badmatch/1","if_end/0","case_end/1", "call_fun/1","make_fun/3","is_function/2","call_ext_only/2","bs_start_match/2","bs_get_integer/5","bs_get_float/5","bs_get_binary/5", "bs_skip_bits/4","bs_test_tail/2","bs_save/1","bs_restore/1","bs_init/2","bs_final/2","bs_put_integer/5","bs_put_binary/5","bs_put_float/5", "bs_put_string/2","bs_need_buf/1","fclearerror/0","fcheckerror/1","fmove/2","fconv/2","fadd/4","fsub/4","fmul/4","fdiv/4","fnegate/3","make_fun2/1", "try/2","try_end/1","try_case/1","try_case_end/1","raise/2","bs_init2/6","bs_bits_to_bytes/3","bs_add/5","apply/1","apply_last/2","is_boolean/2", "is_function2/3","bs_start_match2/5","bs_get_integer2/7","bs_get_float2/7","bs_get_binary2/7","bs_skip_bits2/5","bs_test_tail2/3","bs_save2/2", "bs_restore2/2","gc_bif1/5","gc_bif2/6","bs_final2/2","bs_bits_to_bytes2/2","put_literal/2","is_bitstr/2","bs_context_to_binary/1","bs_test_unit/3", "bs_match_string/4","bs_init_writable/0","bs_append/8","bs_private_append/6","trim/2","bs_init_bits/6","bs_get_utf8/5","bs_skip_utf8/4","bs_get_utf16/5", "bs_skip_utf16/4","bs_get_utf32/5","bs_skip_utf32/4","bs_utf8_size/3","bs_put_utf8/3","bs_utf16_size/3","bs_put_utf16/3","bs_put_utf32/3", "on_load/0","recv_mark/1","recv_set/1","gc_bif3/7"]
554 | 


--------------------------------------------------------------------------------
/Process.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE BangPatterns      #-}
  2 | {-# LANGUAGE OverloadedStrings #-}
  3 | {-# LANGUAGE RankNTypes        #-}
  4 | {-# LANGUAGE RecordWildCards   #-}
  5 | 
  6 | module Process where
  7 | 
  8 | 
  9 | -- hp
 10 | import           Control.Concurrent
 11 | import           Control.Monad.State.Strict
 12 | import qualified Data.ByteString            as B
 13 | import qualified Data.Char                  as Char
 14 | import           Data.Int
 15 | import           Data.List                  (intersperse)
 16 | import           Data.Maybe                 (fromJust, listToMaybe, maybeToList)
 17 | import           Text.Show                  (showListWith)
 18 | 
 19 | -- 3rd party
 20 | import qualified Data.Vector                as V
 21 | import           Text.Show.Pretty
 22 | 
 23 | -- this project
 24 | import           AtomTable                  (AtomTable)
 25 | import qualified AtomTable                  as AT
 26 | import qualified AtomTableErlang            as AT
 27 | import           Beam
 28 | import           EModule
 29 | -- import           ErlangContext
 30 | import           ETerm
 31 | import           ExtTerm
 32 | 
 33 | data Process =
 34 |   Process
 35 |     { pXreg              :: ![ETerm]
 36 |     , pYreg              :: ![ETerm]
 37 |     , pIp                :: !Int
 38 |     , pEModule           :: !EModule
 39 |     , pStack             :: ![StackFrame]
 40 |     , pCatches           :: ![CatchContext]
 41 |     , pAtomTable         :: AtomTable
 42 |     , pFault             :: Maybe AtomNo
 43 |     , pStackTrace        :: Maybe ETerm
 44 |     , pIncommingMessages :: MVar [ETerm]
 45 |     , pAllModules        :: [(AtomNo, EModule)]
 46 |     }
 47 | 
 48 | data StackFrame
 49 |   = StackFrame {-# UNPACK #-} !AtomNo {-# UNPACK #-} !Int
 50 |     deriving Show
 51 | 
 52 | data CatchContext =
 53 |   CatchContext
 54 |     { catchModule          :: {-# UNPACK #-} !AtomNo
 55 |     , catchIp              :: {-# UNPACK #-} !Int
 56 |     , catchCallStackLength :: {-# UNPACK #-} !Int
 57 |     , catchActiveYRegs     :: {-# UNPACK #-} !Int
 58 |     } deriving Show
 59 | 
 60 | runBeam :: [String] -> B.ByteString -> B.ByteString -> [ETerm] -> IO (Maybe ETerm)
 61 | runBeam files mod fun args = do
 62 |   beams <- mapM readBeamFile files
 63 |   let (at, emods) = foldr (\beam (at,emods) -> let (emod, at', beam') = beamToModule beam at in (at', emod:emods)) (AT.basic,[]) beams
 64 |       funNameAtom = AT.lookupByName at fun
 65 |       modNameAtom = AT.lookupByName at mod
 66 |   p0 <- makeProcess emods at modNameAtom funNameAtom args
 67 |   ctx <- newMVar (EC [(emodModNameAtom e, e) | e <- emods] at [p0])
 68 |   p <- runProcess ctx p0
 69 |   case pXreg p of
 70 |     (r0:_) -> return (Just r0)
 71 |     _ -> return Nothing
 72 | 
 73 | makeProcess :: [EModule] -> AtomTable -> AtomNo -> AtomNo -> [ETerm] -> IO Process
 74 | makeProcess emods at emodAN funAtomName args = do
 75 |   let argsArity = fromIntegral (length args)
 76 |       (emod, ip) = case [ (emod', ip) | emod' <- emods
 77 |                                       , emodModNameAtom emod' == emodAN
 78 |                                       , (fun', Arity arity, label) <- emodExports emod'
 79 |                                       , fun' == funAtomName
 80 |                                       , arity == argsArity
 81 |                                       , ip <- maybeToList (lookup label (emodLabelToIp emod')) ] of
 82 |                      [res] -> res
 83 |                      _ -> error $ showString "no such label: " . showFA at funAtomName (Arity argsArity) $ []
 84 |   incomming <- newMVar []
 85 |   return $ Process args [] ip emod [] [] at Nothing Nothing incomming [ (emodModNameAtom emod, emod) | emod <- emods ]
 86 | 
 87 | runProcess :: MVar ErlangContext -> Process -> IO Process
 88 | runProcess ctx p0 = do
 89 |   --putStrLn $ ppShow $ pAtomTable p0
 90 |   (steps, (_ctx, p)) <- runStateT stepper (ctx, p0)
 91 |   let val = head $ [ v | Left v <- steps ]
 92 |   let rendered = renderETerm (pAtomTable p) val
 93 |   -- liftIO $ putStrLn ("Process ended, x0: " ++ rendered)
 94 |   return p
 95 |   where
 96 |     stepper = do
 97 |         p <- getProcess
 98 |         let at = pAtomTable p
 99 |         --liftIO $ putStrLn $ "X: " ++ showListWith showString (map (renderETerm at) (pXreg p)) []
100 |         --liftIO $ putStrLn $ "Y: " ++ showListWith showString (map (renderETerm at) (pYreg p)) []
101 |         --liftIO $ putStrLn $ "Catches: " ++ ppShow (pCatches p)
102 |         --liftIO $ putStrLn $ "Stack: " ++ ppShow (pStack p)
103 |         --liftIO $ putStrLn ""
104 |         --liftIO $ putStrLn $ show (pIp p) ++ ": " ++ show (opAtIp (emodCode (pEModule p)) (pIp p))
105 |         --liftIO $ putStrLn ""
106 |         r <- step
107 |         case r of
108 |           Nothing -> do
109 |             ps <- stepper
110 |             return (Right (opAtIp (emodCode (pEModule p)) (pIp p), p) : ps)
111 |           Just v -> do
112 |             return [Right (opAtIp (emodCode (pEModule p)) (pIp p), p), Left v]
113 | 
114 | showByteString :: B.ByteString -> ShowS
115 | showByteString bs = showString (map (Char.chr . fromIntegral) (B.unpack bs))
116 | 
117 | showMFA :: AtomTable -> AtomNo -> AtomNo -> Arity -> ShowS
118 | showMFA at m0 f0 a0 = showByteString m . showString ":" . showByteString f . showString "/" . shows a
119 |   where
120 |     m = AT.lookupByCode at m0
121 |     f = AT.lookupByCode at f0
122 |     a = unArity a0
123 | 
124 | showFA :: AtomTable -> AtomNo -> Arity -> ShowS
125 | showFA at f0 a0 = showByteString f . showString "/" . shows a
126 |   where
127 |     f = AT.lookupByCode at f0
128 |     a = unArity a0
129 | 
130 | type PM a = StateT (MVar ErlangContext, Process) IO a
131 | 
132 | data ErlangContext = EC {
133 |     ctx_mods              :: [(AtomNo, EModule)],
134 |     ctx_atomtable         :: AT.AtomTable,
135 |     ctx_runningProcessess :: [Process]
136 |   }
137 | 
138 | spawn3 :: MVar ErlangContext -> AtomNo -> AtomNo -> ETerm -> IO ()
139 | spawn3 ec_mvar emod_atom fun_atom args = modifyMVar_ ec_mvar $ \ec -> do
140 |   (emod, at, emods) <- case lookup emod_atom (ctx_mods ec) of
141 |     Just emod -> return (emod, ctx_atomtable ec, ctx_mods ec)
142 |     Nothing -> do
143 |       beam <- readBeamFile "oh-noes-not-implemented.beam"
144 |       let (emod, at, beam') = beamToModule beam (ctx_atomtable ec)
145 |       return (emod, at, (emod_atom, emod) : ctx_mods ec)
146 |   proc <- makeProcess (map snd emods) at emod_atom fun_atom (fromErlangList args)
147 |   forkIO (runProcess ec_mvar proc >> return ())
148 |   --liftIO $ threadDelay 2000000
149 |   return ec { ctx_runningProcessess = proc : ctx_runningProcessess ec
150 |             , ctx_mods = emods
151 |             , ctx_atomtable = at }
152 | 
153 | getProcess :: PM Process
154 | getProcess = gets snd
155 | 
156 | getsProcess :: (Process -> a) -> PM a
157 | getsProcess f = gets (f . snd)
158 | 
159 | modifyProcess :: (Process -> Process) -> PM ()
160 | modifyProcess f = modify (\(ctx,p) -> (ctx, f p))
161 | 
162 | getErlangContextMVar :: PM (MVar ErlangContext)
163 | getErlangContextMVar = gets fst
164 | 
165 | runBif :: AtomNo -> AtomNo -> Arity -> PM ()
166 | runBif emod fun arity =
167 |   case lookup (emod, fun, arity) bifs of
168 |     Just func -> func
169 |     Nothing ->  error "bif not found"
170 | 
171 | bifs :: [((AtomNo, AtomNo, Arity), PM ())]
172 | bifs = [ ((AT.am_erlang, AT.am_now, Arity 0), erlangNow0)
173 |        , ((AT.am_erlang, AT.am_throw, Arity 1), erlangThrow1)
174 |        , ((AT.am_erlang, AT.am_exit, Arity 1), erlangExit1)
175 |        , ((AT.am_erlang, AT.am_error, Arity 1), erlangError1)
176 |        , ((AT.am_erlang, AT.am_get_stacktrace, Arity 0), erlangGetStacktrace0)
177 |        , ((AT.am_erlang, AT.am_spawn, Arity 3), erlangSpawn3)
178 |        , ((AT.am_io, AT.am_format, Arity 1), ioFormat1)
179 |        ]
180 | 
181 | erlangNow0 :: PM ()
182 | erlangNow0 =
183 |   writeDestination (Destination (OperandXReg 0)) $
184 |     ETuple [EInteger 0, EInteger 0, EInteger 0]
185 | 
186 | erlangThrow1 :: PM ()
187 | erlangThrow1 = do
188 |   liftIO $ putStrLn "executing erlang:throw/1"
189 |   t <- readSource (Source (OperandXReg 0))
190 |   fault t ExcThrown
191 |   return ()
192 | 
193 | erlangExit1 :: PM ()
194 | erlangExit1 = do
195 |   liftIO $ putStrLn "executing erlang:exit/1"
196 |   t <- readSource (Source (OperandXReg 0))
197 |   fault t ExcExit
198 |   return ()
199 | 
200 | erlangError1 :: PM ()
201 | erlangError1 = do
202 |   liftIO $ putStrLn "executing erlang:error/1"
203 |   t <- readSource (Source (OperandXReg 0))
204 |   fault t (ExcError JustError) --TODO: justerror?
205 |   return ()
206 | 
207 | erlangSpawn3 :: PM ()
208 | erlangSpawn3 = do
209 |   liftIO $ putStrLn "executing erlang:spawn/3"
210 |   ctx <- getErlangContextMVar
211 |   emod_ <- readSource (Source (OperandXReg 0))
212 |   fun_ <- readSource (Source (OperandXReg 1))
213 |   args <- readSource (Source (OperandXReg 2))
214 |   case (emod_, fun_) of
215 |     (EAtom emod, EAtom fun) | isList args -> do
216 |       liftIO $ spawn3 ctx emod fun args
217 |       return ()
218 | 
219 | ioFormat1 :: PM ()
220 | ioFormat1 = do
221 |   str <- readSource (Source (OperandXReg 0))
222 |   case isList str of
223 |     -- TODO: this is wrong and lame
224 |     True -> liftIO $ putStr ("io:format/1 says: " ++ fixup [ Char.chr (fromIntegral c) | EInteger c <- fromErlangList str ])
225 |     False -> error "io:format/1 says: not a string/list"
226 |   where
227 |     fixup ('~':'n':xs) = '\n' : fixup xs
228 |     fixup (x:xs) = x : fixup xs
229 |     fixup [] = []
230 | 
231 | whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
232 | whenJust Nothing _ = return ()
233 | whenJust (Just x) f = f x
234 | 
235 | data ErrorType
236 |   = ExcError !ErrorKind
237 |   | ExcThrown
238 |   | ExcExit
239 |   deriving (Show)
240 | 
241 | data ErrorKind
242 |   = JustError
243 |   | BasicError
244 |   | BadMatch
245 |   | CaseClause
246 |   | TryClause
247 |   | BadFun
248 |   | BadArity
249 |   | IfClause
250 |   | FunctionClause
251 |   deriving (Show)
252 | 
253 | fault :: ETerm -> ErrorType -> PM (Maybe a)
254 | fault errorTerm0 kind0 = do
255 |   st <- stackTrace
256 |   catches <- getsProcess pCatches
257 |   let (errorTerm', kind) = case (catches, kind0) of
258 |         ([], ExcThrown) -> (ETuple [(EAtom AT.am_nocatch), errorTerm0], ExcError BasicError)
259 |         _ -> (errorTerm0, kind0)
260 |       errorTerm = expandErrorTerm errorTerm' kind
261 |   case catches of
262 |     [] -> do
263 |       at <- getsProcess pAtomTable
264 |       liftIO $ putStrLn (renderETerm at errorTerm)
265 |       liftIO $ print kind
266 |       error "fault: should kill process"
267 |     (c:_cs) -> do
268 |       modifyProcess (\p -> p { pStack = reverse . take (catchCallStackLength c) . reverse $ pStack p
269 |                              , pYreg =  reverse . take (catchActiveYRegs     c) . reverse $ pYreg p })
270 |       let st' = ETuple [errorTerm, st]
271 |       writeDestination (Destination (OperandXReg 0)) ENonValue
272 |       writeDestination (Destination (OperandXReg 1)) (EAtom (exceptionAtom kind))
273 |       writeDestination (Destination (OperandXReg 2)) errorTerm
274 |       writeDestination (Destination (OperandXReg 3)) st' --approx...
275 |       modifyProcess (\p -> p { pStackTrace = Just st' })
276 |       gotoModIp (catchModule c) (catchIp c)
277 |       return Nothing
278 | 
279 | expandErrorTerm :: ETerm -> ErrorType -> ETerm
280 | expandErrorTerm t err =
281 |   case err of
282 |     ExcThrown -> t
283 |     ExcExit -> t
284 |     ExcError BasicError -> t
285 |     ExcError BadMatch -> ETuple [EAtom AT.am_badmatch, t]
286 |     ExcError CaseClause -> ETuple [EAtom AT.am_case_clause, t]
287 |     ExcError TryClause -> ETuple [EAtom AT.am_try_clause, t]
288 |     ExcError BadFun -> ETuple [EAtom AT.am_badfun, t]
289 |     ExcError BadArity -> ETuple [EAtom AT.am_badarity, t]
290 |     ExcError _ -> t
291 | 
292 | exceptionAtom :: ErrorType -> AtomNo
293 | exceptionAtom (ExcError _) = AT.am_error
294 | exceptionAtom ExcExit = AT.am_exit
295 | exceptionAtom ExcThrown = AT.am_throw
296 | 
297 | erlangGetStacktrace0 :: PM ()
298 | erlangGetStacktrace0 = do
299 |   st <- getsProcess pStackTrace
300 |   let term = case st of
301 |                Nothing -> ENil
302 |                Just st' -> st'
303 |   writeDestination (Destination (OperandXReg 0)) term
304 |   handleOp KReturn
305 |   return ()
306 | 
307 | stackTrace :: PM ETerm
308 | stackTrace = do
309 |   stack <- getsProcess pStack
310 |   allModules <- getsProcess pAllModules
311 |   lst <- forM stack $ \(StackFrame modName ip) -> do
312 |     let Just emod = lookup modName allModules
313 |     let code = emodCode emod
314 |     let Just (stackFrame@(emod, fun, ar)) = ipToFunction code ip
315 |     return $ ETuple [EAtom emod, EAtom fun, EInteger (fromIntegral ar)]
316 |   return (toErlangList lst)
317 | 
318 | ipToFunction :: Code -> Int -> Maybe (AtomNo, AtomNo, Int32)
319 | ipToFunction _ (-1) = Nothing
320 | ipToFunction code n =
321 |   case opAtIp code n of
322 |     FuncInfo emod fun arity -> Just (emod, fun, arity)
323 |     _ -> ipToFunction code (n-1)
324 | 
325 | renderETerm :: AtomTable -> ETerm -> String
326 | renderETerm at eterm = go at eterm
327 |   where
328 |     go _ ENonValue = "the-non-value"
329 |     go _ (EInteger n) = show n
330 |     go at (ETuple lst) = concat ("{" : intersperse "," (map (go at) lst) ++ ["}"])
331 |     go at (EList hd tl) = "[" ++ concat (intersperse "," (map (go at) (fromList hd tl))) ++ "]"
332 |     go _ (EString str) = show str
333 |     go _ ENil = "nil"
334 |     go _ (EBinary _) = "<<bin>>"
335 |     go at (EAtom no) = showByteString (AT.lookupByCode at no) []
336 |     go _ (EFun {..}) = showByteString funMod . showString ":" . showByteString funName . showString "/" . shows etfunArity $ []
337 | 
338 |     showAtomName :: String -> String
339 |     showAtomName name
340 |       | any Char.isSpace name = quote name
341 |       | Just c <- listToMaybe name, Char.isUpper c = quote name
342 |       | otherwise = name
343 | 
344 |     quote :: String -> String
345 |     quote name = "'" ++ name ++ "'"
346 | 
347 |     fromList :: ETerm -> ETerm -> [ETerm]
348 |     fromList hd ENil = [hd]
349 |     fromList hd (EList hd' tl) = hd : fromList hd' tl
350 | 
351 | continue :: PM (Maybe a)
352 | continue = modifyProcess (\p -> p { pIp = pIp p + 1 }) >> return Nothing
353 | 
354 | gotoModIp :: AtomNo -> Int -> PM ()
355 | gotoModIp modName ip = do
356 |   p <- getProcess
357 |   emod <- case lookup modName (pAllModules p) of
358 |             Just emod -> return emod
359 |             Nothing -> error $ "no such module; " ++ show modName
360 |   modifyProcess (\p -> p { pEModule = emod, pIp = ip })
361 | 
362 | gotoModFunArity :: AtomNo -> AtomNo -> Arity -> PM (Maybe ETerm)
363 | gotoModFunArity mod fun ar = do
364 |   erl <- lookupModFunArity mod fun ar
365 |   case erl of
366 |     Just (emod, ip) -> gotoModIp (emodModNameAtom emod) ip >> return Nothing
367 |     Nothing -> do -- can be a bif
368 |       case lookup (mod, fun, ar) bifs of
369 |         Just func -> func >> handleOp KReturn
370 |         Nothing -> do -- TODO: module:fun/ar not found! create erlang error.
371 |           at <- getsProcess pAtomTable
372 |           error $ showString "function " . showMFA at mod fun ar . showString " not found" $ []
373 | 
374 | lookupModFunArity :: AtomNo -> AtomNo -> Arity -> PM (Maybe (EModule, Int))
375 | lookupModFunArity modName funName funArity = do
376 |   p <- getProcess
377 |   case [ (emod, ip)
378 |        | emod <- maybeToList (lookup modName (pAllModules p))
379 |        , (fun', arity, label) <- emodExports emod
380 |        , fun' == funName
381 |        , arity == funArity
382 |        , ip <- maybeToList (lookup label (emodLabelToIp emod)) ] of
383 |     [res] -> return (Just res)
384 |     _ -> return Nothing
385 | 
386 | readSource :: Source -> PM ETerm
387 | readSource (Source (OperandInt no)) = return $ EInteger (fromIntegral no)
388 | readSource (Source (OperandXReg n)) =
389 |   getsProcess $ \p -> pXreg p !! (fromIntegral n)
390 | readSource (Source (OperandYReg n)) =
391 |   getsProcess $ \p -> pYreg p !! (fromIntegral n)
392 | readSource (Source (OperandTableLiteral no)) = do
393 |   p <- getProcess
394 |   let Literal x = emodLiteralTable (pEModule p) !! (fromIntegral no)
395 |   return $ extTermToETerm x
396 | readSource (Source (OperandAtom atomNo)) = return $! EAtom atomNo
397 | readSource (Source OperandNil) = return ENil
398 | readSource (Source src) = error $ "readSource " ++ show src
399 | 
400 | writeDestination :: Destination -> ETerm -> PM ()
401 | writeDestination dest !value =
402 |   case dest of
403 |     (Destination (OperandXReg n)) -> modifyProcess (\p -> p { pXreg = updateList (pXreg p) (fromIntegral n) })
404 |     (Destination (OperandYReg n)) -> modifyProcess (\p -> p { pYreg = updateList (pYreg p) (fromIntegral n) })
405 |     _ -> error ("writeDest " ++ show dest ++ ", value=" ++ show value)
406 |   where
407 |     updateList list pos =
408 |       prefix ++ fill ++ value : drop (pos+1) list
409 |       where
410 |         prefix = take pos list
411 |         fill | length prefix < pos = replicate (pos - length prefix) ENil
412 |              | otherwise = []
413 | 
414 | popCatch :: PM CatchContext
415 | popCatch = do
416 |   ccs <- getsProcess pCatches
417 |   case ccs of
418 |     (c:cs) -> modifyProcess (\p -> p { pCatches = cs }) >> return c
419 |     [] -> error "popCatch: no catchcontexts to pop"
420 | 
421 | addStackTrace :: ETerm -> ETerm -> PM ETerm
422 | addStackTrace value exc = do
423 |   where_ <- buildStackTrace exc
424 |   return (ETuple [value, where_])
425 | 
426 | buildStackTrace :: ETerm -> PM ETerm
427 | buildStackTrace exc = return exc
428 | 
429 | step :: PM (Maybe ETerm)
430 | step = do
431 |   p <- getProcess
432 |   let op = opAtIp (emodCode (pEModule p)) (pIp p)
433 |   handleOp op
434 | 
435 | handleOp :: Op -> PM (Maybe ETerm)
436 | handleOp op0 = do
437 |   p <- getProcess
438 |   let thisModuleName = emodModNameAtom (pEModule p)
439 |       sameModule ip = StackFrame thisModuleName ip
440 |   -- liftIO $ print op0
441 |   case op0 of
442 |     Label _ -> continue
443 |     Line _ -> continue
444 |     TestHeap _ _ -> continue
445 |     Trim n _ -> deallocateY n >> continue
446 |     Deallocate n -> deallocateY n >> continue
447 |     Call _ (OperandLabl label) -> do
448 |       let jumpIp = fromJust $ lookup label (emodLabelToIp (pEModule p))
449 |           returnIp = pIp p + 1
450 |       updateStack (sameModule returnIp:)
451 |       gotoIp jumpIp
452 |       ret
453 |     CallOnly _ label -> gotoLabel label >> ret
454 |     CallFun arityAndReg -> do
455 |       -- Fun fact; the value arityAndReg says both where the function is stored
456 |       -- as well as its arity.
457 |       efun <- readSource (Source (OperandXReg arityAndReg))
458 |       case efun of
459 |         EFun {} -> do
460 |           let jumpIp = funIp efun
461 |               returnIp = pIp p + 1
462 |               functionArity = etfunArity efun
463 |               freeVars = funFree efun
464 |               x_regs | length freeVars > 0 =
465 |                          -- [ ... function arguments ...
466 |                          -- , ... free variables ...
467 |                          -- , ... function gets moved here ...
468 |                          -- , ... rest of X registers ... ]
469 |                          take (fromIntegral functionArity) (pXreg p) ++
470 |                            freeVars ++ [efun] ++ drop (fromIntegral functionArity + length freeVars + 1) (pXreg p)
471 |                      | otherwise = pXreg p
472 |           if (functionArity /= arityAndReg)
473 |             then fault (ETuple [efun, toErlangList (take (fromIntegral functionArity) (pXreg p))]) (ExcError BadArity)
474 |             else do
475 |               updateStack (sameModule returnIp:)
476 |               gotoIp jumpIp
477 |               setXRegs x_regs
478 |               ret
479 |         _ -> fault efun (ExcError BadFun)
480 |     CallExt _arity ix -> do
481 |       let (modName, funName, funArity) = (emodImports (pEModule p)) V.! (fromIntegral ix)
482 |           returnIp = pIp p + 1
483 |       updateStack (sameModule returnIp:)
484 |       gotoModFunArity modName funName funArity
485 |     CallExtOnly _arity ix -> do
486 |       let (modName, funName, funArity) = (emodImports (pEModule p)) V.! (fromIntegral ix)
487 |       gotoModFunArity modName funName funArity
488 |     AllocateZero noYregs _ -> do
489 |       modifyProcess (\p -> p { pYreg = replicate (fromIntegral noYregs) (EInteger 0) ++ (pYreg p) })
490 |       continue
491 |     Allocate noYregs _ -> do
492 |       modifyProcess (\p -> p { pYreg = replicate (fromIntegral noYregs) ENil ++ (pYreg p) })
493 |       continue
494 |     IsLt label src1 src2 -> do
495 |       EInteger value1 <- readSource src1
496 |       EInteger value2 <- readSource src2
497 |       let trueIp = pIp p + 1
498 |       falseIp <- lookupIp label
499 |       gotoIp (if value1 < value2 then trueIp else falseIp)
500 |       return Nothing
501 |     IsEqExact label src1 src2 -> do
502 |       value1 <- readSource src1
503 |       value2 <- readSource src2
504 |       let trueIp = pIp p + 1
505 |       falseIp <- lookupIp label
506 |       gotoIp (if isEtermEq value1 value2 then trueIp else falseIp)
507 |       return Nothing
508 |     IsEq label src1 src2 -> handleOp (IsEqExact label src1 src2) -- todo: fix
509 |     IsInteger lbl src -> do
510 |       value <- readSource src
511 |       ip <- case value of
512 |               EInteger _ -> return (pIp p + 1)
513 |               _ -> lookupIp lbl
514 |       gotoIp ip
515 |       return Nothing
516 |     IsAtom lblIfFalse src -> do
517 |       value <- readSource src
518 |       if isAtom value
519 |         then continue
520 |         else gotoLabel lblIfFalse >> ret
521 |     SelectVal src lbl (SelectList lst) -> do
522 |       val <- readSource src
523 |       let newLbl [] = lbl
524 |           newLbl ((op, branch_lbl):xs)
525 |             | isEtermEq val (operandToETerm op) = branch_lbl
526 |             | otherwise = newLbl xs
527 |       newIp <- lookupIp (newLbl lst)
528 |       gotoIp newIp
529 |       ret
530 |     FuncInfo _ _ _ -> fault ENil (ExcError FunctionClause)
531 |     Move src dest -> do
532 |       value <- readSource src
533 |       writeDestination dest value
534 |       continue
535 |     PutList src1 src2 dest -> do
536 |       val1 <- readSource src1
537 |       val2 <- readSource src2
538 |       let lst = EList val1 val2
539 |       writeDestination dest lst
540 |       continue
541 |     PutTuple arity dest -> do
542 |       -- The 'arity' number of following instructions will be 'Put Source' describing where to find
543 |       -- the values to put into the tuple.
544 |       vals <- replicateM (fromIntegral arity) $ do
545 |         continue
546 |         op <- getOp
547 |         case op of
548 |           Put src -> readSource src
549 |           _ -> error "PutTuple; unexpected instruction"
550 |       writeDestination dest (ETuple vals)
551 |       continue
552 |     Put _src -> error "Put; I expected to be part of a PutTuple!"
553 |     GcBif2 _ _ n op1 op2 dest -> do
554 |       let op = case emodImports (pEModule p) V.! (fromIntegral n) of
555 |                  imp | imp == (AT.am_erlang, AT.am_sign_plus, Arity 2) -> bif_plus
556 |                      | imp == (AT.am_erlang, AT.am_sign_minus, Arity 2) -> bif_minus
557 |                      | imp == (AT.am_erlang, AT.am_sign_mult, Arity 2) -> bif_mult
558 |       bif_binop op op1 op2 dest
559 |       continue
560 |     MakeFun2 no -> do
561 |       let funs = emodFunctions (pEModule p)
562 |           fun = funs!!(fromIntegral no)
563 |           numFree = funFreeVars fun
564 |           free = take (fromIntegral numFree) (pXreg p)
565 |           arity = funArity fun - numFree
566 |       funIp <- lookupIp (OperandLabl (funLabel fun))
567 |       let f = EFun
568 |                { funIp = funIp
569 |                , funMod = emodName (pEModule p)
570 |                , funFree = free
571 |                , etfunArity = arity
572 |                , funName = AT.lookupByCode (pAtomTable p) (funAtom fun)
573 |                }
574 |       writeDestination (Destination (OperandXReg 0)) f
575 |       continue
576 |     KReturn
577 |       | null (pStack p) -> return $ Just ((pXreg p) !! 0)
578 |       | otherwise -> do
579 |           let (jumpIp:newStack) = pStack p
580 |               p' = case jumpIp of
581 |                      StackFrame newMod ip
582 |                        | newMod == thisModuleName -> p { pStack = newStack, pIp = ip }
583 |                        | otherwise -> p { pEModule = fromJust (lookup newMod (pAllModules p))
584 |                                         , pStack = newStack
585 |                                         , pIp = ip }
586 |           modifyProcess (const p')
587 |           ret
588 |     Catch (YReg dest) catchLbl -> do
589 |       returnIp <- lookupIp catchLbl
590 |       let catchContext =
591 |             CatchContext
592 |               { catchModule = emodModNameAtom (pEModule p)
593 |               , catchIp = returnIp
594 |               , catchCallStackLength = length (pStack p)
595 |               , catchActiveYRegs = length (pYreg p)
596 |               }
597 |       writeDestination (Destination (OperandYReg dest)) (EString "catch label!")
598 |       updateCatches (catchContext:)
599 |       continue
600 |     Try y l -> handleOp (Catch y l)
601 |     CatchEnd (YReg catchSrc) -> do
602 |       popCatch
603 |       -- TODO: shrink yregs?
604 |       writeDestination (Destination (OperandYReg catchSrc)) ENil
605 |       r <- readSource (Source (OperandXReg 0))
606 |       when (isNonValue r) $ do
607 |         x1 <- readSource (Source (OperandXReg 1))
608 |         if (x1 == EAtom AT.am_throw)
609 |           then writeDestination (Destination (OperandXReg 0)) =<< readSource (Source (OperandXReg 2))
610 |           else do
611 |             when (x1 == EAtom AT.am_error) $ do
612 |               Just st <- getsProcess pStackTrace
613 |               writeDestination (Destination (OperandXReg 2)) st
614 |             x2 <- readSource (Source (OperandXReg 2))
615 |             writeDestination (Destination (OperandXReg 0))
616 |               (ETuple [EAtom AT.am_EXIT, x2])
617 |       continue
618 | 
619 |     TryEnd dst -> do
620 |       popCatch
621 |       writeDestination dst ENil
622 |       r <- readSource (Source (OperandXReg 0))
623 |       when (isNonValue r) $ do
624 |         readSource (Source (OperandXReg 1)) >>= writeDestination (Destination (OperandXReg 0))
625 |         readSource (Source (OperandXReg 2)) >>= writeDestination (Destination (OperandXReg 1))
626 |         readSource (Source (OperandXReg 3)) >>= writeDestination (Destination (OperandXReg 2))
627 |       continue
628 |     TryCase dst -> handleOp (TryEnd dst)
629 | 
630 |     {- Faults -}
631 |     CaseEnd nonMatchingClauseSrc -> do -- a case expression has ended without a match.
632 |       t <- readSource nonMatchingClauseSrc
633 |       fault t (ExcError CaseClause)
634 |     IfEnd ->
635 |       fault ENil (ExcError IfClause)
636 | 
637 |     _ -> error (show op0)
638 |   where
639 |     getOp = getsProcess $ \p -> opAtIp (emodCode (pEModule p)) (pIp p)
640 |     deallocateY n = modifyProcess (\p -> p { pYreg = drop (fromIntegral n) (pYreg p) })
641 |     updateStack f = modifyProcess (\p -> p { pStack = f (pStack p)})
642 |     updateCatches f = modifyProcess (\p -> p { pCatches = f (pCatches p) })
643 |     setXRegs x_regs = modifyProcess (\p -> p { pXreg = x_regs})
644 |     bif_binop f op1 op2 dest = do
645 |       value1 <- readSource op1
646 |       value2 <- readSource op2
647 |       writeDestination dest (f value1 value2)
648 |     bif_plus (EInteger x) (EInteger y) = EInteger (x+y)
649 |     bif_plus x y = error (show x ++ " + " ++ show y)
650 |     bif_minus (EInteger x) (EInteger y) = EInteger (x-y)
651 |     bif_minus x y = error (show x ++ " - " ++ show y)
652 |     bif_mult (EInteger x) (EInteger y) = EInteger (x*y)
653 |     bif_mult x y = error (show x ++ " * " ++ show y)
654 |     lookupIp (OperandLabl label) = do
655 |       p <- getProcess
656 |       case lookup label (emodLabelToIp (pEModule p)) of
657 |         Nothing -> error $ "tried to lookup label that does not exist: " ++ show label
658 |         Just ip -> return ip
659 |     gotoLabel label = gotoIp =<< lookupIp label
660 |     gotoIp ip = modifyProcess (\p -> p { pIp = ip })
661 |     ret = return Nothing
662 | 


--------------------------------------------------------------------------------