ghc/compiler/javaGen/JavaGen.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
   3 %
   4 \section{Generate Java}
   5
   6 Name mangling for Java.
   7 ~~~~~~~~~~~~~~~~~~~~~~
   8
   9 Haskell has a number of namespaces. The Java translator uses
  10 the standard Haskell mangles (see OccName.lhs), and some extra
  11 mangles.
  12
  13 All names are hidden inside packages.
  14
  15 module name:
  16   - becomes a first level java package.
  17   - can not clash with java, because haskell modules are upper case,
  18      java default packages are lower case.
  19
  20 function names:
  21   - these turn into classes
  22   - java keywords (eg. private) have the suffix "zdk" ($k) added.
  23
  24 data *types*
  25   - These have a base class, so need to appear in the
  26     same name space as other object. for example data Foo = Foo
  27   - We add a postfix to types: "zdc" ($c)
  28   - Types are upper case, so never clash with keywords
  29
  30 data constructors
  31   - There are tWO classes for each Constructor
  32    (1) - Class with the payload extends the relevent datatype baseclass.
  33        - This class has the prefix zdw ($w)
  34    (2) - Constructor *wrapper* just use their own name.
  35     - Constructors are upper case, so never clash with keywords
  36     - So Foo would become 2 classes.
  37         * Foo           -- the constructor wrapper
  38         * zdwFoo        -- the worker, with the payload
  39
  40
  41 $i  for instances.
  42 $k  for keyword nameclash avoidance.
  43
  44 \begin{code}
  45 module JavaGen( javaGen ) where
  46
  47 import Java
  48
  49 import Literal  ( Literal(..) )
  50 import Id       ( Id, isDataConId_maybe, isId, idName, isDeadBinder, idPrimRep
  51                 , isPrimOpId_maybe )
  52 import Name     ( NamedThing(..), getOccString, isGlobalName, isLocalName
  53                 , nameModule )
  54 import PrimRep  ( PrimRep(..) )
  55 import DataCon  ( DataCon, dataConRepArity, dataConRepArgTys, dataConId )
  56 import qualified Type
  57 import qualified CoreSyn
  58 import CoreSyn  ( CoreBind, CoreExpr, CoreAlt, CoreBndr,
  59                   Bind(..), AltCon(..), collectBinders, isValArg
  60                 )
  61 import TysWiredIn       ( boolTy, trueDataCon, falseDataCon )
  62 import qualified CoreUtils
  63 import Module   ( Module, moduleString )
  64 import TyCon    ( TyCon, isDataTyCon, tyConDataCons )
  65 import Outputable
  66
  67 import Maybe
  68 import PrimOp
  69
  70 #include "HsVersions.h"
  71
  72 \end{code}
  73
  74
  75 \begin{code}
  76 javaGen :: Module -> [Module] -> [TyCon] -> [CoreBind] -> CompilationUnit
  77
  78 javaGen mod import_mods tycons binds
  79   = liftCompilationUnit package
  80   where
  81     decls = [Import "haskell.runtime.*"] ++
  82             [Import (moduleString mod) | mod <- import_mods] ++
  83             concat (map javaTyCon (filter isDataTyCon tycons)) ++
  84             concat (map javaTopBind binds)
  85     package = Package (moduleString mod) decls
  86 \end{code}
  87
  88
  89 %************************************************************************
  90 %*                                                                      *
  91 \subsection{Type declarations}
  92 %*                                                                      *
  93 %************************************************************************
  94
  95 \begin{code}
  96 javaTyCon :: TyCon -> [Decl]
  97 --      public class List {}
  98 --
  99 --      public class $wCons extends List {
 100 --              Object f1; Object f2
 101 --      }
 102 --      public class $wNil extends List {}
 103
 104 javaTyCon tycon
 105   = tycon_jclass : concat (map constr_class constrs)
 106   where
 107     constrs = tyConDataCons tycon
 108     tycon_jclass_jname =  javaTyConTypeName tycon ++ "zdc"
 109     tycon_jclass = Class [Public] (shortName tycon_jclass_jname) [] [] []
 110
 111     constr_class data_con
 112         = [ Class [Public] constr_jname [tycon_jclass_jname] []
 113                                 (field_decls ++ [cons_meth,debug_meth])
 114           ]
 115         where
 116           constr_jname = shortName (javaConstrWkrName data_con)
 117
 118           field_names  = constrToFields data_con
 119           field_decls  = [ Field [Public] n Nothing
 120                          | n <- field_names
 121                          ]
 122
 123           cons_meth    = mkCons constr_jname field_names
 124
 125           debug_meth   = Method [Public] (Name "toString" stringType)
 126                                          []
 127                                          []
 128                        (  [ Declaration (Field [] txt Nothing) ]
 129                        ++ [ ExprStatement
 130                                 (Assign (Var txt)
 131                                             (mkStr
 132                                                 ("( " ++
 133                                                   getOccString data_con ++
 134                                                   " ")
 135                                              )
 136                                 )
 137                           ]
 138                        ++ [ ExprStatement
 139                                 (Assign (Var txt)
 140                                    (Op (Var txt)
 141                                         "+"
 142                                        (Op (Var n) "+" litSp)
 143                                    )
 144                                 )
 145                           | n <- field_names
 146                           ]
 147                        ++ [ Return (Op (Var txt)
 148                                         "+"
 149                                       (mkStr ")")
 150                                    )
 151                           ]
 152                        )
 153
 154           litSp    = mkStr " "
 155           txt      = Name "__txt" stringType
 156
 157
 158 -- This checks to see the type is reasonable to call new with.
 159 -- primitives might use a static method later.
 160 mkNew :: Type -> [Expr] -> Expr
 161 mkNew t@(PrimType primType) _  = error "new primitive -- fix it???"
 162 mkNew t@(Type _)            es = New t es Nothing
 163 mkNew _                     _  = error "new with strange arguments"
 164
 165 constrToFields :: DataCon -> [Name]
 166 constrToFields cons =
 167         [ fieldName i t
 168         | (i,t) <- zip [1..] (map primRepToType
 169                                   (map Type.typePrimRep
 170                                        (dataConRepArgTys cons)
 171                                   )
 172                              )
 173         ]
 174
 175 mkCons :: TypeName -> [Name] -> Decl
 176 mkCons name args = Constructor [Public] name
 177         [ Parameter [] n | n <- args ]
 178         [ ExprStatement (Assign
 179                            (Access this n)
 180                            (Var n)
 181                          )
 182                     | n <- args ]
 183
 184 mkStr :: String -> Expr
 185 mkStr str = Literal (StringLit str)
 186 \end{code}
 187
 188 %************************************************************************
 189 %*                                                                      *
 190 \subsection{Bindings}
 191 %*                                                                      *
 192 %************************************************************************
 193
 194 \begin{code}
 195 javaTopBind :: CoreBind -> [Decl]
 196 javaTopBind (NonRec bndr rhs) = [java_top_bind bndr rhs]
 197 javaTopBind (Rec prs)         = [java_top_bind bndr rhs | (bndr,rhs) <- prs]
 198
 199 java_top_bind :: Id -> CoreExpr -> Decl
 200 --      public class f implements Code {
 201 --        public Object ENTER() { ...translation of rhs... }
 202 --      }
 203 java_top_bind bndr rhs
 204   = Class [Public] (shortName (javaIdTypeName bndr))
 205                 [] [codeName] [enter_meth]
 206   where
 207     enter_meth = Method [Public]
 208                         enterName
 209                         [vmArg]
 210                         [excName]
 211                         (javaExpr vmRETURN rhs)
 212 \end{code}
 213
 214 %************************************************************************
 215 %*                                                                      *
 216 \subsection{Expressions}
 217 %*                                                                      *
 218 %************************************************************************
 219
 220 \begin{code}
 221 javaVar :: Id -> Expr
 222 javaVar v | isGlobalName (idName v) = mkNew (javaIdType v) []
 223           | otherwise               =   Var (javaName v)
 224
 225 javaLit :: Literal.Literal -> Expr
 226 javaLit (MachInt i)  = Literal (IntLit (fromInteger i))
 227 javaLit (MachChar c) = Literal (CharLit c)
 228 javaLit (MachStr fs) = Literal (StringLit str)
 229    where
 230         str = concatMap renderString (_UNPK_ fs) ++ "\\000"
 231         -- This should really handle all the chars 0..31.
 232         renderString '\NUL' = "\\000"
 233         renderString other  = [other]
 234
 235 javaLit other        = pprPanic "javaLit" (ppr other)
 236
 237 -- Pass in the 'shape' of the result.
 238 javaExpr :: (Expr -> Statement) -> CoreExpr -> [Statement]
 239 -- Generate code to apply the value of
 240 -- the expression to the arguments aleady on the stack
 241 javaExpr r (CoreSyn.Var v)   = [r (javaVar v)]
 242 javaExpr r (CoreSyn.Lit l)   = [r (javaLit l)]
 243 javaExpr r (CoreSyn.App f a) = javaApp r f [a]
 244 javaExpr r e@(CoreSyn.Lam _ _) = javaLam r (collectBinders e)
 245 javaExpr r (CoreSyn.Case e x alts) = javaCase r e x alts
 246 javaExpr r (CoreSyn.Let bind body) = javaBind bind ++ javaExpr r body
 247 javaExpr r (CoreSyn.Note _ e)    = javaExpr r e
 248
 249 javaCase :: (Expr -> Statement) -> CoreExpr -> Id -> [CoreAlt] -> [Statement]
 250 --      case e of x { Nil      -> r1
 251 --                    Cons p q -> r2 }
 252 -- ==>
 253 --      final Object x = VM.WHNF(...code for e...)
 254 --      else if x instance_of Nil {
 255 --              ...translation of r1...
 256 --      } else if x instance_of Cons {
 257 --              final Object p = ((Cons) x).f1
 258 --              final Object q = ((Cons) x).f2
 259 --              ...translation of r2...
 260 --      } else throw java.lang.Exception
 261
 262 -- This first special case happens a lot, typically
 263 -- during dictionary deconstruction.
 264 -- We need to access at least *one* field, to check to see
 265 -- if we have correct constructor.
 266 -- If we've got the wrong one, this is _|_, and the
 267 -- casting will catch this with an exception.
 268
 269 javaCase r e x [(DataAlt d,bs,rhs)] | length bs > 0
 270   = java_expr PushExpr e ++
 271     [ var [Final] (javaName x)
 272                   (whnf primRep (vmPOP (primRepToType primRep))) ] ++
 273     bind_args d bs ++
 274     javaExpr r rhs
 275    where
 276      primRep = idPrimRep x
 277      whnf PtrRep = vmWHNF       -- needs evaluation
 278      whnf _      = id           -- anything else does notg
 279
 280      bind_args d bs = [var [Final] (javaName b)
 281                            (Access (Cast (javaConstrWkrType d) (javaVar x)
 282                                    ) f
 283                            )
 284                       | (b,f) <- filter isId bs `zip` (constrToFields d)
 285                       , not (isDeadBinder b)
 286                       ]
 287
 288 javaCase r e x alts
 289   | isIfThenElse && isPrimCmp
 290   = javaIfThenElse r (fromJust maybePrim) tExpr fExpr
 291   | otherwise
 292   = java_expr PushExpr e ++
 293        [ var [Final] (javaName x)
 294                            (whnf primRep (vmPOP (primRepToType primRep)))
 295        , IfThenElse (map mk_alt con_alts) (Just default_code)
 296        ]
 297   where
 298      isIfThenElse = CoreUtils.exprType e `Type.eqType` boolTy
 299                     -- also need to check that x is not free in
 300                     -- any of the branches.
 301      maybePrim    = findCmpPrim e []
 302      isPrimCmp    = isJust maybePrim
 303      (_,_,tExpr)  = CoreUtils.findAlt (DataAlt trueDataCon) alts
 304      (_,_,fExpr)  = CoreUtils.findAlt (DataAlt falseDataCon) alts
 305
 306      primRep = idPrimRep x
 307      whnf PtrRep = vmWHNF       -- needs evaluation
 308      whnf _      = id
 309
 310      (con_alts, maybe_default) = CoreUtils.findDefault alts
 311      default_code = case maybe_default of
 312                         Nothing  -> ExprStatement (Raise excName [Literal (StringLit "case failure")])
 313                         Just rhs -> Block (javaExpr r rhs)
 314
 315      mk_alt (DataAlt d,  bs, rhs) = (instanceOf x d, Block (bind_args d bs ++ javaExpr r rhs))
 316      mk_alt (LitAlt lit, bs, rhs) = (eqLit lit     , Block (javaExpr r rhs))
 317
 318
 319      eqLit (MachInt n) = Op (Literal (IntLit n))
 320
 321                             "=="
 322                             (Var (javaName x))
 323      eqLit (MachChar n) = Op (Literal (CharLit n))
 324                             "=="
 325                             (Var (javaName x))
 326      eqLit other       = pprPanic "eqLit" (ppr other)
 327
 328      bind_args d bs = [var [Final] (javaName b)
 329                            (Access (Cast (javaConstrWkrType d) (javaVar x)
 330                                    ) f
 331                            )
 332                       | (b,f) <- filter isId bs `zip` (constrToFields d)
 333                       , not (isDeadBinder b)
 334                       ]
 335
 336 javaIfThenElse r cmp tExpr fExpr
 337 {-
 338  - Now what we need to do is generate code for the if/then/else.
 339  - [all arguments are already check for simpleness (Var or Lit).]
 340  -
 341  - if (<prim> arg1 arg2 arg3 ...) {
 342  -      trueCode
 343  -  } else {
 344  -      falseCode
 345  - }
 346  -}
 347  = [IfThenElse [(cmp,j_tExpr)] (Just j_fExpr)]
 348  where
 349    j_tExpr, j_fExpr :: Statement
 350    j_tExpr = Block (javaExpr r tExpr)
 351    j_fExpr = Block (javaExpr r fExpr)
 352
 353 javaBind (NonRec x rhs)
 354 {-
 355         x = ...rhs_x...
 356   ==>
 357         final Object x = new Thunk( new Code() { ...code for rhs_x... } )
 358 -}
 359
 360   = java_expr (SetVar name) rhs
 361   where
 362     name = case coreTypeToType rhs of
 363             ty@(PrimType _) -> javaName x `withType` ty
 364             _               -> javaName x `withType` codeType
 365
 366 javaBind (Rec prs)
 367 {-      rec { x = ...rhs_x...; y = ...rhs_y... }
 368   ==>
 369         class x implements Code {
 370           Code x, y;
 371           public Object ENTER() { ...code for rhs_x...}
 372         }
 373         ...ditto for y...
 374
 375         final x x_inst = new x();
 376         ...ditto for y...
 377
 378         final Thunk x = new Thunk( x_inst );
 379         ...ditto for y...
 380
 381         x_inst.x = x;
 382         x_inst.y = y;
 383         ...ditto for y...
 384 -}
 385   = (map mk_class prs) ++ (map mk_inst prs) ++
 386     (map mk_thunk prs) ++ concat (map mk_knot prs)
 387   where
 388     mk_class (b,r) = Declaration (Class [] class_name [] [codeName] stmts)
 389                    where
 390                      class_name = javaIdTypeName b
 391                      stmts = [Field [] (javaName b `withType` codeType) Nothing | (b,_) <- prs] ++
 392                              [Method [Public] enterName [vmArg] [excName] (javaExpr vmRETURN r)]
 393
 394     mk_inst (b,r) = var [Final] name (mkNew ty [])
 395         where
 396            name@(Name _ ty)  = javaInstName b
 397
 398     mk_thunk (b,r) = var [Final] (javaName b `withType` codeType)
 399                          (mkNew thunkType [Var (javaInstName b)])
 400
 401     mk_knot (b,_) = [ ExprStatement (Assign lhs rhs)
 402                     | (b',_) <- prs,
 403                       let lhs = Access (Var (javaInstName b)) (javaName b'),
 404                       let rhs = Var (javaName b')
 405                     ]
 406
 407 javaLam :: (Expr -> Statement) -> ([CoreBndr], CoreExpr) -> [Statement]
 408 javaLam r (bndrs, body)
 409   | null val_bndrs = javaExpr r body
 410   | otherwise
 411   =  vmCOLLECT (length val_bndrs) this
 412   ++ [var [Final] n (vmPOP t) | n@(Name _ t) <- val_bndrs]
 413   ++ javaExpr r body
 414   where
 415     val_bndrs = map javaName (filter isId bndrs)
 416
 417 javaApp :: (Expr -> Statement) -> CoreExpr -> [CoreExpr] -> [Statement]
 418 javaApp r (CoreSyn.App f a) as
 419         | isValArg a = javaApp r f (a:as)
 420         | otherwise  = javaApp r f as
 421 javaApp r (CoreSyn.Var f) as
 422   = case isDataConId_maybe f of {
 423         Just dc | length as == dataConRepArity dc
 424          -- NOTE: Saturated constructors never returning a primitive at this point
 425          --
 426          -- We push the arguments backwards, because we are using
 427          -- the (ugly) semantics of the order of evaluation of arguments,
 428          -- to avoid making up local names. Oh to have a namesupply...
 429          --
 430                 -> javaArgs (reverse as) ++
 431                    [r (New (javaIdType f)
 432                            (javaPops as)
 433                            Nothing
 434                        )
 435                    ]
 436                 | otherwise ->
 437                    --  build a local
 438                    let stmts =
 439                           vmCOLLECT (dataConRepArity dc) this ++
 440                         [ vmRETURN
 441                            (New (javaIdType f)
 442                                 [ vmPOP ty | (Name _ ty) <- constrToFields dc ]
 443                                 Nothing
 444                             )
 445                         ]
 446                    in javaArgs (reverse as) ++ [r (newCode stmts)]
 447     ; other -> java_apply r (CoreSyn.Var f) as
 448     }
 449
 450 javaApp r f as = java_apply r f as
 451
 452 -- This means, given a expression an a list of arguments,
 453 -- generate code for "pushing the arguments on the stack,
 454 --  and the executing the expression."
 455
 456 java_apply :: (Expr -> Statement) -> CoreExpr -> [CoreExpr] -> [Statement]
 457 java_apply r f as = javaArgs as ++ javaExpr r f
 458
 459 -- This generates statements that have the net effect
 460 -- of pushing values (perhaps thunks) onto the stack.
 461
 462 javaArgs :: [CoreExpr] -> [Statement]
 463 javaArgs args = concat [ java_expr PushExpr a | a <- args, isValArg a]
 464
 465 javaPops :: [CoreExpr] -> [Expr]
 466 javaPops args = [ vmPOP (primRepToType (Type.typePrimRep (CoreUtils.exprType a)))
 467                 | a <- args
 468                 , isValArg a
 469                 ]
 470
 471
 472 -- The result is a list of statments that have the effect of
 473 -- pushing onto the stack (via one of the VM.PUSH* commands)
 474 -- the argument, (or returning, or setting a variable)
 475 -- perhaps thunked.
 476
 477 {- This is mixing two things.
 478  (1) Optimizations for things like primitives, whnf calls, etc.
 479  (2) If something needs a thunk constructor round it.
 480  - Seperate them at some point!
 481  -}
 482 data ExprRetStyle = SetVar Name | PushExpr | ReturnExpr
 483
 484 java_expr :: ExprRetStyle -> CoreExpr -> [Statement]
 485 java_expr _ (CoreSyn.Type t) = pprPanic "java_expr" (ppr t)
 486 java_expr ret e
 487    | isPrimCall = [push (fromJust maybePrim)]
 488         -- This is a shortcut,
 489         -- basic names and literals do not need a code block
 490         -- to compute the value.
 491    | isPrim primty && CoreUtils.exprIsTrivial e = javaExpr push e
 492    | isPrim primty =
 493           let expr  = javaExpr vmRETURN e
 494               code  = access (vmWHNF (newCode expr)) (primRepToType primty)
 495           in [push code]
 496    | otherwise =
 497           let expr  = javaExpr vmRETURN e
 498               code  = newCode expr
 499               code' = if CoreUtils.exprIsValue e
 500                       || CoreUtils.exprIsTrivial e
 501                       || isPrim primty
 502                       then code
 503                       else newThunk code
 504           in [push code']
 505    where
 506         maybePrim  = findFnPrim e []
 507         isPrimCall = isJust maybePrim
 508
 509         push e = case ret of
 510                   SetVar name -> var [Final] name e
 511                   PushExpr -> vmPUSH e
 512                   ReturnExpr -> vmRETURN e
 513         corety = CoreUtils.exprType e
 514         primty = Type.typePrimRep corety
 515         isPrim PtrRep  = False  -- only this needs updated
 516         isPrim _       = True
 517
 518 coreTypeToType = primRepToType . Type.typePrimRep . CoreUtils.exprType
 519
 520 renameForKeywords :: (NamedThing name) => name -> String
 521 renameForKeywords name
 522   | str `elem` keywords = "zdk" ++ str
 523   | otherwise            = str
 524   where
 525         str = getOccString name
 526
 527 keywords :: [String]
 528 keywords =
 529         [ "return"
 530         , "if"
 531         , "then"
 532         , "else"
 533         , "class"
 534         , "instance"
 535         , "import"
 536         , "throw"
 537         , "try"
 538         ]
 539
 540 \end{code}
 541
 542 %************************************************************************
 543 %*                                                                      *
 544 \subsection{Helper functions}
 545 %*                                                                      *
 546 %************************************************************************
 547
 548 \begin{code}
 549 true, this,javaNull :: Expr
 550 this = Var thisName
 551 true = Var (Name "true" (PrimType PrimBoolean))
 552 javaNull = Var (Name "null" objectType)
 553
 554 vmCOLLECT :: Int -> Expr -> [Statement]
 555 vmCOLLECT 0 e = []
 556 vmCOLLECT n e = [ExprStatement
 557                     (Call varVM collectName
 558                         [ Literal (IntLit (toInteger n))
 559                         , e
 560                         ]
 561                     )
 562                 ]
 563
 564 vmPOP :: Type -> Expr
 565 vmPOP ty = Call varVM (Name ("POP" ++ suffix ty) ty) []
 566
 567 vmPUSH :: Expr -> Statement
 568 vmPUSH e = ExprStatement
 569              (Call varVM (Name ("PUSH" ++ suffix (exprType e)) void) [e])
 570
 571 vmRETURN :: Expr -> Statement
 572 vmRETURN e = Return (
 573      case ty of
 574         PrimType _ -> Call varVM (Name ("RETURN" ++ suffix ty)
 575                                        valueType
 576                                  ) [e]
 577         _ -> e)
 578   where
 579         ty = exprType e
 580
 581 var :: [Modifier] -> Name -> Expr -> Statement
 582 var ms field_name@(Name _ ty) value
 583    | exprType value == ty = Declaration (Field ms field_name (Just value))
 584    | otherwise            = var ms field_name (Cast ty value)
 585
 586 vmWHNF :: Expr -> Expr
 587 vmWHNF e = Call varVM whnfName [e]
 588
 589 suffix :: Type -> String
 590 suffix (PrimType t) = primName t
 591 suffix _            = ""
 592
 593 primName :: PrimType -> String
 594 primName PrimInt       = "int"
 595 primName PrimChar      = "char"
 596 primName PrimByte      = "byte"
 597 primName PrimBoolean   = "boolean"
 598 primName _             = error "unsupported primitive"
 599
 600 varVM :: Expr
 601 varVM = Var vmName
 602
 603 instanceOf :: Id -> DataCon -> Expr
 604 instanceOf x data_con
 605   = InstanceOf (Var (javaName x)) (javaConstrWkrType data_con)
 606
 607 newCode :: [Statement] -> Expr
 608 newCode [Return e] = e
 609 newCode stmts      = New codeType [] (Just [Method [Public] enterName [vmArg] [excName] stmts])
 610
 611 newThunk :: Expr -> Expr
 612 newThunk e = New thunkType [e] Nothing
 613
 614 vmArg :: Parameter
 615 vmArg = Parameter [Final] vmName
 616
 617 -- This is called with boolean compares, checking
 618 -- to see if we can do an obvious shortcut.
 619 -- If there is, we return a (GOO) expression for doing this,
 620
 621 -- So if, we have case (#< x y) of { True -> e1; False -> e2 },
 622 -- we will call findCmpFn with (#< x y), this return Just (Op x "<" y)
 623
 624 findCmpPrim :: CoreExpr -> [Expr] -> Maybe Expr
 625 findCmpPrim (CoreSyn.App f a) as =
 626      case a of
 627         CoreSyn.Var v -> findCmpPrim f (javaVar v:as)
 628         CoreSyn.Lit l -> findCmpPrim f (javaLit l:as)
 629         _ -> Nothing
 630 findCmpPrim (CoreSyn.Var p)   as =
 631         case isPrimOpId_maybe p of
 632           Just prim -> find_cmp_prim prim as
 633           Nothing   -> Nothing
 634 findCmpPrim _                 as = Nothing
 635
 636 find_cmp_prim cmpPrim args@[a,b] =
 637    case cmpPrim of
 638      IntGtOp -> fn ">"
 639      IntGeOp -> fn ">="
 640      IntEqOp -> fn "=="
 641      IntNeOp -> fn "/="
 642      IntLtOp -> fn "<"
 643      IntLeOp -> fn "<="
 644      _ -> Nothing
 645   where
 646         fn op = Just (Op a op b)
 647 find_cmp_prim _ _ = Nothing
 648
 649 findFnPrim :: CoreExpr -> [Expr] -> Maybe Expr
 650 findFnPrim (CoreSyn.App f a) as =
 651      case a of
 652         CoreSyn.Var v -> findFnPrim f (javaVar v:as)
 653         CoreSyn.Lit l -> findFnPrim f (javaLit l:as)
 654         _ -> Nothing
 655 findFnPrim (CoreSyn.Var p)   as =
 656         case isPrimOpId_maybe p of
 657           Just prim -> find_fn_prim prim as
 658           Nothing   -> Nothing
 659 findFnPrim _                 as = Nothing
 660
 661 find_fn_prim cmpPrim args@[a,b] =
 662    case cmpPrim of
 663      IntAddOp -> fn "+"
 664      IntSubOp -> fn "-"
 665      IntMulOp -> fn "*"
 666      _ -> Nothing
 667   where
 668         fn op = Just (Op a op b)
 669 find_fn_prim _ _ = Nothing
 670 \end{code}
 671
 672 %************************************************************************
 673 %*                                                                      *
 674 \subsection{Haskell to Java Types}
 675 %*                                                                      *
 676 %************************************************************************
 677
 678 \begin{code}
 679 exprType (Var (Name _ t)) = t
 680 exprType (Literal lit)    = litType lit
 681 exprType (Cast t _)       = t
 682 exprType (New t _ _)      = t
 683 exprType (Call _ (Name _ t) _) = t
 684 exprType (Access _ (Name _ t)) = t
 685 exprType (Raise t _)           = error "do not know the type of raise!"
 686 exprType (Op _ op _) | op `elem` ["==","/=","<","<=","=>",">"]
 687                      = PrimType PrimBoolean
 688 exprType (Op x op _) | op `elem` ["+","-","*"]
 689                      = exprType x
 690 exprType expr = error ("can't figure out an expression type: " ++ show expr)
 691
 692 litType (IntLit i)    = PrimType PrimInt
 693 litType (CharLit i)   = PrimType PrimChar
 694 litType (StringLit i) = stringType      -- later, might use char array?
 695 \end{code}
 696
 697 %************************************************************************
 698 %*                                                                      *
 699 \subsection{Name mangling}
 700 %*                                                                      *
 701 %************************************************************************
 702
 703 \begin{code}
 704 codeName, excName, thunkName :: TypeName
 705 codeName  = "haskell.runtime.Code"
 706 thunkName = "haskell.runtime.Thunk"
 707 excName   = "java.lang.Exception"
 708
 709 enterName, vmName,thisName,collectName, whnfName :: Name
 710 enterName   = Name "ENTER"   objectType
 711 vmName      = Name "VM"      vmType
 712 thisName    = Name "this"    (Type "<this>")
 713 collectName = Name "COLLECT" void
 714 whnfName    = Name "WHNF"    objectType
 715
 716 fieldName :: Int -> Type -> Name        -- Names for fields of a constructor
 717 fieldName n ty = Name ("f" ++ show n) ty
 718
 719 withType :: Name -> Type -> Name
 720 withType (Name n _) t = Name n t
 721
 722 -- This maps (local only) names Ids to Names,
 723 -- using the same string as the Id.
 724 javaName :: Id -> Name
 725 javaName n
 726   | isGlobalName (idName n) = error "useing javaName on global"
 727   | otherwise = Name (getOccString n)
 728                      (primRepToType (idPrimRep n))
 729
 730 -- TypeName's are almost always global. This would typically return something
 731 -- like Test.foo or Test.Foozdc or PrelBase.foldr.
 732 -- Local might use locally bound types, (which do not have '.' in them).
 733
 734 javaIdTypeName :: Id -> TypeName
 735 javaIdTypeName n
 736     | isLocalName n' = renameForKeywords n'
 737     | otherwise      = moduleString (nameModule n') ++ "." ++ renameForKeywords n'
 738   where
 739              n' = getName n
 740
 741 -- There is no such thing as a local type constructor.
 742
 743 javaTyConTypeName :: TyCon -> TypeName
 744 javaTyConTypeName n = (moduleString (nameModule n') ++ "." ++ renameForKeywords n')
 745   where
 746              n' = getName n
 747
 748 -- this is used for getting the name of a class when defining it.
 749 shortName :: TypeName -> TypeName
 750 shortName = reverse . takeWhile (/= '.') . reverse
 751
 752 -- The function that makes the constructor name
 753 -- The constructor "Foo ..." in module Test,
 754 -- would return the name "Test.Foo".
 755
 756 javaConstrWkrName :: DataCon -> TypeName
 757 javaConstrWkrName = javaIdTypeName . dataConId
 758
 759 -- Makes x_inst for Rec decls
 760 -- They are *never* is primitive
 761 -- and always have local (type) names.
 762 javaInstName :: Id -> Name
 763 javaInstName n = Name (renameForKeywords n ++ "zdi_inst")
 764                       (Type (renameForKeywords n))
 765 \end{code}
 766
 767 %************************************************************************
 768 %*                                                                      *
 769 \subsection{Types and type mangling}
 770 %*                                                                      *
 771 %************************************************************************
 772
 773 \begin{code}
 774 -- Haskell RTS types
 775 codeType, thunkType, valueType :: Type
 776 codeType   = Type codeName
 777 thunkType  = Type thunkName
 778 valueType  = Type "haskell.runtime.Value"
 779 vmType     = Type "haskell.runtime.VMEngine"
 780
 781 -- Basic Java types
 782 objectType, stringType :: Type
 783 objectType = Type "java.lang.Object"
 784 stringType = Type "java.lang.String"
 785
 786 void :: Type
 787 void = PrimType PrimVoid
 788
 789 inttype :: Type
 790 inttype = PrimType PrimInt
 791
 792 chartype :: Type
 793 chartype = PrimType PrimChar
 794
 795 bytetype :: Type
 796 bytetype = PrimType PrimByte
 797
 798 -- This lets you get inside a possible "Value" type,
 799 -- to access the internal unboxed object.
 800 access :: Expr -> Type -> Expr
 801 access expr (PrimType prim) = accessPrim (Cast valueType expr) prim
 802 access expr other           = expr
 803
 804 accessPrim expr PrimInt  = Call expr (Name "intValue" inttype) []
 805 accessPrim expr PrimChar = Call expr (Name "charValue" chartype) []
 806 accessPrim expr PrimByte = Call expr (Name "byteValue" bytetype) []
 807 accessPrim expr other    = pprPanic "accessPrim" (text (show other))
 808
 809 -- This is where we map from typename to types,
 810 -- allowing to match possible primitive types.
 811 mkType :: TypeName -> Type
 812 mkType "PrelGHC.Intzh"  = inttype
 813 mkType "PrelGHC.Charzh" = chartype
 814 mkType other            = Type other
 815
 816 -- Turns a (global) Id into a Type (fully qualified name).
 817 javaIdType :: Id -> Type
 818 javaIdType = mkType . javaIdTypeName
 819
 820 javaLocalIdType :: Id -> Type
 821 javaLocalIdType = primRepToType . idPrimRep
 822
 823 primRepToType ::PrimRep -> Type
 824 primRepToType PtrRep  = objectType
 825 primRepToType IntRep  = inttype
 826 primRepToType CharRep = chartype
 827 primRepToType Int8Rep = bytetype
 828 primRepToType AddrRep = objectType
 829 primRepToType other   = pprPanic "primRepToType" (ppr other)
 830
 831 -- The function that makes the constructor name
 832 javaConstrWkrType :: DataCon -> Type
 833 javaConstrWkrType con = Type (javaConstrWkrName con)
 834 \end{code}
 835
 836 %************************************************************************
 837 %*                                                                      *
 838 \subsection{Class Lifting}
 839 %*                                                                      *
 840 %************************************************************************
 841
 842 This is a very simple class lifter. It works by carrying inwards a
 843 list of bound variables (things that might need to be passed to a
 844 lifted inner class).
 845  * Any variable references is check with this list, and if it is
 846    bound, then it is not top level, external reference.
 847  * This means that for the purposes of lifting, it might be free
 848    inside a lifted inner class.
 849  * We remember these "free inside the inner class" values, and
 850    use this list (which is passed, via the monad, outwards)
 851    when lifting.
 852
 853 \begin{code}
 854 type Bound = [Name]
 855 type Frees = [Name]
 856
 857 combine :: [Name] -> [Name] -> [Name]
 858 combine []           names          = names
 859 combine names        []             = names
 860 combine (name:names) (name':names')
 861         | name < name' = name  : combine names (name':names')
 862         | name > name' = name' : combine (name:names) names'
 863         | name == name = name  : combine names names'
 864         | otherwise    = error "names are not a total order"
 865
 866 both :: [Name] -> [Name] -> [Name]
 867 both []           names          = []
 868 both names        []             = []
 869 both (name:names) (name':names')
 870         | name < name' = both names (name':names')
 871         | name > name' = both (name:names) names'
 872         | name == name = name  : both names names'
 873         | otherwise    = error "names are not a total order"
 874
 875 combineEnv :: Env -> [Name] -> Env
 876 combineEnv (Env bound env) new = Env (bound `combine` new) env
 877
 878 addTypeMapping :: TypeName -> TypeName -> [Name] -> Env -> Env
 879 addTypeMapping origName newName frees (Env bound env)
 880         = Env bound ((origName,(newName,frees)) : env)
 881
 882 -- This a list of bound vars (with types)
 883 -- and a mapping from old class name
 884 --     to inner class name (with a list of frees that need passed
 885 --                          to the inner class.)
 886
 887 data Env = Env Bound [(TypeName,(TypeName,[Name]))]
 888
 889 newtype LifterM a =
 890         LifterM { unLifterM ::
 891                      TypeName ->                -- this class name
 892                      Int ->                     -- uniq supply
 893                           ( a                   -- *
 894                             , Frees             -- frees
 895                             , [Decl]            -- lifted classes
 896                             , Int               -- The uniqs
 897                             )
 898                 }
 899
 900 instance Monad LifterM where
 901         return a = LifterM (\ n s -> (a,[],[],s))
 902         (LifterM m) >>= fn = LifterM (\ n s ->
 903           case m n s of
 904             (a,frees,lifted,s)
 905                  -> case unLifterM (fn a) n s of
 906                      (a,frees2,lifted2,s) -> ( a
 907                                              , combine frees frees2
 908                                              , lifted ++ lifted2
 909                                              , s)
 910           )
 911
 912 liftAccess :: Env -> Name -> LifterM ()
 913 liftAccess env@(Env bound _) name
 914         | name `elem` bound = LifterM (\ n s -> ((),[name],[],s))
 915         | otherwise         = return ()
 916
 917 scopedName :: TypeName -> LifterM a -> LifterM a
 918 scopedName name (LifterM m) =
 919    LifterM (\ _ s ->
 920       case m name 1 of
 921         (a,frees,lifted,_) -> (a,frees,lifted,s)
 922       )
 923
 924 genAnonInnerClassName :: LifterM TypeName
 925 genAnonInnerClassName = LifterM (\ n s ->
 926         ( n ++ "$" ++ show s
 927         , []
 928         , []
 929         , s + 1
 930         )
 931     )
 932
 933 genInnerClassName :: TypeName -> LifterM TypeName
 934 genInnerClassName name = LifterM (\ n s ->
 935         ( n ++ "$" ++ name
 936         , []
 937         , []
 938         , s
 939         )
 940     )
 941
 942 getFrees  :: LifterM a -> LifterM (a,Frees)
 943 getFrees (LifterM m) = LifterM (\ n s ->
 944         case m n s of
 945           (a,frees,lifted,n) -> ((a,frees),frees,lifted,n)
 946     )
 947
 948 rememberClass :: Decl -> LifterM ()
 949 rememberClass decl = LifterM (\ n s -> ((),[],[decl],s))
 950
 951
 952 liftCompilationUnit :: CompilationUnit -> CompilationUnit
 953 liftCompilationUnit (Package name ds) =
 954     Package name (concatMap liftCompilationUnit' ds)
 955
 956 liftCompilationUnit' :: Decl -> [Decl]
 957 liftCompilationUnit' decl =
 958     case unLifterM (liftDecls True (Env [] []) [decl]) [] 1 of
 959       (ds,_,ds',_) -> ds ++ ds'
 960
 961
 962 -- The bound vars for the current class have
 963 -- already be captured before calling liftDecl,
 964 -- because they are in scope everywhere inside the class.
 965
 966 liftDecl :: Bool -> Env -> Decl -> LifterM Decl
 967 liftDecl = \ top env decl ->
 968   case decl of
 969     { Import n -> return (Import n)
 970     ; Field mfs n e ->
 971       do { e <- liftMaybeExpr env e
 972          ; return (Field mfs (liftName env n) e)
 973          }
 974     ; Constructor mfs n as ss ->
 975       do { let newBound = getBoundAtParameters as
 976          ; (ss,_) <- liftStatements (combineEnv env newBound) ss
 977          ; return (Constructor mfs n (liftParameters env as) ss)
 978          }
 979     ; Method mfs n as ts ss ->
 980       do { let newBound = getBoundAtParameters as
 981          ; (ss,_) <- liftStatements (combineEnv env newBound) ss
 982          ; return (Method mfs (liftName env n) (liftParameters env as) ts ss)
 983          }
 984     ; Comment s -> return (Comment s)
 985     ; Interface mfs n is ms -> error "interfaces not supported"
 986     ; Class mfs n x is ms ->
 987       do { let newBound = getBoundAtDecls ms
 988          ; ms <- scopedName n
 989                     (liftDecls False (combineEnv env newBound) ms)
 990          ; return (Class mfs n x is ms)
 991          }
 992     }
 993
 994 liftDecls :: Bool -> Env -> [Decl] -> LifterM [Decl]
 995 liftDecls top env = mapM (liftDecl top env)
 996
 997 getBoundAtDecls :: [Decl] -> Bound
 998 getBoundAtDecls = foldr combine [] . map getBoundAtDecl
 999
1000 getBoundAtDecl :: Decl -> Bound
1001 getBoundAtDecl (Field _ n _) = [n]
1002 getBoundAtDecl _             = []
1003
1004 getBoundAtParameters :: [Parameter] -> Bound
1005 getBoundAtParameters = foldr combine [] . map getBoundAtParameter
1006
1007 -- TODO
1008 getBoundAtParameter :: Parameter -> Bound
1009 getBoundAtParameter (Parameter _ n) = [n]
1010
1011
1012 liftStatement :: Env -> Statement -> LifterM (Statement,Env)
1013 liftStatement = \ env stmt ->
1014   case stmt of
1015     { Skip -> return (stmt,env)
1016     ; Return e -> do { e <- liftExpr env e
1017                      ; return (Return e,env)
1018                      }
1019     ; Block ss -> do { (ss,env) <- liftStatements env ss
1020                      ; return (Block ss,env)
1021                      }
1022     ; ExprStatement e -> do { e <- liftExpr env e
1023                             ; return (ExprStatement e,env)
1024                             }
1025     ; Declaration decl@(Field mfs n e) ->
1026       do { e <- liftMaybeExpr env e
1027          ; return ( Declaration (Field mfs (liftName env n) e)
1028                   , env `combineEnv` getBoundAtDecl decl
1029                   )
1030          }
1031     ; Declaration decl@(Class mfs n x is ms) ->
1032       do { innerName <- genInnerClassName n
1033          ; frees <- liftClass env innerName ms x is
1034          ; return ( Declaration (Comment ["lifted " ++  n])
1035                   , addTypeMapping n innerName frees env
1036                   )
1037          }
1038     ; Declaration d -> error "general Decl not supported"
1039     ; IfThenElse ecs s -> ifthenelse env ecs s
1040     ; Switch e as d -> error "switch not supported"
1041     }
1042
1043 ifthenelse :: Env
1044            -> [(Expr,Statement)]
1045            -> (Maybe Statement)
1046            -> LifterM (Statement,Env)
1047 ifthenelse env pairs may_stmt =
1048   do { let (exprs,stmts) = unzip pairs
1049      ; exprs <- liftExprs env exprs
1050      ; (stmts,_) <- liftStatements env stmts
1051      ; may_stmt <- case may_stmt of
1052                       Just stmt -> do { (stmt,_) <- liftStatement env stmt
1053                                       ; return (Just stmt)
1054                                       }
1055                       Nothing -> return Nothing
1056      ; return (IfThenElse (zip exprs stmts) may_stmt,env)
1057      }
1058
1059 liftStatements :: Env -> [Statement] -> LifterM ([Statement],Env)
1060 liftStatements env []     = return ([],env)
1061 liftStatements env (s:ss) =
1062         do { (s,env) <- liftStatement env s
1063            ; (ss,env) <- liftStatements env ss
1064            ; return (s:ss,env)
1065            }
1066
1067 liftExpr :: Env -> Expr -> LifterM Expr
1068 liftExpr = \ env expr ->
1069  case expr of
1070    { Var n -> do { liftAccess env n
1071                  ; return (Var (liftName env n))
1072                  }
1073    ; Literal l -> return expr
1074    ; Cast t e -> do { e <- liftExpr env e
1075                     ; return (Cast (liftType env t) e)
1076                     }
1077    ; Access e n -> do { e <- liftExpr env e
1078                         -- do not consider n as an access, because
1079                         -- this is a indirection via a reference
1080                       ; return (Access e n)
1081                       }
1082    ; Assign l r -> do { l <- liftExpr env l
1083                       ; r <- liftExpr env r
1084                       ; return (Assign l r)
1085                       }
1086    ; InstanceOf e t -> do { e <- liftExpr env e
1087                           ; return (InstanceOf e (liftType env t))
1088                           }
1089    ; Raise n es -> do { es <- liftExprs env es
1090                       ; return (Raise n es)
1091                       }
1092    ; Call e n es -> do { e <- liftExpr env e
1093                        ; es <- mapM (liftExpr env) es
1094                        ; return (Call e n es)
1095                        }
1096    ; Op e1 o e2 -> do { e1 <- liftExpr env e1
1097                       ; e2 <- liftExpr env e2
1098                       ; return (Op e1 o e2)
1099                       }
1100    ; New n es ds -> new env n es ds
1101    }
1102
1103 liftParameter env (Parameter ms n) = Parameter ms (liftName env n)
1104 liftParameters env = map (liftParameter env)
1105
1106 liftName env (Name n t) = Name n (liftType env t)
1107
1108 liftExprs :: Env -> [Expr] -> LifterM [Expr]
1109 liftExprs = mapM . liftExpr
1110
1111
1112 liftMaybeExpr :: Env -> (Maybe Expr) -> LifterM (Maybe Expr)
1113 liftMaybeExpr env Nothing     = return Nothing
1114 liftMaybeExpr env (Just stmt) = do { stmt <- liftExpr env stmt
1115                                      ; return (Just stmt)
1116                                      }
1117
1118
1119
1120 new :: Env -> Type -> [Expr] -> Maybe [Decl] -> LifterM Expr
1121 new env@(Env _ pairs) typ args Nothing =
1122   do { args <- liftExprs env args
1123      ; return (liftNew env typ args)
1124      }
1125 new env typ [] (Just inner) =
1126   -- anon. inner class
1127   do { innerName <- genAnonInnerClassName
1128      ; frees <- liftClass env innerName inner [] [unType typ]
1129      ; return (New (Type (innerName))
1130                    (map Var frees)
1131                     Nothing)
1132      }
1133   where unType (Type name) = name
1134         unType _             = error "incorrect type style"
1135 new env typ _ (Just inner) = error "cant handle inner class with args"
1136
1137
1138 liftClass :: Env -> TypeName -> [Decl] -> [TypeName] -> [TypeName] -> LifterM [ Name ]
1139 liftClass env@(Env bound _) innerName inner xs is =
1140   do { let newBound = getBoundAtDecls inner
1141      ; (inner,frees) <-
1142            getFrees (liftDecls False (env `combineEnv` newBound) inner)
1143      ; let trueFrees = filter (\ (Name xs _) -> xs /= "VM") (both frees bound)
1144      ; let freeDefs = [ Field [Final] n Nothing | n <- trueFrees ]
1145      ; let cons = mkCons innerName trueFrees
1146      ; let innerClass = Class [] innerName xs is (freeDefs ++ [cons] ++ inner)
1147      ; rememberClass innerClass
1148      ; return trueFrees
1149      }
1150
1151 liftType :: Env -> Type -> Type
1152 liftType (Env _ env) typ@(Type name)
1153    = case lookup name env of
1154         Nothing     -> typ
1155         Just (nm,_) -> Type nm
1156 liftType _           typ = typ
1157
1158 liftNew :: Env -> Type -> [Expr] -> Expr
1159 liftNew (Env _ env) typ@(Type name) exprs
1160    = case lookup name env of
1161         Nothing                     -> New typ exprs Nothing
1162         Just (nm,args) | null exprs
1163                 -> New (Type nm) (map Var args) Nothing
1164         _ -> error "pre-lifted constructor with arguments"
1165 \end{code}