ghc/compiler/javaGen/JavaGen.lhs

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