Remove javaGen; part of trac #2243

1 files changed, 0 insertions, 1173 deletions

diff --git a/compiler/javaGen/JavaGen.lhs b/compiler/javaGen/JavaGen.lhs
deleted file mode 100644
index 513879a876..0000000000
--- a/compiler/javaGen/JavaGen.lhs
+++ /dev/null
@@ -1,1173 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
-%
-\section{Generate Java}
-
-Name mangling for Java.
-~~~~~~~~~~~~~~~~~~~~~~
-
-Haskell has a number of namespaces. The Java translator uses
-the standard Haskell mangles (see OccName.lhs), and some extra
-mangles.
-
-All names are hidden inside packages.
-
-module name:
-  - becomes a first level java package.
-  - can not clash with java, because haskell modules are upper case,
-     java default packages are lower case.
-
-function names: 
-  - these turn into classes
-  - java keywords (eg. private) have the suffix "zdk" ($k) added.
-
-data *types*
-  - These have a base class, so need to appear in the 
-    same name space as other object. for example data Foo = Foo
-  - We add a postfix to types: "zdc" ($c)
-  - Types are upper case, so never clash with keywords
-
-data constructors
-  - There are tWO classes for each Constructor
-   (1) - Class with the payload extends the relevent datatype baseclass.
-       - This class has the prefix zdw ($w)
-   (2) - Constructor *wrapper* just use their own name.
-    - Constructors are upper case, so never clash with keywords
-    - So Foo would become 2 classes.
-	* Foo		-- the constructor wrapper
-	* zdwFoo	-- the worker, with the payload
-
-
-$i  for instances.
-$k  for keyword nameclash avoidance.
-
-\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
-module JavaGen( javaGen ) where
-
-import Java
-
-import Literal	( Literal(..) )
-import Id	( Id, isDataConWorkId_maybe, isId, idName, isDeadBinder, idPrimRep
-		, isPrimOpId_maybe )
-import Name	( NamedThing(..), getOccString, isExternalName, isInternalName
-		, nameModule )
-import PrimRep  ( PrimRep(..) )
-import DataCon	( DataCon, dataConRepArity, dataConRepArgTys, dataConWorkId )
-import qualified Type
-import qualified CoreSyn
-import CoreSyn	( CoreBind, CoreExpr, CoreAlt, CoreBndr,
-		  Bind(..), AltCon(..), collectBinders, isValArg
-		)
-import TysWiredIn	( boolTy, trueDataCon, falseDataCon )
-import qualified CoreUtils
-import Module	( Module, moduleString )
-import TyCon	( TyCon, isDataTyCon, tyConDataCons )
-import Outputable
-
-import Maybe
-import PrimOp
-import Util     ( lengthIs, notNull )
-
-#include "HsVersions.h"
-
-\end{code}
-
-
-\begin{code}
-javaGen :: Module -> [Module] -> [TyCon] -> [CoreBind] -> CompilationUnit
-
-javaGen mod import_mods tycons binds
-  = liftCompilationUnit package
-  where
-    decls = [Import "haskell.runtime.*"] ++
-	    [Import (moduleString mod) | mod <- import_mods] ++
-	    concat (map javaTyCon (filter isDataTyCon tycons)) ++ 
-	    concat (map javaTopBind binds)
-    package = Package (moduleString mod) decls
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection{Type declarations}
-%*									*
-%************************************************************************
-
-\begin{code}
-javaTyCon :: TyCon -> [Decl]
---  	public class List {}
---
---	public class $wCons extends List {
---		Object f1; Object f2
---	}
---	public class $wNil extends List {}
-
-javaTyCon tycon 
-  = tycon_jclass : concat (map constr_class constrs)
-  where
-    constrs = tyConDataCons tycon
-    tycon_jclass_jname =  javaTyConTypeName tycon ++ "zdc"
-    tycon_jclass = Class [Public] (shortName tycon_jclass_jname) [] [] []
-
-    constr_class data_con
-	= [ Class [Public] constr_jname [tycon_jclass_jname] []
-				(field_decls ++ [cons_meth,debug_meth])
-	  ]
-	where
-	  constr_jname = shortName (javaConstrWkrName data_con)
-
-	  field_names  = constrToFields data_con
-	  field_decls  = [ Field [Public] n Nothing 
-			 | n <- field_names
-			 ]
-
-	  cons_meth    = mkCons constr_jname field_names
-
-	  debug_meth   = Method [Public] (Name "toString" stringType)
-					 []
-					 []
-		       (  [ Declaration (Field [] txt Nothing) ]
-		       ++ [ ExprStatement
-				(Assign (Var txt)
-					    (mkStr
-						("( " ++ 
-						  getOccString data_con ++ 
-						  " ")
-				       	     )
-				)
-			  ]
-		       ++ [ ExprStatement
-				(Assign (Var txt)
-				   (Op (Var txt)
-				        "+" 
-				       (Op (Var n) "+" litSp)
-				   )
-				)
-			  | n <- field_names
-			  ]
-		       ++ [ Return (Op (Var txt)
-				        "+" 
-				      (mkStr ")")
-				   )
-			  ]
-		       )
-
-	  litSp    = mkStr " "
-	  txt      = Name "__txt" stringType
-	 
-
--- This checks to see the type is reasonable to call new with.
--- primitives might use a static method later.
-mkNew :: Type -> [Expr] -> Expr
-mkNew t@(PrimType primType) _  = error "new primitive -- fix it???"
-mkNew t@(Type _)            es = New t es Nothing
-mkNew _                     _  = error "new with strange arguments"
-
-constrToFields :: DataCon -> [Name]
-constrToFields cons = 
-	[ fieldName i t 
-	| (i,t) <- zip [1..] (map primRepToType
-			          (map Type.typePrimRep
-				       (dataConRepArgTys cons)
-				  )
-			     )
-	]
-
-mkCons :: TypeName -> [Name] -> Decl
-mkCons name args = Constructor [Public] name
-	[ Parameter [] n | n <- args ]
-	[ ExprStatement (Assign 
-			   (Access this n)
-			   (Var n)
-			 )
-		    | n <- args ]
-
-mkStr :: String -> Expr
-mkStr str = Literal (StringLit str)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Bindings}
-%*									*
-%************************************************************************
-
-\begin{code}
-javaTopBind :: CoreBind -> [Decl]
-javaTopBind (NonRec bndr rhs) = [java_top_bind bndr rhs]
-javaTopBind (Rec prs) 	      = [java_top_bind bndr rhs | (bndr,rhs) <- prs]
-
-java_top_bind :: Id -> CoreExpr -> Decl
--- 	public class f implements Code {
---	  public Object ENTER() { ...translation of rhs... }
---	}
-java_top_bind bndr rhs
-  = Class [Public] (shortName (javaIdTypeName bndr))
-		[] [codeName] [enter_meth]
-  where
-    enter_meth = Method [Public]
-			enterName
-			[vmArg]
-			[excName]
-			(javaExpr vmRETURN rhs)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Expressions}
-%*									*
-%************************************************************************
-
-\begin{code}
-javaVar :: Id -> Expr
-javaVar v | isExternalName (idName v) = mkNew (javaIdType v) []
-	  | otherwise	  	    =   Var (javaName v)
-
-javaLit :: Literal.Literal -> Expr
-javaLit (MachInt i)  = Literal (IntLit (fromInteger i))
-javaLit (MachChar c) = Literal (CharLit c)
-javaLit (MachStr fs) = Literal (StringLit str)
-   where
-	str = concatMap renderString (unpackFS fs) ++ "\\000"
-	-- This should really handle all the chars 0..31.
-	renderString '\NUL' = "\\000"
-	renderString other  = [other]
-
-javaLit other	     = pprPanic "javaLit" (ppr other)
-
--- Pass in the 'shape' of the result.
-javaExpr :: (Expr -> Statement) -> CoreExpr -> [Statement]
--- Generate code to apply the value of 
--- the expression to the arguments aleady on the stack
-javaExpr r (CoreSyn.Var v)   = [r (javaVar v)]
-javaExpr r (CoreSyn.Lit l)   = [r (javaLit l)]
-javaExpr r (CoreSyn.App f a) = javaApp r f [a]
-javaExpr r e@(CoreSyn.Lam _ _) = javaLam r (collectBinders e)
-javaExpr r (CoreSyn.Case e x alts) = javaCase r e x alts
-javaExpr r (CoreSyn.Let bind body) = javaBind bind ++ javaExpr r body
-javaExpr r (CoreSyn.Note _ e)	 = javaExpr r e
-
-javaCase :: (Expr -> Statement) -> CoreExpr -> Id -> [CoreAlt] -> [Statement]
--- 	case e of x { Nil      -> r1
---		      Cons p q -> r2 }
--- ==>
---	final Object x = VM.WHNF(...code for e...)
---	else if x instance_of Nil {
---		...translation of r1...
---	} else if x instance_of Cons {
---		final Object p = ((Cons) x).f1
---		final Object q = ((Cons) x).f2
---		...translation of r2...
---	} else throw java.lang.Exception
-
--- This first special case happens a lot, typically
--- during dictionary deconstruction.
--- We need to access at least *one* field, to check to see
--- if we have correct constructor.
--- If we've got the wrong one, this is _|_, and the
--- casting will catch this with an exception.
-
-javaCase r e x [(DataAlt d,bs,rhs)] | notNull bs
-  = java_expr PushExpr e ++
-    [ var [Final] (javaName x)
-	          (whnf primRep (vmPOP (primRepToType primRep))) ] ++
-    bind_args d bs ++
-    javaExpr r rhs
-   where      
-     primRep = idPrimRep x
-     whnf PtrRep = vmWHNF	-- needs evaluation
-     whnf _      = id		-- anything else does notg
-
-     bind_args d bs = [var [Final] (javaName b) 
-			   (Access (Cast (javaConstrWkrType d) (javaVar x)
-				   ) f
-			   )
-		      | (b,f) <- filter isId bs `zip` (constrToFields d)
-		      , not (isDeadBinder b)
-		      ]
-   
-javaCase r e x alts
-  | isIfThenElse && isPrimCmp
-  = javaIfThenElse r (fromJust maybePrim) tExpr fExpr
-  | otherwise
-  = java_expr PushExpr e ++
-       [ var [Final] (javaName x)
-		           (whnf primRep (vmPOP (primRepToType primRep)))
-       , IfThenElse (map mk_alt con_alts) (Just default_code)
-       ]
-  where
-     isIfThenElse = CoreUtils.exprType e `Type.eqType` boolTy
-		    -- also need to check that x is not free in
-		    -- any of the branches.
-     maybePrim    = findCmpPrim e []
-     isPrimCmp    = isJust maybePrim
-     (_,_,tExpr)  = CoreUtils.findAlt (DataAlt trueDataCon) alts 
-     (_,_,fExpr)  = CoreUtils.findAlt (DataAlt falseDataCon) alts 
-
-     primRep = idPrimRep x
-     whnf PtrRep = vmWHNF	-- needs evaluation
-     whnf _      = id
-
-     (con_alts, maybe_default) = CoreUtils.findDefault alts
-     default_code = case maybe_default of
-			Nothing  -> ExprStatement (Raise excName [Literal (StringLit "case failure")])
-			Just rhs -> Block (javaExpr r rhs)
-
-     mk_alt (DataAlt d,  bs, rhs) = (instanceOf x d, Block (bind_args d bs ++ javaExpr r rhs))
-     mk_alt (LitAlt lit, bs, rhs) = (eqLit lit     , Block (javaExpr r rhs))
-
-
-     eqLit (MachInt n) = Op (Literal (IntLit n))
-
-			    "=="
-			    (Var (javaName x))
-     eqLit (MachChar n) = Op (Literal (CharLit n))
-			    "=="
-			    (Var (javaName x))
-     eqLit other       = pprPanic "eqLit" (ppr other)
-
-     bind_args d bs = [var [Final] (javaName b) 
-			   (Access (Cast (javaConstrWkrType d) (javaVar x)
-				   ) f
-			   )
-		      | (b,f) <- filter isId bs `zip` (constrToFields d)
-		      , not (isDeadBinder b)
-		      ]
-
-javaIfThenElse r cmp tExpr fExpr 
-{-
- - Now what we need to do is generate code for the if/then/else.
- - [all arguments are already check for simpleness (Var or Lit).]
- - 
- - if (<prim> arg1 arg2 arg3 ...) {
- -	trueCode
- -  } else {
- -	falseCode
- - }
- -}
- = [IfThenElse [(cmp,j_tExpr)] (Just j_fExpr)]
- where
-   j_tExpr, j_fExpr :: Statement
-   j_tExpr = Block (javaExpr r tExpr)
-   j_fExpr = Block (javaExpr r fExpr)
-
-javaBind (NonRec x rhs)
-{-
-	x = ...rhs_x...
-  ==>
-	final Object x = new Thunk( new Code() { ...code for rhs_x... } )
--}
-
-  = java_expr (SetVar name) rhs
-  where
-    name = case coreTypeToType rhs of
-	    ty@(PrimType _) -> javaName x `withType` ty
-	    _               -> javaName x `withType` codeType
-
-javaBind (Rec prs)
-{- 	rec { x = ...rhs_x...; y = ...rhs_y... }
-  ==>
-	class x implements Code {
-	  Code x, y;
-	  public Object ENTER() { ...code for rhs_x...}
-	}
-	...ditto for y...
-
-	final x x_inst = new x();
-	...ditto for y...
-
-	final Thunk x = new Thunk( x_inst );
-	...ditto for y...
-
-	x_inst.x = x;
-	x_inst.y = y;
-	...ditto for y...
--}
-  = (map mk_class prs) ++ (map mk_inst prs) ++ 
-    (map mk_thunk prs) ++ concat (map mk_knot prs)
-  where
-    mk_class (b,r) = Declaration (Class [] class_name [] [codeName] stmts)
-		   where
-		     class_name = javaIdTypeName b
-		     stmts = [Field [] (javaName b `withType` codeType) Nothing | (b,_) <- prs] ++
-			     [Method [Public] enterName [vmArg] [excName] (javaExpr vmRETURN r)]	
-
-    mk_inst (b,r) = var [Final] name (mkNew ty [])
-	where
-	   name@(Name _ ty)  = javaInstName b
-
-    mk_thunk (b,r) = var [Final] (javaName b `withType` codeType)
-			 (mkNew thunkType [Var (javaInstName b)])
-
-    mk_knot (b,_) = [ ExprStatement (Assign lhs rhs) 
-		    | (b',_) <- prs,
-		      let lhs = Access (Var (javaInstName b)) (javaName b'),
-		      let rhs = Var (javaName b')
-		    ]
-
-javaLam :: (Expr -> Statement) -> ([CoreBndr], CoreExpr) -> [Statement]
-javaLam r (bndrs, body)
-  | null val_bndrs = javaExpr r body
-  | otherwise
-  =  vmCOLLECT (length val_bndrs) this
-  ++ [var [Final] n (vmPOP t) | n@(Name _ t) <- val_bndrs]
-  ++ javaExpr r body
-  where
-    val_bndrs = map javaName (filter isId bndrs)
-
-javaApp :: (Expr -> Statement) -> CoreExpr -> [CoreExpr] -> [Statement]
-javaApp r (CoreSyn.App f a) as 
-	| isValArg a = javaApp r f (a:as)
-	| otherwise  = javaApp r f as
-javaApp r (CoreSyn.Var f) as 
-  = case isDataConWorkId_maybe f of {
-	Just dc | as `lengthIs` dataConRepArity dc
-	 -- NOTE: Saturated constructors never returning a primitive at this point
-	 --
-	 -- We push the arguments backwards, because we are using
-	 -- the (ugly) semantics of the order of evaluation of arguments,
-	 -- to avoid making up local names. Oh to have a namesupply...
-	 --
-		-> javaArgs (reverse as) ++
-		   [r (New (javaIdType f)
-			   (javaPops as)
-			   Nothing
-		       )
-		   ]
-	        | otherwise ->
-		   --  build a local 
-		   let stmts = 
-			  vmCOLLECT (dataConRepArity dc) this ++
-			[ vmRETURN
-			   (New (javaIdType f)
-				[ vmPOP ty | (Name _ ty) <- constrToFields dc ]
-				Nothing
-			    )
-			]
-		   in javaArgs (reverse as) ++ [r (newCode stmts)]
-    ; other -> java_apply r (CoreSyn.Var f) as
-    }
-	
-javaApp r f as = java_apply r f as
-
--- This means, given a expression an a list of arguments,
--- generate code for "pushing the arguments on the stack,
---  and the executing the expression."
-
-java_apply :: (Expr -> Statement) -> CoreExpr -> [CoreExpr] -> [Statement]
-java_apply r f as = javaArgs as ++ javaExpr r f
-
--- This generates statements that have the net effect
--- of pushing values (perhaps thunks) onto the stack.
-
-javaArgs :: [CoreExpr] -> [Statement]
-javaArgs args = concat [ java_expr PushExpr a | a <- args, isValArg a]
-
-javaPops :: [CoreExpr] -> [Expr]
-javaPops args = [ vmPOP (primRepToType (Type.typePrimRep (CoreUtils.exprType a)))
-		| a <- args 
-		, isValArg a
-		]
-
-
--- The result is a list of statments that have the effect of
--- pushing onto the stack (via one of the VM.PUSH* commands)
--- the argument, (or returning, or setting a variable)
--- perhaps thunked.
-
-{- This is mixing two things.
- (1) Optimizations for things like primitives, whnf calls, etc.
- (2) If something needs a thunk constructor round it.
- - Seperate them at some point!
- -}
-data ExprRetStyle = SetVar Name | PushExpr | ReturnExpr
-
-java_expr :: ExprRetStyle -> CoreExpr -> [Statement]
-java_expr _ (CoreSyn.Type t) = pprPanic "java_expr" (ppr t)
-java_expr ret e
-   | isPrimCall = [push (fromJust maybePrim)]
-	-- This is a shortcut, 
-	-- basic names and literals do not need a code block
-	-- to compute the value.
-   | isPrim primty && CoreUtils.exprIsTrivial e = javaExpr push e
-   | isPrim primty =
- 	  let expr  = javaExpr vmRETURN e
-	      code  = access (vmWHNF (newCode expr)) (primRepToType primty)
-	  in [push code]
-   | otherwise =
- 	  let expr  = javaExpr vmRETURN e
-	      code  = newCode expr
-	      code' = if CoreUtils.exprIsValue e 
-		      || CoreUtils.exprIsTrivial e 
-		      || isPrim primty
-		      then code
-		      else newThunk code
-	  in [push code']
-   where
-	maybePrim  = findFnPrim e []
-	isPrimCall = isJust maybePrim
-
-	push e = case ret of
-		  SetVar name -> var [Final] name e
-		  PushExpr -> vmPUSH e
-		  ReturnExpr -> vmRETURN e
-	corety = CoreUtils.exprType e
-	primty = Type.typePrimRep corety
-	isPrim PtrRep  = False	-- only this needs updated
-	isPrim _       = True
-
-coreTypeToType = primRepToType . Type.typePrimRep . CoreUtils.exprType
-
-renameForKeywords :: (NamedThing name) => name -> String
-renameForKeywords name 
-  | str `elem` keywords = "zdk" ++ str
-  | otherwise            = str
-  where
-	str = getOccString name
-
-keywords :: [String]
-keywords =
-	[ "return"
-	, "if"
-	, "then"
-	, "else"
-	, "class"
-	, "instance"
-	, "import"
-	, "throw"
-	, "try"
-	]
-
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Helper functions}
-%*									*
-%************************************************************************
-
-\begin{code}
-true, this,javaNull :: Expr
-this = Var thisName 
-true = Var (Name "true" (PrimType PrimBoolean))
-javaNull = Var (Name "null" objectType)
-
-vmCOLLECT :: Int -> Expr -> [Statement]
-vmCOLLECT 0 e = []
-vmCOLLECT n e = [ExprStatement 
-		    (Call varVM collectName
-			[ Literal (IntLit (toInteger n))
-			, e
-			]
-		    )
-		]
-
-vmPOP :: Type -> Expr 
-vmPOP ty = Call varVM (Name ("POP" ++ suffix ty) ty) []
-
-vmPUSH :: Expr -> Statement
-vmPUSH e = ExprStatement 
-	     (Call varVM (Name ("PUSH" ++ suffix (exprType e)) void) [e])
-
-vmRETURN :: Expr -> Statement
-vmRETURN e = Return (
-     case ty of
-	PrimType _ -> Call varVM (Name ("RETURN" ++ suffix ty)
-				       valueType
-				 ) [e]
-	_ -> e)
-  where
-	ty = exprType e
-
-var :: [Modifier] -> Name -> Expr -> Statement
-var ms field_name@(Name _ ty) value 
-   | exprType value == ty = Declaration (Field ms field_name (Just value))
-   | otherwise            = var ms field_name (Cast ty value)
-
-vmWHNF :: Expr -> Expr
-vmWHNF e = Call varVM whnfName [e]
-
-suffix :: Type -> String
-suffix (PrimType t) = primName t
-suffix _            = ""
-
-primName :: PrimType -> String
-primName PrimInt       = "int"
-primName PrimChar      = "char"
-primName PrimByte      = "byte"
-primName PrimBoolean   = "boolean"
-primName _             = error "unsupported primitive"
-
-varVM :: Expr
-varVM = Var vmName 
-
-instanceOf :: Id -> DataCon -> Expr
-instanceOf x data_con
-  = InstanceOf (Var (javaName x)) (javaConstrWkrType data_con)
-
-newCode :: [Statement] -> Expr
-newCode [Return e] = e
-newCode stmts	   = New codeType [] (Just [Method [Public] enterName [vmArg] [excName] stmts])
-
-newThunk :: Expr -> Expr
-newThunk e = New thunkType [e] Nothing
-
-vmArg :: Parameter
-vmArg = Parameter [Final] vmName
-
--- This is called with boolean compares, checking 
--- to see if we can do an obvious shortcut.
--- If there is, we return a (GOO) expression for doing this,
-
--- So if, we have case (#< x y) of { True -> e1; False -> e2 },
--- we will call findCmpFn with (#< x y), this return Just (Op x "<" y)
-
-findCmpPrim :: CoreExpr -> [Expr] -> Maybe Expr
-findCmpPrim (CoreSyn.App f a) as =
-     case a of
-	CoreSyn.Var v -> findCmpPrim f (javaVar v:as)
-	CoreSyn.Lit l -> findCmpPrim f (javaLit l:as)
-	_ -> Nothing
-findCmpPrim (CoreSyn.Var p)   as = 
-	case isPrimOpId_maybe p of
-	  Just prim -> find_cmp_prim prim as
-	  Nothing   -> Nothing
-findCmpPrim _                 as = Nothing
-
-find_cmp_prim cmpPrim args@[a,b] = 
-   case cmpPrim of
-     IntGtOp -> fn ">"
-     IntGeOp -> fn ">="
-     IntEqOp -> fn "=="
-     IntNeOp -> fn "/="
-     IntLtOp -> fn "<"
-     IntLeOp -> fn "<="
-     _ -> Nothing
-  where
-	fn op = Just (Op a op b)
-find_cmp_prim _ _ = Nothing
-
-findFnPrim :: CoreExpr -> [Expr] -> Maybe Expr
-findFnPrim (CoreSyn.App f a) as =
-     case a of
-	CoreSyn.Var v -> findFnPrim f (javaVar v:as)
-	CoreSyn.Lit l -> findFnPrim f (javaLit l:as)
-	_ -> Nothing
-findFnPrim (CoreSyn.Var p)   as = 
-	case isPrimOpId_maybe p of
-	  Just prim -> find_fn_prim prim as
-	  Nothing   -> Nothing
-findFnPrim _                 as = Nothing
-
-find_fn_prim cmpPrim args@[a,b] = 
-   case cmpPrim of
-     IntAddOp -> fn "+"
-     IntSubOp -> fn "-"
-     IntMulOp -> fn "*"
-     _ -> Nothing
-  where
-	fn op = Just (Op a op b)
-find_fn_prim _ _ = Nothing
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Haskell to Java Types}
-%*									*
-%************************************************************************
-
-\begin{code}
-exprType (Var (Name _ t)) = t
-exprType (Literal lit)    = litType lit
-exprType (Cast t _)       = t
-exprType (New t _ _)      = t
-exprType (Call _ (Name _ t) _) = t
-exprType (Access _ (Name _ t)) = t
-exprType (Raise t _)           = error "do not know the type of raise!"
-exprType (Op _ op _) | op `elem` ["==","/=","<","<=","=>",">"]
-		     = PrimType PrimBoolean
-exprType (Op x op _) | op `elem` ["+","-","*"]
-		     = exprType x
-exprType expr = error ("can't figure out an expression type: " ++ show expr)
-
-litType (IntLit i)    = PrimType PrimInt
-litType (CharLit i)   = PrimType PrimChar
-litType (StringLit i) = stringType	-- later, might use char array?
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Name mangling}
-%*									*
-%************************************************************************
-
-\begin{code}
-codeName, excName, thunkName :: TypeName
-codeName  = "haskell.runtime.Code"
-thunkName = "haskell.runtime.Thunk"
-excName   = "java.lang.Exception"
-
-enterName, vmName,thisName,collectName, whnfName :: Name
-enterName   = Name "ENTER"   objectType
-vmName      = Name "VM"      vmType
-thisName    = Name "this"    (Type "<this>")
-collectName = Name "COLLECT" void
-whnfName    = Name "WHNF"    objectType
-
-fieldName :: Int -> Type -> Name	-- Names for fields of a constructor
-fieldName n ty = Name ("f" ++ show n) ty
-
-withType :: Name -> Type -> Name
-withType (Name n _) t = Name n t
-
--- This maps (local only) names Ids to Names, 
--- using the same string as the Id.
-javaName :: Id -> Name
-javaName n 
-  | isExternalName (idName n) = error "useing javaName on global"
-  | otherwise = Name (getOccString n)
-		     (primRepToType (idPrimRep n))
-
--- TypeName's are almost always global. This would typically return something
--- like Test.foo or Test.Foozdc or PrelBase.foldr.
--- Local might use locally bound types, (which do not have '.' in them).
-
-javaIdTypeName :: Id -> TypeName
-javaIdTypeName n
-    | isInternalName n' = renameForKeywords n'
-    | otherwise      = moduleString (nameModule n') ++ "." ++ renameForKeywords n'
-  where
-	     n' = getName n
-
--- There is no such thing as a local type constructor.
-
-javaTyConTypeName :: TyCon -> TypeName
-javaTyConTypeName n = (moduleString (nameModule n') ++ "." ++ renameForKeywords n')
-  where
-	     n' = getName n
-
--- this is used for getting the name of a class when defining it.
-shortName :: TypeName -> TypeName
-shortName = reverse . takeWhile (/= '.') . reverse
-
--- The function that makes the constructor name
--- The constructor "Foo ..." in module Test,
--- would return the name "Test.Foo".
-
-javaConstrWkrName :: DataCon -> TypeName
-javaConstrWkrName = javaIdTypeName . dataConWorkId
-
--- Makes x_inst for Rec decls
--- They are *never* is primitive
--- and always have local (type) names.
-javaInstName :: Id -> Name
-javaInstName n = Name (renameForKeywords n ++ "zdi_inst")
-		      (Type (renameForKeywords n))
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Types and type mangling}
-%*									*
-%************************************************************************
-
-\begin{code}
--- Haskell RTS types
-codeType, thunkType, valueType :: Type
-codeType   = Type codeName
-thunkType  = Type thunkName
-valueType  = Type "haskell.runtime.Value"
-vmType     = Type "haskell.runtime.VMEngine"
-
--- Basic Java types
-objectType, stringType :: Type
-objectType = Type "java.lang.Object"
-stringType = Type "java.lang.String"
-
-void :: Type
-void = PrimType PrimVoid
-
-inttype :: Type
-inttype = PrimType PrimInt
-
-chartype :: Type
-chartype = PrimType PrimChar
-
-bytetype :: Type
-bytetype = PrimType PrimByte
-
--- This lets you get inside a possible "Value" type,
--- to access the internal unboxed object.
-access :: Expr -> Type -> Expr
-access expr (PrimType prim) = accessPrim (Cast valueType expr) prim
-access expr other           = expr
-
-accessPrim expr PrimInt  = Call expr (Name "intValue" inttype) []
-accessPrim expr PrimChar = Call expr (Name "charValue" chartype) []
-accessPrim expr PrimByte = Call expr (Name "byteValue" bytetype) []
-accessPrim expr other    = pprPanic "accessPrim" (text (show other))
-
--- This is where we map from typename to types,
--- allowing to match possible primitive types.
-mkType :: TypeName -> Type
-mkType "PrelGHC.Intzh"  = inttype
-mkType "PrelGHC.Charzh" = chartype
-mkType other            = Type other
-
--- Turns a (global) Id into a Type (fully qualified name).
-javaIdType :: Id -> Type
-javaIdType = mkType . javaIdTypeName
-
-javaLocalIdType :: Id -> Type
-javaLocalIdType = primRepToType . idPrimRep
-
-primRepToType ::PrimRep -> Type
-primRepToType PtrRep  = objectType
-primRepToType IntRep  = inttype
-primRepToType CharRep = chartype
-primRepToType Int8Rep = bytetype
-primRepToType AddrRep = objectType
-primRepToType other   = pprPanic "primRepToType" (ppr other)
-
--- The function that makes the constructor name
-javaConstrWkrType :: DataCon -> Type
-javaConstrWkrType con = Type (javaConstrWkrName con)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Class Lifting}
-%*									*
-%************************************************************************
-
-This is a very simple class lifter. It works by carrying inwards a
-list of bound variables (things that might need to be passed to a
-lifted inner class). 
- * Any variable references is check with this list, and if it is
-   bound, then it is not top level, external reference. 
- * This means that for the purposes of lifting, it might be free
-   inside a lifted inner class.
- * We remember these "free inside the inner class" values, and 
-   use this list (which is passed, via the monad, outwards)
-   when lifting.
-
-\begin{code}
-type Bound = [Name]
-type Frees = [Name]
-
-combine :: [Name] -> [Name] -> [Name]
-combine []           names          = names
-combine names        []             = names
-combine (name:names) (name':names') 
-	| name < name' = name  : combine names (name':names')
-	| name > name' = name' : combine (name:names) names'
-	| name == name = name  : combine names names'
-	| otherwise    = error "names are not a total order"
-
-both :: [Name] -> [Name] -> [Name]
-both []           names          = []
-both names        []             = []
-both (name:names) (name':names') 
-	| name < name' = both names (name':names')
-	| name > name' = both (name:names) names'
-	| name == name = name  : both names names'
-	| otherwise    = error "names are not a total order"
-
-combineEnv :: Env -> [Name] -> Env
-combineEnv (Env bound env) new = Env (bound `combine` new) env
-
-addTypeMapping :: TypeName -> TypeName -> [Name] -> Env -> Env
-addTypeMapping origName newName frees (Env bound env)
-	= Env bound ((origName,(newName,frees)) : env)
-
--- This a list of bound vars (with types)
--- and a mapping from old class name 
---     to inner class name (with a list of frees that need passed
---	                    to the inner class.)
-
-data Env = Env Bound [(TypeName,(TypeName,[Name]))]
-
-newtype LifterM a = 
-  	LifterM { unLifterM ::
-		     TypeName ->		-- this class name
-		     Int -> 			-- uniq supply
-			  ( a			--  *
-			    , Frees		-- frees
-			    , [Decl]		-- lifted classes
-			    , Int		-- The uniqs
-			    )
-		}
-
-instance Monad LifterM where
-	return a = LifterM (\ n s -> (a,[],[],s))
-	(LifterM m) >>= fn = LifterM (\ n s ->
-	  case m n s of
-	    (a,frees,lifted,s) 
-	         -> case unLifterM (fn a) n s of
-	 	     (a,frees2,lifted2,s) -> ( a
-					     , combine frees frees2
-					     , lifted ++ lifted2
-					     , s)
-	  )
-
-liftAccess :: Env -> Name -> LifterM ()
-liftAccess env@(Env bound _) name 
-	| name `elem` bound = LifterM (\ n s -> ((),[name],[],s))
-	| otherwise         = return ()
-
-scopedName :: TypeName -> LifterM a -> LifterM a
-scopedName name (LifterM m) =
-   LifterM (\ _ s -> 
-      case m name 1 of
-	(a,frees,lifted,_) -> (a,frees,lifted,s)
-      )
-
-genAnonInnerClassName :: LifterM TypeName
-genAnonInnerClassName = LifterM (\ n s ->
-	( n ++ "$" ++ show s
-	, []
-	, []
-	, s + 1
-	)
-    )
-
-genInnerClassName :: TypeName -> LifterM TypeName
-genInnerClassName name = LifterM (\ n s ->
-	( n ++ "$" ++ name 
-	, []
-	, []
-	, s
-	)
-    )
-
-getFrees  :: LifterM a -> LifterM (a,Frees)
-getFrees (LifterM m) = LifterM (\ n s ->
-	case m n s of
-	  (a,frees,lifted,n) -> ((a,frees),frees,lifted,n)
-    )
-
-rememberClass :: Decl -> LifterM ()
-rememberClass decl = LifterM (\ n s -> ((),[],[decl],s))
-
-
-liftCompilationUnit :: CompilationUnit -> CompilationUnit
-liftCompilationUnit (Package name ds) = 
-    Package name (concatMap liftCompilationUnit' ds)
-
-liftCompilationUnit' :: Decl -> [Decl]
-liftCompilationUnit' decl = 
-    case unLifterM (liftDecls True (Env [] []) [decl]) [] 1 of
-      (ds,_,ds',_) -> ds ++ ds'
-
-
--- The bound vars for the current class have
--- already be captured before calling liftDecl,
--- because they are in scope everywhere inside the class.
-
-liftDecl :: Bool -> Env -> Decl -> LifterM Decl
-liftDecl = \ top env decl ->
-  case decl of
-    { Import n -> return (Import n)
-    ; Field mfs n e -> 
-      do { e <- liftMaybeExpr env e
-	 ; return (Field mfs (liftName env n) e)
-	 }
-    ; Constructor mfs n as ss -> 
-      do { let newBound = getBoundAtParameters as
-	 ; (ss,_) <- liftStatements (combineEnv env newBound) ss
-	 ; return (Constructor mfs n (liftParameters env as) ss)
-	 }
-    ; Method mfs n as ts ss -> 
-      do { let newBound = getBoundAtParameters as
-	 ; (ss,_) <- liftStatements (combineEnv env newBound) ss
-	 ; return (Method mfs (liftName env n) (liftParameters env as) ts ss)
-	 }
-    ; Comment s -> return (Comment s)
-    ; Interface mfs n is ms -> error "interfaces not supported"
-    ; Class mfs n x is ms -> 
-      do { let newBound = getBoundAtDecls ms
-	 ; ms <- scopedName n
-		    (liftDecls False (combineEnv env newBound) ms)
-	 ; return (Class mfs n x is ms)
-	 }
-    }
-
-liftDecls :: Bool -> Env -> [Decl] -> LifterM [Decl]
-liftDecls top env = mapM (liftDecl top env)
-
-getBoundAtDecls :: [Decl] -> Bound
-getBoundAtDecls = foldr combine [] . map getBoundAtDecl
-
-getBoundAtDecl :: Decl -> Bound
-getBoundAtDecl (Field _ n _) = [n]
-getBoundAtDecl _             = []
-
-getBoundAtParameters :: [Parameter] -> Bound
-getBoundAtParameters = foldr combine [] . map getBoundAtParameter
-
--- TODO
-getBoundAtParameter :: Parameter -> Bound
-getBoundAtParameter (Parameter _ n) = [n]
-
-
-liftStatement :: Env -> Statement -> LifterM (Statement,Env)
-liftStatement = \ env stmt ->
-  case stmt of 
-    { Skip -> return (stmt,env)
-    ; Return e -> do { e <- liftExpr env e
-		     ; return (Return e,env)
-		     } 
-    ; Block ss -> do { (ss,env) <- liftStatements env ss
-		     ; return (Block ss,env)
-		     }
-    ; ExprStatement e -> do { e <- liftExpr env e
-			    ; return (ExprStatement e,env)
-			    }
-    ; Declaration decl@(Field mfs n e) ->
-      do { e <- liftMaybeExpr env e
-	 ; return ( Declaration (Field mfs (liftName env n) e)
-		  , env `combineEnv` getBoundAtDecl decl
-		  )
-	 }
-    ; Declaration decl@(Class mfs n x is ms) ->
-      do { innerName <- genInnerClassName n
-	 ; frees <- liftClass env innerName ms x is
-	 ; return ( Declaration (Comment ["lifted " ++  n])
-		  , addTypeMapping n innerName frees env
-		  )
-	 }
-    ; Declaration d -> error "general Decl not supported"
-    ; IfThenElse ecs s -> ifthenelse env ecs s
-    ; Switch e as d -> error "switch not supported"
-    } 
-
-ifthenelse :: Env 
-	   -> [(Expr,Statement)] 
-	   -> (Maybe Statement) 
-	   -> LifterM (Statement,Env)
-ifthenelse env pairs may_stmt =
-  do { let (exprs,stmts) = unzip pairs
-     ; exprs <- liftExprs env exprs
-     ; (stmts,_) <- liftStatements env stmts
-     ; may_stmt <- case may_stmt of
-		      Just stmt -> do { (stmt,_) <- liftStatement env stmt
-				      ; return (Just stmt)
-				      }
-		      Nothing -> return Nothing
-     ; return (IfThenElse (zip exprs stmts) may_stmt,env)
-     }
-
-liftStatements :: Env -> [Statement] -> LifterM ([Statement],Env)
-liftStatements env []     = return ([],env)
-liftStatements env (s:ss) = 
-	do { (s,env) <- liftStatement env s
-	   ; (ss,env) <- liftStatements env ss
-	   ; return (s:ss,env) 
-	   }
-
-liftExpr :: Env -> Expr -> LifterM Expr
-liftExpr = \ env expr ->
- case expr of
-   { Var n -> do { liftAccess env n 
-		 ; return (Var (liftName env n))
-	         }
-   ; Literal l -> return expr
-   ; Cast t e -> do { e <- liftExpr env e
-	            ; return (Cast (liftType env t) e) 
-	            }
-   ; Access e n -> do { e <- liftExpr env e 
-			-- do not consider n as an access, because
-			-- this is a indirection via a reference
-		      ; return (Access e n) 
-		      }
-   ; Assign l r -> do { l <- liftExpr env l
-		      ; r <- liftExpr env r
-		      ; return (Assign l r)
-		      } 
-   ; InstanceOf e t -> do { e <- liftExpr env e
-			  ; return (InstanceOf e (liftType env t))
-			  }	    
-   ; Raise n es -> do { es <- liftExprs env es
-		      ; return (Raise n es)
-		      }
-   ; Call e n es -> do { e <- liftExpr env e
-		       ; es <- mapM (liftExpr env) es
-		       ; return (Call e n es) 
-		       }
-   ; Op e1 o e2 -> do { e1 <- liftExpr env e1
-		      ;	e2 <- liftExpr env e2
-		      ; return (Op e1 o e2)
-		      }
-   ; New n es ds -> new env n es ds
-   }
-
-liftParameter env (Parameter ms n) = Parameter ms (liftName env n)
-liftParameters env = map (liftParameter env)
-
-liftName env (Name n t) = Name n (liftType env t)
-
-liftExprs :: Env -> [Expr] -> LifterM [Expr]
-liftExprs = mapM . liftExpr
-
-
-liftMaybeExpr :: Env -> (Maybe Expr) -> LifterM (Maybe Expr)
-liftMaybeExpr env Nothing     = return Nothing
-liftMaybeExpr env (Just stmt) = do { stmt <- liftExpr env stmt
-				     ; return (Just stmt)
-				     }
-
-
-
-new :: Env -> Type -> [Expr] -> Maybe [Decl] -> LifterM Expr
-new env@(Env _ pairs) typ args Nothing =
-  do { args <- liftExprs env args
-     ; return (liftNew env typ args)
-     }
-new env typ [] (Just inner) =
-  -- anon. inner class
-  do { innerName <- genAnonInnerClassName 
-     ; frees <- liftClass env innerName inner [] [unType typ]
-     ; return (New (Type (innerName)) 
-	           (map Var frees) 
-	            Nothing)
-     }
-  where unType (Type name) = name
-	unType _             = error "incorrect type style"
-new env typ _ (Just inner) = error "cant handle inner class with args"
-
-
-liftClass :: Env -> TypeName -> [Decl] -> [TypeName] -> [TypeName] -> LifterM [ Name ]
-liftClass env@(Env bound _) innerName inner xs is =
-  do { let newBound = getBoundAtDecls inner
-     ; (inner,frees) <- 
-	   getFrees (liftDecls False (env `combineEnv` newBound) inner)
-     ; let trueFrees = filter (\ (Name xs _) -> xs /= "VM") (both frees bound)
-     ; let freeDefs = [ Field [Final] n Nothing | n <- trueFrees ]
-     ; let cons = mkCons innerName trueFrees
-     ; let innerClass = Class [] innerName xs is (freeDefs ++ [cons] ++ inner)
-     ; rememberClass innerClass
-     ; return trueFrees
-     }
-
-liftType :: Env -> Type -> Type
-liftType (Env _ env) typ@(Type name) 
-   = case lookup name env of
-	Nothing     -> typ
-	Just (nm,_) -> Type nm
-liftType _           typ = typ
-
-liftNew :: Env -> Type -> [Expr] -> Expr
-liftNew (Env _ env) typ@(Type name) exprs
-   = case lookup name env of
-	Nothing                     -> New typ exprs Nothing
-	Just (nm,args) | null exprs 
-		-> New (Type nm) (map Var args) Nothing
-	_ -> error "pre-lifted constructor with arguments"
-\end{code}