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