-----------------------------------------------------------------------------
--
-- 			 Compiling Exceptions Correctly
--
--                        Graham Hutton and Joel Wright
--                          University of Nottingham
--
--                                February 2005
--
-----------------------------------------------------------------------------



-----------------------------------------------------------------------------
-- Expressions
-----------------------------------------------------------------------------

data Expr 			=  Val Int | Add Expr Expr |
			 	   Throw | Catch Expr Expr
				   deriving Show

eval            		:: Expr -> Maybe Int
eval (Val n)     		=  Just n
eval (Add x y)   		=  case eval x of
                      	      	      Nothing -> Nothing
                      	      	      Just n  -> case eval y of
                         	         Nothing -> Nothing
  		                         Just m  -> Just (n+m)
eval (Throw)     		=  Nothing
eval (Catch x h) 		=  case eval x of
                      	              Nothing -> eval h
                      	              Just n  -> Just n

-----------------------------------------------------------------------------
-- Compiler
-----------------------------------------------------------------------------

type Code  			=  [Op]

data Op                       	=  PUSH Int | ADD | THROW | MARK Loc |
				   UNMARK | LABEL Loc | JUMP Loc
				   deriving Show

type Loc                     	=  Int

fresh                         	:: Loc -> Loc
fresh a                       	=  a+1

comp                          	:: Loc -> Expr -> Code
comp a e                      	=  fst (compile a e)

compile                       	:: Loc -> Expr -> (Code,Loc)
compile a (Val n)             	=  ([PUSH n], a)
compile a (Add x y)           	=  (xs ++ ys ++ [ADD], c)
                               	   where
                                      (xs,b) = compile a x
                                      (ys,c) = compile b y
compile a (Throw)             	=  ([THROW], a)
compile a (Catch x h)         	=  ([MARK a] ++ xs ++ [UNMARK, JUMP b,
                                    LABEL a] ++ hs ++ [LABEL b], e)
                                   where
                                      b      = fresh a
                                      c      = fresh b
                                      (xs,d) = compile c x
                                      (hs,e) = compile d h

-----------------------------------------------------------------------------
-- Virtual machine
-----------------------------------------------------------------------------

type Stack                    	=  [Item]

data Item                     	=  VAL Int | HAN Loc
				   deriving Show

exec                          	:: Stack -> Code -> Stack
exec s []                     	=  s
exec s (PUSH n : ops)         	=  exec (VAL n : s) ops
exec s (ADD : ops)            	=  case s of
                                      (VAL m : VAL n : s') ->
 				         exec (VAL (n+m) : s') ops
exec s (THROW : ops)          	=  unwind s ops
exec s (MARK a : ops)           =  exec (HAN a : s) ops
exec s (UNMARK : ops)         	=  case s of
				      (x : HAN _ : s') ->
                                         exec (x:s') ops
exec s (LABEL _ : ops)          =  exec s ops
exec s (JUMP a : ops)           =  exec s (jump a ops)

unwind 				:: Stack -> Code -> Stack
unwind []          _      	=  []
unwind (VAL _ : s) ops 		=  unwind s ops
unwind (HAN a : s) ops     	=  exec s (jump a ops)

jump                            :: Loc -> Code -> Code
jump _ []                       =  []
jump a (LABEL b : ops)          =  if a == b then ops else jump a ops
jump a (_       : ops)          =  jump a ops

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