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