2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section{Generate Java}
7 module JavaGen( javaGen ) where
11 import Literal ( Literal(..) )
12 import Id ( Id, isDataConId_maybe, isId, idName, isDeadBinder )
13 import Name ( NamedThing(..), getOccString, isGlobalName )
14 import DataCon ( DataCon, dataConRepArity, dataConId )
15 import qualified CoreSyn
16 import CoreSyn ( CoreBind, CoreExpr, CoreAlt, CoreBndr,
17 Bind(..), Alt, AltCon(..), collectBinders, isValArg
19 import CoreUtils( exprIsValue, exprIsTrivial )
20 import Module ( Module, moduleString )
21 import TyCon ( TyCon, isDataTyCon, tyConDataCons )
24 #include "HsVersions.h"
30 javaGen :: Module -> [Module] -> [TyCon] -> [CoreBind] -> CompilationUnit
32 javaGen mod import_mods tycons binds
33 = liftCompilationUnit package
35 decls = [Import [moduleString mod] | mod <- import_mods] ++
36 concat (map javaTyCon (filter isDataTyCon tycons)) ++
37 concat (map javaTopBind binds)
38 package = Package (moduleString mod) decls
42 %************************************************************************
44 \subsection{Type declarations}
46 %************************************************************************
49 javaTyCon :: TyCon -> [Decl]
50 -- public class List {}
52 -- public class $wCons extends List {
53 -- Object f1; Object f2
55 -- public class $wNil extends List {}
58 = tycon_jclass : map constr_class constrs
60 constrs = tyConDataCons tycon
61 tycon_jclass_jname = javaName tycon
62 tycon_jclass = Class [Public] tycon_jclass_jname [] [] []
65 = Class [Public] constr_jname [tycon_jclass_jname] [] field_decls
67 constr_jname = javaConstrWkrName data_con
68 constr_jtype = javaConstrWkrType data_con
69 enter_meth = Method [Public] objectType enterName [] stmts
70 n_val_args = dataConRepArity data_con
71 field_names = map fieldName [1..n_val_args]
72 field_decls = [Field [Public] objectType f Nothing | f <- field_names]
73 stmts = vmCOLLECT n_val_args (Var thisName) ++
74 [var [Final] objectType f vmPOP | f <- field_names] ++
75 [Return (New constr_jtype (map Var field_names) Nothing)]
78 %************************************************************************
82 %************************************************************************
85 javaTopBind :: CoreBind -> [Decl]
86 javaTopBind (NonRec bndr rhs) = [java_top_bind bndr rhs]
87 javaTopBind (Rec prs) = [java_top_bind bndr rhs | (bndr,rhs) <- prs]
89 java_top_bind :: Id -> CoreExpr -> Decl
90 -- public class f implements Code {
91 -- public Object ENTER() { ...translation of rhs... }
93 java_top_bind bndr rhs
94 = Class [Public] (javaName bndr) [] [codeName] [enter_meth]
96 enter_meth = Method [Public] objectType enterName [] (javaExpr rhs)
100 %************************************************************************
102 \subsection{Expressions}
104 %************************************************************************
107 javaVar :: Id -> Expr
108 javaVar v | isGlobalName (idName v) = New (javaType v) [] Nothing
109 | otherwise = Var (javaName v)
111 javaLit :: Literal.Literal -> Lit
112 javaLit (MachInt i) = UIntLit (fromInteger i)
113 javaLit (MachChar c) = UCharLit c
114 javaLit other = pprPanic "javaLit" (ppr other)
116 javaExpr :: CoreExpr -> [Statement]
117 -- Generate code to apply the value of
118 -- the expression to the arguments aleady on the stack
119 javaExpr (CoreSyn.Var v) = [Return (javaVar v)]
120 javaExpr (CoreSyn.Lit l) = [Return (Literal (javaLit l))]
121 javaExpr (CoreSyn.App f a) = javaApp f [a]
122 javaExpr e@(CoreSyn.Lam _ _) = javaLam (collectBinders e)
123 javaExpr (CoreSyn.Case e x alts) = javaCase e x alts
124 javaExpr (CoreSyn.Let bind body) = javaBind bind ++ javaExpr body
125 javaExpr (CoreSyn.Note _ e) = javaExpr e
127 javaCase :: CoreExpr -> Id -> [CoreAlt] -> [Statement]
128 -- case e of x { Nil -> r1
131 -- final Object x = VM.WHNF(...code for e...)
132 -- else if x instance_of Nil {
133 -- ...translation of r1...
134 -- } else if x instance_of Cons {
135 -- final Object p = ((Cons) x).f1
136 -- final Object q = ((Cons) x).f2
137 -- ...translation of r2...
138 -- } else return null
141 = [var [Final] objectType (javaName x) (vmWHNF (javaArg e)),
142 IfThenElse (map mk_alt alts) Nothing]
144 mk_alt (DEFAULT, [], rhs) = (true, Block (javaExpr rhs))
145 mk_alt (DataAlt d, bs, rhs) = (instanceOf x d, Block (bind_args d bs ++ javaExpr rhs))
146 mk_alt alt@(LitAlt _, _, _) = pprPanic "mk_alt" (ppr alt)
148 bind_args d bs = [var [Final] objectType (javaName b)
149 (Access (Cast (javaConstrWkrType d) (javaVar x)) f)
150 | (b, f) <- filter isId bs `zip` map fieldName [1..],
154 javaBind (NonRec x rhs)
158 final Object x = new Thunk( new Code() { ...code for rhs_x... } )
160 = [var [Final] objectType (javaName x) (javaArg rhs)]
163 {- rec { x = ...rhs_x...; y = ...rhs_y... }
165 class x implements Code {
167 public Object ENTER() { ...code for rhs_x...}
171 final x x_inst = new x();
174 final Thunk x = new Thunk( x_inst );
181 = (map mk_class prs) ++ (map mk_inst prs) ++
182 (map mk_thunk prs) ++ concat (map mk_knot prs)
184 mk_class (b,r) = Declaration (Class [] (javaName b) [] [codeName] stmts)
186 stmts = [Field [] codeType (javaName b) Nothing | (b,_) <- prs] ++
187 [Method [Public] objectType enterName [] (javaExpr r)]
189 mk_inst (b,r) = var [Final] (javaType b) (javaInstName b)
190 (New (javaType b) [] Nothing)
192 mk_thunk (b,r) = var [Final] thunkType (javaName b)
193 (New thunkType [Var (javaInstName b)] Nothing)
195 mk_knot (b,_) = [ExprStatement (Assign lhs rhs)
197 let lhs = Access (Var (javaInstName b)) (javaName b'),
198 let rhs = Var (javaName b')
201 javaLam :: ([CoreBndr], CoreExpr) -> [Statement]
202 javaLam (bndrs, body)
203 | null val_bndrs = javaExpr body
205 = vmCOLLECT (length val_bndrs) (Var thisName)
206 ++ [var [Final] objectType (javaName n) vmPOP | n <- val_bndrs]
209 val_bndrs = filter isId bndrs
211 javaApp :: CoreExpr -> [CoreExpr] -> [Statement]
212 javaApp (CoreSyn.App f a) as = javaApp f (a:as)
213 javaApp (CoreSyn.Var f) as
214 = case isDataConId_maybe f of {
215 Just dc | length as == dataConRepArity dc
216 -> -- Saturated constructors
217 [Return (New (javaType f) (javaArgs as) Nothing)]
219 ; other -> -- Not a saturated constructor
220 java_apply (CoreSyn.Var f) as
223 javaApp f as = java_apply f as
225 java_apply :: CoreExpr -> [CoreExpr] -> [Statement]
226 java_apply f as = [ExprStatement (vmPUSH arg) | arg <- javaArgs as] ++ javaExpr f
228 javaArgs :: [CoreExpr] -> [Expr]
229 javaArgs args = [javaArg a | a <- args, isValArg a]
231 javaArg :: CoreExpr -> Expr
232 javaArg (CoreSyn.Type t) = pprPanic "javaArg" (ppr t)
233 javaArg e | exprIsValue e || exprIsTrivial e = newCode (javaExpr e)
234 | otherwise = newThunk (newCode (javaExpr e))
237 %************************************************************************
239 \subsection{Helper functions}
241 %************************************************************************
249 vmCOLLECT :: Int -> Expr -> [Statement]
251 vmCOLLECT n e = [ExprStatement (Call (Var vmName) "COLLECT" [Literal (IntLit n), e])]
254 vmPOP = Call (Var vmName) "POP" []
256 vmPUSH :: Expr -> Expr
257 vmPUSH e = Call (Var vmName) "PUSH" [e]
259 var :: [Modifier] -> Type -> Name -> Expr -> Statement
260 var ms ty field_name value = Declaration (Field ms ty field_name (Just value))
262 vmWHNF :: Expr -> Expr
263 vmWHNF e = Call (Var vmName) "WHNF" [e]
265 instanceOf :: Id -> DataCon -> Expr
266 instanceOf x data_con
267 = InstanceOf (Var (javaName x)) (javaConstrWkrType data_con)
269 newCode :: [Statement] -> Expr
270 newCode [Return e] = e
271 newCode stmts = New codeType [] (Just [Method [Public] objectType enterName [] stmts])
273 newThunk :: Expr -> Expr
274 newThunk e = New thunkType [e] Nothing
277 %************************************************************************
279 \subsection{Name mangling}
281 %************************************************************************
284 codeName, enterName, vmName :: Name
291 fieldName :: Int -> Name -- Names for fields of a constructor
292 fieldName n = "f" ++ show n
294 javaName :: NamedThing a => a -> Name
295 javaName n = getOccString n
297 javaConstrWkrName :: DataCon -> Name
298 -- The function that makes the constructor
299 javaConstrWkrName con = getOccString (dataConId con)
301 javaInstName :: NamedThing a => a -> Name
302 -- Makes x_inst for Rec decls
303 javaInstName n = getOccString n ++ "_inst"
306 %************************************************************************
308 \subsection{Type mangling}
310 %************************************************************************
313 javaType :: NamedThing a => a -> Type
314 javaType n = Type [javaName n]
316 javaConstrWkrType :: DataCon -> Type
317 -- The function that makes the constructor
318 javaConstrWkrType con = Type [javaConstrWkrName con]
320 codeType, thunkType, objectType :: Type
321 objectType = Type ["Object"]
322 codeType = Type [codeName]
323 thunkType = Type [thunkName]
326 %************************************************************************
328 \subsection{Class Lifting}
330 %************************************************************************
332 This is a very simple class lifter. It works by carrying inwards a
333 list of bound variables (things that might need to be passed to a
335 * Any variable references is check with this list, and if it is
336 bound, then it is not top level, external reference.
337 * This means that for the purposes of lifting, it might be free
338 inside a lifted inner class.
339 * We remember these "free inside the inner class" values, and
340 use this list (which is passed, via the monad, outwards)
347 combine :: [Name] -> [Name] -> [Name]
348 combine [] names = names
349 combine names [] = names
350 combine (name:names) (name':names')
351 | name < name' = name : combine names (name':names')
352 | name > name' = name' : combine (name:names) names'
353 | name == name = name : combine names names'
354 | otherwise = error "names are not a total order"
356 both :: [Name] -> [Name] -> [Name]
359 both (name:names) (name':names')
360 | name < name' = both names (name':names')
361 | name > name' = both (name:names) names'
362 | name == name = name : both names names'
363 | otherwise = error "names are not a total order"
365 combineEnv :: Env -> [Name] -> Env
366 combineEnv (Env bound env) new = Env (bound `combine` new) env
368 addTypeMapping :: Name -> Name -> [Name] -> Env -> Env
369 addTypeMapping origName newName frees (Env bound env)
370 = Env bound ((origName,(newName,frees)) : env)
372 data Env = Env Bound [(Name,(Name,[Name]))]
375 LifterM { unLifterM ::
379 , [Decl] -- lifted classes
384 instance Monad LifterM where
385 return a = LifterM (\ n s -> (a,[],[],s))
386 (LifterM m) >>= fn = LifterM (\ n s ->
389 -> case unLifterM (fn a) n s of
390 (a,frees2,lifted2,s) -> ( a
391 , combine frees frees2
396 access :: Env -> Name -> LifterM ()
397 access env@(Env bound _) name
398 | name `elem` bound = LifterM (\ n s -> ((),[name],[],s))
399 | otherwise = return ()
401 scopedName :: Name -> LifterM a -> LifterM a
402 scopedName name (LifterM m) =
405 (a,frees,lifted,_) -> (a,frees,lifted,s)
408 genAnonInnerClassName :: LifterM Name
409 genAnonInnerClassName = LifterM (\ n s ->
417 genInnerClassName :: Name -> LifterM Name
418 genInnerClassName name = LifterM (\ n s ->
426 getFrees :: LifterM a -> LifterM (a,Frees)
427 getFrees (LifterM m) = LifterM (\ n s ->
429 (a,frees,lifted,n) -> ((a,frees),frees,lifted,n)
432 rememberClass :: Decl -> LifterM ()
433 rememberClass decl = LifterM (\ n s -> ((),[],[decl],s))
436 liftCompilationUnit :: CompilationUnit -> CompilationUnit
437 liftCompilationUnit (Package name ds) =
438 case unLifterM (liftDecls True (Env [] []) ds) [] 1 of
439 (ds,_,ds',_) -> Package name (ds ++ ds')
441 -- The bound vars for the current class have
442 -- already be captured before calling liftDecl,
443 -- because they are in scope everywhere inside the class.
445 liftDecl :: Bool -> Env -> Decl -> LifterM Decl
446 liftDecl = \ top env decl ->
448 { Import n -> return (Import n)
450 do { e <- liftMaybeExpr env e
451 ; return (Field mfs (liftType env t) n e)
453 ; Constructor mfs n as ss ->
454 do { let newBound = getBoundAtParameters as
455 ; (ss,_) <- liftStatements (combineEnv env newBound) ss
456 ; return (Constructor mfs n (liftParameters env as) ss)
458 ; Method mfs t n as ss ->
459 do { let newBound = getBoundAtParameters as
460 ; (ss,_) <- liftStatements (combineEnv env newBound) ss
461 ; return (Method mfs (liftType env t) n (liftParameters env as) ss)
463 ; Comment s -> return (Comment s)
464 ; Interface mfs n is ms -> error "interfaces not supported"
465 ; Class mfs n x is ms ->
466 do { let newBound = getBoundAtDecls ms
468 (liftDecls False (combineEnv env newBound) ms)
469 ; return (Class mfs n x is ms)
473 liftDecls :: Bool -> Env -> [Decl] -> LifterM [Decl]
474 liftDecls top env = mapM (liftDecl top env)
476 getBoundAtDecls :: [Decl] -> Bound
477 getBoundAtDecls = foldr combine [] . map getBoundAtDecl
480 getBoundAtDecl :: Decl -> Bound
481 getBoundAtDecl (Field _ _ n _) = [n]
482 getBoundAtDecl _ = []
484 getBoundAtParameters :: [Parameter] -> Bound
485 getBoundAtParameters = foldr combine [] . map getBoundAtParameter
488 getBoundAtParameter :: Parameter -> Bound
489 getBoundAtParameter (Parameter _ _ n) = [n]
491 liftStatement :: Env -> Statement -> LifterM (Statement,Env)
492 liftStatement = \ env stmt ->
494 { Skip -> return (stmt,env)
495 ; Return e -> do { e <- liftExpr env e
496 ; return (Return e,env)
498 ; Block ss -> do { (ss,env) <- liftStatements env ss
499 ; return (Block ss,env)
501 ; ExprStatement e -> do { e <- liftExpr env e
502 ; return (ExprStatement e,env)
504 ; Declaration decl@(Field mfs t n e) ->
505 do { e <- liftMaybeExpr env e
506 ; return ( Declaration (Field mfs t n e)
507 , env `combineEnv` getBoundAtDecl decl
510 ; Declaration decl@(Class mfs n x is ms) ->
511 do { innerName <- genInnerClassName n
512 ; frees <- liftClass env innerName ms x is
513 ; return ( Declaration (Comment ["lifted " ++ n])
514 , addTypeMapping n innerName frees env
517 ; Declaration d -> error "general Decl not supported"
518 ; IfThenElse ecs s -> ifthenelse env ecs s
519 ; Switch e as d -> error "switch not supported"
523 -> [(Expr,Statement)]
525 -> LifterM (Statement,Env)
526 ifthenelse env pairs may_stmt =
527 do { let (exprs,stmts) = unzip pairs
528 ; exprs <- liftExprs env exprs
529 ; (stmts,_) <- liftStatements env stmts
530 ; may_stmt <- case may_stmt of
531 Just stmt -> do { (stmt,_) <- liftStatement env stmt
534 Nothing -> return Nothing
535 ; return (IfThenElse (zip exprs stmts) may_stmt,env)
538 liftStatements :: Env -> [Statement] -> LifterM ([Statement],Env)
539 liftStatements env [] = return ([],env)
540 liftStatements env (s:ss) =
541 do { (s,env) <- liftStatement env s
542 ; (ss,env) <- liftStatements env ss
547 liftExpr :: Env -> Expr -> LifterM Expr
548 liftExpr = \ env expr ->
550 { Var n -> do { access env n
553 ; Literal l -> return expr
554 ; Cast t e -> do { e <- liftExpr env e
555 ; return (Cast (liftType env t) e)
557 ; Access e n -> do { e <- liftExpr env e
558 -- do not consider n as an access, because
559 -- this is a indirection via a reference
560 ; return (Access e n)
562 ; Assign l r -> do { l <- liftExpr env l
563 ; r <- liftExpr env r
564 ; return (Assign l r)
566 ; InstanceOf e t -> do { e <- liftExpr env e
567 ; return (InstanceOf e (liftType env t))
569 ; Call e n es -> do { e <- liftExpr env e
570 ; es <- mapM (liftExpr env) es
571 ; return (Call e n es)
573 ; Op e1 o e2 -> do { e1 <- liftExpr env e1
574 ; e2 <- liftExpr env e1
575 ; return (Op e1 o e2)
577 ; New n es ds -> new env n es ds
578 ; NewArray n es -> error "array not (yet) supported"
581 liftParameter env (Parameter ms t n) = Parameter ms (liftType env t) n
582 liftParameters env = map (liftParameter env)
584 liftExprs :: Env -> [Expr] -> LifterM [Expr]
585 liftExprs = mapM . liftExpr
587 liftMaybeExpr :: Env -> (Maybe Expr) -> LifterM (Maybe Expr)
588 liftMaybeExpr env Nothing = return Nothing
589 liftMaybeExpr env (Just stmt) = do { stmt <- liftExpr env stmt
594 new :: Env -> Type -> [Expr] -> Maybe [Decl] -> LifterM Expr
595 new env@(Env _ pairs) typ args Nothing =
596 do { args <- liftExprs env args
597 ; return (mkNew env typ args)
599 new env typ [] (Just inner) =
601 do { innerName <- genAnonInnerClassName
602 ; frees <- liftClass env innerName inner [] []
603 ; return (mkNew env typ [ Var name | name <- frees ])
605 new env typ _ (Just inner) = error "cant handle inner class with args"
607 liftClass :: Env -> Name -> [Decl] -> [Name] -> [Name] -> LifterM [ Name ]
608 liftClass env@(Env bound _) innerName inner xs is =
609 do { let newBound = getBoundAtDecls inner
611 getFrees (liftDecls False (env `combineEnv` newBound) inner)
612 ; let trueFrees = both frees bound
613 ; let mirrorFrees = [ "_" ++ name ++ "_" | name <- trueFrees ]
614 ; let freeDefs = [ Field [Final] objectType n Nothing | n <- trueFrees ]
615 ; let cons = Constructor [Public] innerName
616 [ Parameter [] objectType name | name <- mirrorFrees ]
617 [ ExprStatement (Assign (Var true) (Var mirror))
618 | (true,mirror) <- zip trueFrees mirrorFrees
620 ; let innerClass = Class [] innerName xs is (freeDefs ++ [cons] ++ inner)
621 ; rememberClass innerClass
625 liftType :: Env -> Type -> Type
626 liftType (Env _ env) typ@(Type [name])
627 = case lookup name env of
629 Just (nm,_) -> Type [nm]
632 mkNew :: Env -> Type -> [Expr] -> Expr
633 mkNew (Env _ env) typ@(Type [name]) exprs
634 = case lookup name env of
635 Nothing -> New typ exprs Nothing
636 Just (nm,args) | null exprs
637 -> New (Type [nm]) (map Var args) Nothing
638 _ -> error "pre-lifted constructor with arguments"
639 mkNew _ typ exprs = New typ exprs Nothing