ghc/compiler/javaGen/JavaGen.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section{Generate Java}
   5
   6 \begin{code}
   7 module JavaGen( javaGen ) where
   8
   9 import Java
  10
  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
  18                 )
  19 import CoreUtils( exprIsValue, exprIsTrivial )
  20 import Module   ( Module, moduleString )
  21 import TyCon    ( TyCon, isDataTyCon, tyConDataCons )
  22 import Outputable
  23
  24 #include "HsVersions.h"
  25
  26 \end{code}
  27
  28
  29 \begin{code}
  30 javaGen :: Module -> [Module] -> [TyCon] -> [CoreBind] -> CompilationUnit
  31
  32 javaGen mod import_mods tycons binds
  33   = Package [moduleString mod] decls
  34   where
  35     decls = [Import [moduleString mod] | mod <- import_mods] ++
  36             concat (map javaTyCon (filter isDataTyCon tycons)) ++
  37             concat (map javaTopBind binds)
  38 \end{code}
  39
  40
  41 %************************************************************************
  42 %*                                                                      *
  43 \subsection{Type declarations}
  44 %*                                                                      *
  45 %************************************************************************
  46
  47 \begin{code}
  48 javaTyCon :: TyCon -> [Decl]
  49 --      public class List {}
  50 --
  51 --      public class $wCons extends List {
  52 --              Object f1; Object f2
  53 --      }
  54 --      public class $wNil extends List {}
  55
  56 javaTyCon tycon
  57   = tycon_jclass : map constr_class constrs
  58   where
  59     constrs = tyConDataCons tycon
  60     tycon_jclass_jname = javaName tycon
  61     tycon_jclass = Class [Public] tycon_jclass_jname [] [] []
  62
  63     constr_class data_con
  64         = Class [Public] constr_jname [tycon_jclass_jname] [] field_decls
  65         where
  66           constr_jname = javaConstrWkrName data_con
  67           enter_meth   = Method [Public] objectType enterName [] stmts
  68           n_val_args   = dataConRepArity data_con
  69           field_names  = map fieldName [1..n_val_args]
  70           field_decls  = [Field [Public] objectType f Nothing | f <- field_names]
  71           stmts        = vmCOLLECT n_val_args (Var thisName) ++
  72                          [var [Final] objectType f vmPOP | f <- field_names] ++
  73                          [Return (New constr_jname (map Var field_names) Nothing)]
  74 \end{code}
  75
  76 %************************************************************************
  77 %*                                                                      *
  78 \subsection{Bindings}
  79 %*                                                                      *
  80 %************************************************************************
  81
  82 \begin{code}
  83 javaTopBind :: CoreBind -> [Decl]
  84 javaTopBind (NonRec bndr rhs) = [java_top_bind bndr rhs]
  85 javaTopBind (Rec prs)         = [java_top_bind bndr rhs | (bndr,rhs) <- prs]
  86
  87 java_top_bind :: Id -> CoreExpr -> Decl
  88 --      public class f implements Code {
  89 --        public Object ENTER() { ...translation of rhs... }
  90 --      }
  91 java_top_bind bndr rhs
  92   = Class [Public] (javaName bndr) [] [codeName] [enter_meth]
  93   where
  94     enter_meth = Method [Public] objectType enterName [] (javaExpr rhs)
  95 \end{code}
  96
  97
  98 %************************************************************************
  99 %*                                                                      *
 100 \subsection{Expressions}
 101 %*                                                                      *
 102 %************************************************************************
 103
 104 \begin{code}
 105 javaVar :: Id -> Expr
 106 javaVar v | isGlobalName (idName v) = New (javaName v) [] Nothing
 107           | otherwise               = Var (javaName v)
 108
 109
 110 javaLit :: Literal.Literal -> Lit
 111 javaLit (MachInt i)  = UIntLit (fromInteger i)
 112 javaLit (MachChar c) = UCharLit c
 113 javaLit other        = pprPanic "javaLit" (ppr other)
 114
 115 javaExpr :: CoreExpr -> [Statement]
 116 -- Generate code to apply the value of
 117 -- the expression to the arguments aleady on the stack
 118 javaExpr (CoreSyn.Var v)   = [Return (javaVar v)]
 119 javaExpr (CoreSyn.Lit l)   = [Return (Literal (javaLit l))]
 120 javaExpr (CoreSyn.App f a) = javaApp f [a]
 121 javaExpr e@(CoreSyn.Lam _ _) = javaLam (collectBinders e)
 122 javaExpr (CoreSyn.Case e x alts) = javaCase e x alts
 123 javaExpr (CoreSyn.Let bind body) = javaBind bind ++ javaExpr body
 124 javaExpr (CoreSyn.Note _ e)      = javaExpr e
 125
 126 javaCase :: CoreExpr -> Id -> [CoreAlt] -> [Statement]
 127 --      case e of x { Nil      -> r1
 128 --                    Cons p q -> r2 }
 129 -- ==>
 130 --      final Object x = VM.WHNF(...code for e...)
 131 --      else if x instance_of Nil {
 132 --              ...translation of r1...
 133 --      } else if x instance_of Cons {
 134 --              final Object p = ((Cons) x).f1
 135 --              final Object q = ((Cons) x).f2
 136 --              ...translation of r2...
 137 --      } else return null
 138
 139 javaCase e x alts
 140   =  [var [Final] objectType (javaName x) (vmWHNF (javaArg e)),
 141       IfThenElse (map mk_alt alts) Nothing]
 142   where
 143      mk_alt (DEFAULT, [], rhs)   = (true,           Block (javaExpr rhs))
 144      mk_alt (DataAlt d, bs, rhs) = (instanceOf x d, Block (bind_args d bs ++ javaExpr rhs))
 145      mk_alt alt@(LitAlt _, _, _) = pprPanic "mk_alt" (ppr alt)
 146
 147      bind_args d bs = [var [Final] objectType (javaName b)
 148                            (Access (Cast (Type (javaConstrWkrName d)) (javaVar x)) f)
 149                       | (b, f) <- filter isId bs `zip` map fieldName [1..],
 150                         not (isDeadBinder b)
 151                       ]
 152
 153 javaBind (NonRec x rhs)
 154 {-
 155         x = ...rhs_x...
 156   ==>
 157         final Object x = new Thunk( new Code() { ...code for rhs_x... } )
 158 -}
 159   = [var [Final] objectType (javaName x) (javaArg rhs)]
 160
 161 javaBind (Rec prs)
 162 {-      rec { x = ...rhs_x...; y = ...rhs_y... }
 163   ==>
 164         class x implements Code {
 165           Code x, y;
 166           public Object ENTER() { ...code for rhs_x...}
 167         }
 168         ...ditto for y...
 169
 170         final x x_inst = new x();
 171         ...ditto for y...
 172
 173         final Thunk x = new Thunk( x_inst );
 174         ...ditto for y...
 175
 176         x_inst.x = x;
 177         x_inst.y = y;
 178         ...ditto for y...
 179 -}
 180   = (map mk_class prs) ++ (map mk_inst prs) ++
 181     (map mk_thunk prs) ++ concat (map mk_knot prs)
 182   where
 183     mk_class (b,r) = Declaration (Class [] (javaName b) [] [codeName] stmts)
 184                    where
 185                      stmts = [Field [] codeType (javaName b) Nothing | (b,_) <- prs] ++
 186                              [Method [Public] objectType enterName [] (javaExpr r)]
 187
 188     mk_inst (b,r) = var [Final] (Type (javaName b)) (javaInstName b)
 189                         (New (javaName b) [] Nothing)
 190
 191     mk_thunk (b,r) = var [Final] thunkType (javaName b)
 192                          (New thunkName [Var (javaInstName b)] Nothing)
 193
 194     mk_knot (b,_) = [ExprStatement (Assign lhs rhs)
 195                     | (b',_) <- prs,
 196                       let lhs = Access (Var (javaInstName b)) (javaName b'),
 197                       let rhs = Var (javaName b')
 198                     ]
 199
 200 javaLam :: ([CoreBndr], CoreExpr) -> [Statement]
 201 javaLam (bndrs, body)
 202   | null val_bndrs = javaExpr body
 203   | otherwise
 204   =  vmCOLLECT (length val_bndrs) (Var thisName)
 205   ++ [var [Final] objectType (javaName n) vmPOP | n <- val_bndrs]
 206   ++ javaExpr body
 207   where
 208     val_bndrs = filter isId bndrs
 209
 210 javaApp :: CoreExpr -> [CoreExpr] -> [Statement]
 211 javaApp (CoreSyn.App f a) as = javaApp f (a:as)
 212 javaApp (CoreSyn.Var f) as
 213   = case isDataConId_maybe f of {
 214         Just dc | length as == dataConRepArity dc
 215                 ->      -- Saturated constructors
 216                    [Return (New (javaName f) (javaArgs as) Nothing)]
 217
 218     ; other ->   -- Not a saturated constructor
 219         java_apply (CoreSyn.Var f) as
 220     }
 221
 222 javaApp f as = java_apply f as
 223
 224 java_apply :: CoreExpr -> [CoreExpr] -> [Statement]
 225 java_apply f as = [ExprStatement (vmPUSH arg) | arg <- javaArgs as] ++ javaExpr f
 226
 227 javaArgs :: [CoreExpr] -> [Expr]
 228 javaArgs args = [javaArg a | a <- args, isValArg a]
 229
 230 javaArg :: CoreExpr -> Expr
 231 javaArg (CoreSyn.Type t) = pprPanic "javaArg" (ppr t)
 232 javaArg e | exprIsValue e || exprIsTrivial e = newCode (javaExpr e)
 233           | otherwise                        = newThunk (newCode (javaExpr e))
 234 \end{code}
 235
 236 %************************************************************************
 237 %*                                                                      *
 238 \subsection{Helper functions}
 239 %*                                                                      *
 240 %************************************************************************
 241
 242 \begin{code}
 243 true, this :: Expr
 244 this = Var thisName
 245
 246 true = Var ["true"]
 247
 248 vmCOLLECT :: Int -> Expr -> [Statement]
 249 vmCOLLECT 0 e = []
 250 vmCOLLECT n e = [ExprStatement (Call (Var vmName) ["COLLECT"] [Literal (IntLit n), e])]
 251
 252 vmPOP :: Expr
 253 vmPOP = Call (Var vmName) ["POP"] []
 254
 255 vmPUSH :: Expr -> Expr
 256 vmPUSH e = Call (Var vmName) ["PUSH"] [e]
 257
 258 var :: [Modifier] -> Type -> Name -> Expr -> Statement
 259 var ms ty field_name value = Declaration (Field ms ty field_name (Just value))
 260
 261 vmWHNF :: Expr -> Expr
 262 vmWHNF e = Call (Var vmName) ["WHNF"] [e]
 263
 264 instanceOf :: Id -> DataCon -> Expr
 265 instanceOf x data_con
 266   = InstanceOf (Var (javaName x)) (Type (javaConstrWkrName data_con))
 267
 268 newCode :: [Statement] -> Expr
 269 newCode [Return e] = e
 270 newCode stmts      = New codeName [] (Just [Method [Public] objectType enterName [] stmts])
 271
 272 newThunk :: Expr -> Expr
 273 newThunk e = New thunkName [e] Nothing
 274 \end{code}
 275
 276 %************************************************************************
 277 %*                                                                      *
 278 \subsection{Name mangling}
 279 %*                                                                      *
 280 %************************************************************************
 281
 282 \begin{code}
 283 codeName, enterName, vmName :: Name
 284 codeName  = ["Code"]
 285 thunkName = ["Thunk"]
 286 enterName = ["ENTER"]
 287 vmName    = ["VM"]
 288 thisName  = ["this"]
 289
 290 fieldName :: Int -> Name        -- Names for fields of a constructor
 291 fieldName n = ["f" ++ show n]
 292
 293 javaName :: NamedThing a => a -> Name
 294 javaName n = [getOccString n]
 295
 296 javaConstrWkrName :: DataCon ->  Name
 297 -- The function that makes the constructor
 298 javaConstrWkrName con = [getOccString (dataConId con)]
 299
 300 javaInstName :: NamedThing a => a -> Name
 301 -- Makes x_inst for Rec decls
 302 javaInstName n = [getOccString n ++ "_inst"]
 303 \end{code}
 304
 305 %************************************************************************
 306 %*                                                                      *
 307 \subsection{Type mangling}
 308 %*                                                                      *
 309 %************************************************************************
 310
 311 \begin{code}
 312 codeType, thunkType, objectType :: Type
 313 objectType = Type ["Object"]
 314 codeType  = Type codeName
 315 thunkType = Type thunkName
 316 \end{code}
 317