--- /dev/null
+%
+% (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}
+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}
projects / ghc-hetmet.git / blobdiff