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