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 PrimBoolean   = "boolean"
 609 primName _             = error "unsupported primitive"
 610
 611 varVM :: Expr
 612 varVM = Var vmName
 613
 614 instanceOf :: Id -> DataCon -> Expr
 615 instanceOf x data_con
 616   = InstanceOf (Var (javaName x)) (javaConstrWkrType data_con)
 617
 618 newCode :: [Statement] -> Expr
 619 newCode [Return e] = e
 620 newCode stmts      = New codeType [] (Just [Method [Public] enterName [vmArg] [excName] stmts])
 621
 622 newThunk :: Expr -> Expr
 623 newThunk e = New thunkType [e] Nothing
 624
 625 vmArg :: Parameter
 626 vmArg = Parameter [Final] vmName
 627
 628 -- This is called with boolean compares, checking
 629 -- to see if we can do an obvious shortcut.
 630 -- If there is, we return a (GOO) expression for doing this,
 631
 632 -- So if, we have case (#< x y) of { True -> e1; False -> e2 },
 633 -- we will call findCmpFn with (#< x y), this return Just (Op x "<" y)
 634
 635 findCmpPrim :: CoreExpr -> [Expr] -> Maybe Expr
 636 findCmpPrim (CoreSyn.App f a) as =
 637      case a of
 638         CoreSyn.Var v -> findCmpPrim f (javaVar v:as)
 639         CoreSyn.Lit l -> findCmpPrim f (javaLit l:as)
 640         _ -> Nothing
 641 findCmpPrim (CoreSyn.Var p)   as =
 642         case isPrimOpId_maybe p of
 643           Just prim -> find_cmp_prim prim as
 644           Nothing   -> Nothing
 645 findCmpPrim _                 as = Nothing
 646
 647 find_cmp_prim cmpPrim args@[a,b] =
 648    case cmpPrim of
 649      IntGtOp -> fn ">"
 650      IntGeOp -> fn ">="
 651      IntEqOp -> fn "=="
 652      IntNeOp -> fn "/="
 653      IntLtOp -> fn "<"
 654      IntLeOp -> fn "<="
 655      _ -> Nothing
 656   where
 657         fn op = Just (Op a op b)
 658 find_cmp_prim _ _ = Nothing
 659
 660 findFnPrim :: CoreExpr -> [Expr] -> Maybe Expr
 661 findFnPrim (CoreSyn.App f a) as =
 662      case a of
 663         CoreSyn.Var v -> findFnPrim f (javaVar v:as)
 664         CoreSyn.Lit l -> findFnPrim f (javaLit l:as)
 665         _ -> Nothing
 666 findFnPrim (CoreSyn.Var p)   as =
 667         case isPrimOpId_maybe p of
 668           Just prim -> find_fn_prim prim as
 669           Nothing   -> Nothing
 670 findFnPrim _                 as = Nothing
 671
 672 find_fn_prim cmpPrim args@[a,b] =
 673    case cmpPrim of
 674      IntAddOp -> fn "+"
 675      IntSubOp -> fn "-"
 676      IntMulOp -> fn "*"
 677      _ -> Nothing
 678   where
 679         fn op = Just (Op a op b)
 680 find_fn_prim _ _ = Nothing
 681 \end{code}
 682
 683 %************************************************************************
 684 %*                                                                      *
 685 \subsection{Haskell to Java Types}
 686 %*                                                                      *
 687 %************************************************************************
 688
 689 \begin{code}
 690 exprType (Var (Name _ t)) = t
 691 exprType (Literal lit)    = litType lit
 692 exprType (Cast t _)       = t
 693 exprType (New t _ _)      = t
 694 exprType (Call _ (Name _ t) _) = t
 695 exprType (Access _ (Name _ t)) = t
 696 exprType (Raise t _)           = error "do not know the type of raise!"
 697 exprType (Op _ op _) | op `elem` ["==","/=","<","<=","=>",">"]
 698                      = PrimType PrimBoolean
 699 exprType (Op x op _) | op `elem` ["+","-","*"]
 700                      = exprType x
 701 exprType expr = error ("can't figure out an expression type: " ++ show expr)
 702
 703 litType (IntLit i)    = PrimType PrimInt
 704 litType (CharLit i)   = PrimType PrimChar
 705 litType (StringLit i) = stringType      -- later, might use char array?
 706 \end{code}
 707
 708 %************************************************************************
 709 %*                                                                      *
 710 \subsection{Name mangling}
 711 %*                                                                      *
 712 %************************************************************************
 713
 714 \begin{code}
 715 codeName, excName, thunkName :: TypeName
 716 codeName  = "haskell.runtime.Code"
 717 thunkName = "haskell.runtime.Thunk"
 718 excName   = "java.lang.Exception"
 719
 720 enterName, vmName,thisName,collectName, whnfName :: Name
 721 enterName   = Name "ENTER"   objectType
 722 vmName      = Name "VM"      vmType
 723 thisName    = Name "this"    (Type "<this>")
 724 collectName = Name "COLLECT" void
 725 whnfName    = Name "WHNF"    objectType
 726
 727 fieldName :: Int -> Type -> Name        -- Names for fields of a constructor
 728 fieldName n ty = Name ("f" ++ show n) ty
 729
 730 withType :: Name -> Type -> Name
 731 withType (Name n _) t = Name n t
 732
 733 -- This maps (local only) names Ids to Names,
 734 -- using the same string as the Id.
 735 javaName :: Id -> Name
 736 javaName n
 737   | isGlobalName (idName n) = error "useing javaName on global"
 738   | otherwise = Name (getOccString n)
 739                      (primRepToType (idPrimRep n))
 740
 741 -- TypeName's are almost always global. This would typically return something
 742 -- like Test.foo or Test.Foozdc or PrelBase.foldr.
 743 -- Local might use locally bound types, (which do not have '.' in them).
 744
 745 javaIdTypeName :: Id -> TypeName
 746 javaIdTypeName n
 747     | isLocalName n' = renameForKeywords n'
 748     | otherwise      = moduleString (nameModule n') ++ "." ++ renameForKeywords n'
 749   where
 750              n' = getName n
 751
 752 -- There is no such thing as a local type constructor.
 753
 754 javaTyConTypeName :: TyCon -> TypeName
 755 javaTyConTypeName n = (moduleString (nameModule n') ++ "." ++ renameForKeywords n')
 756   where
 757              n' = getName n
 758
 759 -- this is used for getting the name of a class when defining it.
 760 shortName :: TypeName -> TypeName
 761 shortName = reverse . takeWhile (/= '.') . reverse
 762
 763 -- The function that makes the constructor name
 764 -- The constructor "Foo ..." in module Test,
 765 -- would return the name "Test.Foo".
 766
 767 javaConstrWkrName :: DataCon -> TypeName
 768 javaConstrWkrName = javaIdTypeName . dataConId
 769
 770 -- Makes x_inst for Rec decls
 771 -- They are *never* is primitive
 772 -- and always have local (type) names.
 773 javaInstName :: Id -> Name
 774 javaInstName n = Name (renameForKeywords n ++ "zdi_inst")
 775                       (Type (renameForKeywords n))
 776 \end{code}
 777
 778 %************************************************************************
 779 %*                                                                      *
 780 \subsection{Types and type mangling}
 781 %*                                                                      *
 782 %************************************************************************
 783
 784 \begin{code}
 785 -- Haskell RTS types
 786 codeType, thunkType, valueType :: Type
 787 codeType   = Type codeName
 788 thunkType  = Type thunkName
 789 valueType  = Type "haskell.runtime.Value"
 790 vmType     = Type "haskell.runtime.VMEngine"
 791
 792 -- Basic Java types
 793 objectType, stringType :: Type
 794 objectType = Type "java.lang.Object"
 795 stringType = Type "java.lang.String"
 796
 797 void :: Type
 798 void = PrimType PrimVoid
 799
 800 inttype :: Type
 801 inttype = PrimType PrimInt
 802
 803 chartype :: Type
 804 chartype = PrimType PrimChar
 805
 806 -- This lets you get inside a possible "Value" type,
 807 -- to access the internal unboxed object.
 808 access :: Expr -> Type -> Expr
 809 access expr (PrimType prim) = accessPrim (Cast valueType expr) prim
 810 access expr other           = expr
 811
 812 accessPrim expr PrimInt  = Call expr (Name "intValue" inttype) []
 813 accessPrim expr PrimChar = Call expr (Name "charValue" chartype) []
 814 accessPrim expr other    = pprPanic "accessPrim" (text (show other))
 815
 816 -- This is where we map from typename to types,
 817 -- allowing to match possible primitive types.
 818 mkType :: TypeName -> Type
 819 mkType "PrelGHC.Intzh"  = inttype
 820 mkType "PrelGHC.Charzh" = chartype
 821 mkType other            = Type other
 822
 823 -- Turns a (global) Id into a Type (fully qualified name).
 824 javaIdType :: Id -> Type
 825 javaIdType = mkType . javaIdTypeName
 826
 827 javaLocalIdType :: Id -> Type
 828 javaLocalIdType = primRepToType . idPrimRep
 829
 830 primRepToType ::PrimRep -> Type
 831 primRepToType PtrRep  = objectType
 832 primRepToType IntRep  = inttype
 833 primRepToType CharRep = chartype
 834 primRepToType AddrRep = objectType
 835 primRepToType other   = pprPanic "primRepToType" (ppr other)
 836
 837 -- The function that makes the constructor name
 838 javaConstrWkrType :: DataCon -> Type
 839 javaConstrWkrType con = Type (javaConstrWkrName con)
 840 \end{code}
 841
 842 %************************************************************************
 843 %*                                                                      *
 844 \subsection{Class Lifting}
 845 %*                                                                      *
 846 %************************************************************************
 847
 848 This is a very simple class lifter. It works by carrying inwards a
 849 list of bound variables (things that might need to be passed to a
 850 lifted inner class).
 851  * Any variable references is check with this list, and if it is
 852    bound, then it is not top level, external reference.
 853  * This means that for the purposes of lifting, it might be free
 854    inside a lifted inner class.
 855  * We remember these "free inside the inner class" values, and
 856    use this list (which is passed, via the monad, outwards)
 857    when lifting.
 858
 859 \begin{code}
 860 type Bound = [Name]
 861 type Frees = [Name]
 862
 863 combine :: [Name] -> [Name] -> [Name]
 864 combine []           names          = names
 865 combine names        []             = names
 866 combine (name:names) (name':names')
 867         | name < name' = name  : combine names (name':names')
 868         | name > name' = name' : combine (name:names) names'
 869         | name == name = name  : combine names names'
 870         | otherwise    = error "names are not a total order"
 871
 872 both :: [Name] -> [Name] -> [Name]
 873 both []           names          = []
 874 both names        []             = []
 875 both (name:names) (name':names')
 876         | name < name' = both names (name':names')
 877         | name > name' = both (name:names) names'
 878         | name == name = name  : both names names'
 879         | otherwise    = error "names are not a total order"
 880
 881 combineEnv :: Env -> [Name] -> Env
 882 combineEnv (Env bound env) new = Env (bound `combine` new) env
 883
 884 addTypeMapping :: TypeName -> TypeName -> [Name] -> Env -> Env
 885 addTypeMapping origName newName frees (Env bound env)
 886         = Env bound ((origName,(newName,frees)) : env)
 887
 888 -- This a list of bound vars (with types)
 889 -- and a mapping from old class name
 890 --     to inner class name (with a list of frees that need passed
 891 --                          to the inner class.)
 892
 893 data Env = Env Bound [(TypeName,(TypeName,[Name]))]
 894
 895 newtype LifterM a =
 896         LifterM { unLifterM ::
 897                      TypeName ->                -- this class name
 898                      Int ->                     -- uniq supply
 899                           ( a                   -- *
 900                             , Frees             -- frees
 901                             , [Decl]            -- lifted classes
 902                             , Int               -- The uniqs
 903                             )
 904                 }
 905
 906 instance Monad LifterM where
 907         return a = LifterM (\ n s -> (a,[],[],s))
 908         (LifterM m) >>= fn = LifterM (\ n s ->
 909           case m n s of
 910             (a,frees,lifted,s)
 911                  -> case unLifterM (fn a) n s of
 912                      (a,frees2,lifted2,s) -> ( a
 913                                              , combine frees frees2
 914                                              , lifted ++ lifted2
 915                                              , s)
 916           )
 917
 918 liftAccess :: Env -> Name -> LifterM ()
 919 liftAccess env@(Env bound _) name
 920         | name `elem` bound = LifterM (\ n s -> ((),[name],[],s))
 921         | otherwise         = return ()
 922
 923 scopedName :: TypeName -> LifterM a -> LifterM a
 924 scopedName name (LifterM m) =
 925    LifterM (\ _ s ->
 926       case m name 1 of
 927         (a,frees,lifted,_) -> (a,frees,lifted,s)
 928       )
 929
 930 genAnonInnerClassName :: LifterM TypeName
 931 genAnonInnerClassName = LifterM (\ n s ->
 932         ( n ++ "$" ++ show s
 933         , []
 934         , []
 935         , s + 1
 936         )
 937     )
 938
 939 genInnerClassName :: TypeName -> LifterM TypeName
 940 genInnerClassName name = LifterM (\ n s ->
 941         ( n ++ "$" ++ name
 942         , []
 943         , []
 944         , s
 945         )
 946     )
 947
 948 getFrees  :: LifterM a -> LifterM (a,Frees)
 949 getFrees (LifterM m) = LifterM (\ n s ->
 950         case m n s of
 951           (a,frees,lifted,n) -> ((a,frees),frees,lifted,n)
 952     )
 953
 954 rememberClass :: Decl -> LifterM ()
 955 rememberClass decl = LifterM (\ n s -> ((),[],[decl],s))
 956
 957
 958 liftCompilationUnit :: CompilationUnit -> CompilationUnit
 959 liftCompilationUnit (Package name ds) =
 960     Package name (concatMap liftCompilationUnit' ds)
 961
 962 liftCompilationUnit' :: Decl -> [Decl]
 963 liftCompilationUnit' decl =
 964     case unLifterM (liftDecls True (Env [] []) [decl]) [] 1 of
 965       (ds,_,ds',_) -> ds ++ ds'
 966
 967
 968 -- The bound vars for the current class have
 969 -- already be captured before calling liftDecl,
 970 -- because they are in scope everywhere inside the class.
 971
 972 liftDecl :: Bool -> Env -> Decl -> LifterM Decl
 973 liftDecl = \ top env decl ->
 974   case decl of
 975     { Import n -> return (Import n)
 976     ; Field mfs n e ->
 977       do { e <- liftMaybeExpr env e
 978          ; return (Field mfs (liftName env n) e)
 979          }
 980     ; Constructor mfs n as ss ->
 981       do { let newBound = getBoundAtParameters as
 982          ; (ss,_) <- liftStatements (combineEnv env newBound) ss
 983          ; return (Constructor mfs n (liftParameters env as) ss)
 984          }
 985     ; Method mfs n as ts ss ->
 986       do { let newBound = getBoundAtParameters as
 987          ; (ss,_) <- liftStatements (combineEnv env newBound) ss
 988          ; return (Method mfs (liftName env n) (liftParameters env as) ts ss)
 989          }
 990     ; Comment s -> return (Comment s)
 991     ; Interface mfs n is ms -> error "interfaces not supported"
 992     ; Class mfs n x is ms ->
 993       do { let newBound = getBoundAtDecls ms
 994          ; ms <- scopedName n
 995                     (liftDecls False (combineEnv env newBound) ms)
 996          ; return (Class mfs n x is ms)
 997          }
 998     }
 999
1000 liftDecls :: Bool -> Env -> [Decl] -> LifterM [Decl]
1001 liftDecls top env = mapM (liftDecl top env)
1002
1003 getBoundAtDecls :: [Decl] -> Bound
1004 getBoundAtDecls = foldr combine [] . map getBoundAtDecl
1005
1006 getBoundAtDecl :: Decl -> Bound
1007 getBoundAtDecl (Field _ n _) = [n]
1008 getBoundAtDecl _             = []
1009
1010 getBoundAtParameters :: [Parameter] -> Bound
1011 getBoundAtParameters = foldr combine [] . map getBoundAtParameter
1012
1013 -- TODO
1014 getBoundAtParameter :: Parameter -> Bound
1015 getBoundAtParameter (Parameter _ n) = [n]
1016
1017
1018 liftStatement :: Env -> Statement -> LifterM (Statement,Env)
1019 liftStatement = \ env stmt ->
1020   case stmt of
1021     { Skip -> return (stmt,env)
1022     ; Return e -> do { e <- liftExpr env e
1023                      ; return (Return e,env)
1024                      }
1025     ; Block ss -> do { (ss,env) <- liftStatements env ss
1026                      ; return (Block ss,env)
1027                      }
1028     ; ExprStatement e -> do { e <- liftExpr env e
1029                             ; return (ExprStatement e,env)
1030                             }
1031     ; Declaration decl@(Field mfs n e) ->
1032       do { e <- liftMaybeExpr env e
1033          ; return ( Declaration (Field mfs (liftName env n) e)
1034                   , env `combineEnv` getBoundAtDecl decl
1035                   )
1036          }
1037     ; Declaration decl@(Class mfs n x is ms) ->
1038       do { innerName <- genInnerClassName n
1039          ; frees <- liftClass env innerName ms x is
1040          ; return ( Declaration (Comment ["lifted " ++  n])
1041                   , addTypeMapping n innerName frees env
1042                   )
1043          }
1044     ; Declaration d -> error "general Decl not supported"
1045     ; IfThenElse ecs s -> ifthenelse env ecs s
1046     ; Switch e as d -> error "switch not supported"
1047     }
1048
1049 ifthenelse :: Env
1050            -> [(Expr,Statement)]
1051            -> (Maybe Statement)
1052            -> LifterM (Statement,Env)
1053 ifthenelse env pairs may_stmt =
1054   do { let (exprs,stmts) = unzip pairs
1055      ; exprs <- liftExprs env exprs
1056      ; (stmts,_) <- liftStatements env stmts
1057      ; may_stmt <- case may_stmt of
1058                       Just stmt -> do { (stmt,_) <- liftStatement env stmt
1059                                       ; return (Just stmt)
1060                                       }
1061                       Nothing -> return Nothing
1062      ; return (IfThenElse (zip exprs stmts) may_stmt,env)
1063      }
1064
1065 liftStatements :: Env -> [Statement] -> LifterM ([Statement],Env)
1066 liftStatements env []     = return ([],env)
1067 liftStatements env (s:ss) =
1068         do { (s,env) <- liftStatement env s
1069            ; (ss,env) <- liftStatements env ss
1070            ; return (s:ss,env)
1071            }
1072
1073 liftExpr :: Env -> Expr -> LifterM Expr
1074 liftExpr = \ env expr ->
1075  case expr of
1076    { Var n -> do { liftAccess env n
1077                  ; return (Var (liftName env n))
1078                  }
1079    ; Literal l -> return expr
1080    ; Cast t e -> do { e <- liftExpr env e
1081                     ; return (Cast (liftType env t) e)
1082                     }
1083    ; Access e n -> do { e <- liftExpr env e
1084                         -- do not consider n as an access, because
1085                         -- this is a indirection via a reference
1086                       ; return (Access e n)
1087                       }
1088    ; Assign l r -> do { l <- liftExpr env l
1089                       ; r <- liftExpr env r
1090                       ; return (Assign l r)
1091                       }
1092    ; InstanceOf e t -> do { e <- liftExpr env e
1093                           ; return (InstanceOf e (liftType env t))
1094                           }
1095    ; Raise n es -> do { es <- liftExprs env es
1096                       ; return (Raise n es)
1097                       }
1098    ; Call e n es -> do { e <- liftExpr env e
1099                        ; es <- mapM (liftExpr env) es
1100                        ; return (Call e n es)
1101                        }
1102    ; Op e1 o e2 -> do { e1 <- liftExpr env e1
1103                       ; e2 <- liftExpr env e2
1104                       ; return (Op e1 o e2)
1105                       }
1106    ; New n es ds -> new env n es ds
1107    }
1108
1109 liftParameter env (Parameter ms n) = Parameter ms (liftName env n)
1110 liftParameters env = map (liftParameter env)
1111
1112 liftName env (Name n t) = Name n (liftType env t)
1113
1114 liftExprs :: Env -> [Expr] -> LifterM [Expr]
1115 liftExprs = mapM . liftExpr
1116
1117
1118 liftMaybeExpr :: Env -> (Maybe Expr) -> LifterM (Maybe Expr)
1119 liftMaybeExpr env Nothing     = return Nothing
1120 liftMaybeExpr env (Just stmt) = do { stmt <- liftExpr env stmt
1121                                      ; return (Just stmt)
1122                                      }
1123
1124
1125
1126 new :: Env -> Type -> [Expr] -> Maybe [Decl] -> LifterM Expr
1127 new env@(Env _ pairs) typ args Nothing =
1128   do { args <- liftExprs env args
1129      ; return (liftNew env typ args)
1130      }
1131 new env typ [] (Just inner) =
1132   -- anon. inner class
1133   do { innerName <- genAnonInnerClassName
1134      ; frees <- liftClass env innerName inner [] [unType typ]
1135      ; return (New (Type (innerName))
1136                    (map Var frees)
1137                     Nothing)
1138      }
1139   where unType (Type name) = name
1140         unType _             = error "incorrect type style"
1141 new env typ _ (Just inner) = error "cant handle inner class with args"
1142
1143
1144 liftClass :: Env -> TypeName -> [Decl] -> [TypeName] -> [TypeName] -> LifterM [ Name ]
1145 liftClass env@(Env bound _) innerName inner xs is =
1146   do { let newBound = getBoundAtDecls inner
1147      ; (inner,frees) <-
1148            getFrees (liftDecls False (env `combineEnv` newBound) inner)
1149      ; let trueFrees = filter (\ (Name xs _) -> xs /= "VM") (both frees bound)
1150      ; let freeDefs = [ Field [Final] n Nothing | n <- trueFrees ]
1151      ; let cons = mkCons innerName trueFrees
1152      ; let innerClass = Class [] innerName xs is (freeDefs ++ [cons] ++ inner)
1153      ; rememberClass innerClass
1154      ; return trueFrees
1155      }
1156
1157 liftType :: Env -> Type -> Type
1158 liftType (Env _ env) typ@(Type name)
1159    = case lookup name env of
1160         Nothing     -> typ
1161         Just (nm,_) -> Type nm
1162 liftType _           typ = typ
1163
1164 liftNew :: Env -> Type -> [Expr] -> Expr
1165 liftNew (Env _ env) typ@(Type name) exprs
1166    = case lookup name env of
1167         Nothing                     -> New typ exprs Nothing
1168         Just (nm,args) | null exprs
1169                 -> New (Type nm) (map Var args) Nothing
1170         _ -> error "pre-lifted constructor with arguments"
1171 \end{code}