ghc/compiler/javaGen/JavaGen.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
   3 %
   4 \section{Generate Java}
   5
   6 Name mangling for Java.
   7 ~~~~~~~~~~~~~~~~~~~~~~
   8
   9 Haskell has a number of namespaces. The Java translator uses
  10 the standard Haskell mangles (see OccName.lhs), and some extra
  11 mangles.
  12
  13 All names are hidden inside packages.
  14
  15 module name:
  16   - becomes a first level java package.
  17   - can not clash with java, because haskell modules are upper case,
  18      java default packages are lower case.
  19
  20 function names:
  21   - these turn into classes
  22   - java keywords (eg. private) have the suffix "zdk" ($k) added.
  23
  24 data *types*
  25   - These have a base class, so need to appear in the
  26     same name space as other object. for example data Foo = Foo
  27   - We add a postfix to types: "zdt" ($t)
  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 \begin{code}
  41 module JavaGen( javaGen ) where
  42
  43 import Java
  44
  45 import Literal  ( Literal(..) )
  46 import Id       ( Id, isDataConId_maybe, isId, idName, isDeadBinder, idPrimRep )
  47 import Name     ( NamedThing(..), getOccString, isGlobalName
  48                 , nameModule )
  49 import PrimRep  ( PrimRep(..) )
  50 import DataCon  ( DataCon, dataConRepArity, dataConRepArgTys, dataConId )
  51 import qualified TypeRep
  52 import qualified Type
  53 import qualified CoreSyn
  54 import CoreSyn  ( CoreBind, CoreExpr, CoreAlt, CoreBndr,
  55                   Bind(..), Alt, AltCon(..), collectBinders, isValArg
  56                 )
  57 import CoreUtils( exprIsValue, exprIsTrivial )
  58 import Module   ( Module, moduleString )
  59 import TyCon    ( TyCon, isDataTyCon, tyConDataCons )
  60 import Outputable
  61
  62 #include "HsVersions.h"
  63
  64 \end{code}
  65
  66
  67 \begin{code}
  68 javaGen :: Module -> [Module] -> [TyCon] -> [CoreBind] -> CompilationUnit
  69
  70 javaGen mod import_mods tycons binds
  71   = id {-liftCompilationUnit-} package
  72   where
  73     decls = [Import "haskell.runtime.*"] ++
  74             [Import (moduleString mod) | mod <- import_mods] ++
  75             concat (map javaTyCon (filter isDataTyCon tycons)) ++
  76             concat (map javaTopBind binds)
  77     package = Package (moduleString mod) decls
  78 \end{code}
  79
  80
  81 %************************************************************************
  82 %*                                                                      *
  83 \subsection{Type declarations}
  84 %*                                                                      *
  85 %************************************************************************
  86
  87 \begin{code}
  88 javaTyCon :: TyCon -> [Decl]
  89 --      public class List {}
  90 --
  91 --      public class $wCons extends List {
  92 --              Object f1; Object f2
  93 --      }
  94 --      public class $wNil extends List {}
  95
  96 javaTyCon tycon
  97   = tycon_jclass : concat (map constr_class constrs)
  98   where
  99     constrs = tyConDataCons tycon
 100     tycon_jclass_jname =  javaGlobTypeName tycon ++ "zdc"
 101     tycon_jclass = Class [Public] (shortName tycon_jclass_jname) [] [] []
 102
 103     constr_class data_con
 104         = [ Class [Public] (shortName constr_jname) [tycon_jclass_jname] []
 105                                 (field_decls ++ [cons_meth,debug_meth])
 106           ]
 107         where
 108           constr_jname = javaConstrWkrName data_con
 109           constr_jtype = javaConstrWkrType data_con
 110
 111           field_names  = constrToFields data_con
 112           field_decls  = [ Field [Public] n Nothing
 113                          | n <- field_names
 114                          ]
 115
 116           cons_meth    = mkCons (shortName constr_jname) field_names
 117
 118           debug_meth   = Method [Public] (Name "toString" stringType)
 119                                          []
 120                                          []
 121                        (  [ Declaration (Field [] txt Nothing) ]
 122                        ++ [ ExprStatement
 123                                 (Assign (Var txt)
 124                                             (mkStr
 125                                                 ("( " ++
 126                                                   getOccString data_con ++
 127                                                   " ")
 128                                              )
 129                                 )
 130                           ]
 131                        ++ [ ExprStatement
 132                                 (Assign (Var txt)
 133                                    (Op (Var txt)
 134                                         "+"
 135                                        (Op (Var n) "+" litSp)
 136                                    )
 137                                 )
 138                           | n <- field_names
 139                           ]
 140                        ++ [ Return (Op (Var txt)
 141                                         "+"
 142                                       (mkStr ")")
 143                                    )
 144                           ]
 145                        )
 146
 147           litSp    = mkStr " "
 148           txt      = Name "__txt" stringType
 149
 150
 151 mkNew :: Type -> [Expr] -> Expr
 152 mkNew t@(PrimType primType) [] = error "new primitive???"
 153 mkNew t@(Type _)            es = New t es Nothing
 154 mkNew _                     _  = error "new with strange arguments"
 155
 156 constrToFields :: DataCon -> [Name]
 157 constrToFields cons =
 158         [ fieldName i t
 159         | (i,t) <- zip [1..] (map javaTauType (dataConRepArgTys cons))
 160         ]
 161
 162 mkCons :: TypeName -> [Name] -> Decl
 163 mkCons name args = Constructor [Public] name
 164         [ Parameter [] n | n <- args ]
 165         [ ExprStatement (Assign
 166                            (Access this n)
 167                            (Var n)
 168                          )
 169                     | n <- args ]
 170
 171 mkStr :: String -> Expr
 172 mkStr str = Literal (StringLit str)
 173 \end{code}
 174
 175 %************************************************************************
 176 %*                                                                      *
 177 \subsection{Bindings}
 178 %*                                                                      *
 179 %************************************************************************
 180
 181 \begin{code}
 182 javaTopBind :: CoreBind -> [Decl]
 183 javaTopBind (NonRec bndr rhs) = [java_top_bind bndr rhs]
 184 javaTopBind (Rec prs)         = [java_top_bind bndr rhs | (bndr,rhs) <- prs]
 185
 186 java_top_bind :: Id -> CoreExpr -> Decl
 187 --      public class f implements Code {
 188 --        public Object ENTER() { ...translation of rhs... }
 189 --      }
 190 java_top_bind bndr rhs
 191   = Class [Public] (shortName (javaGlobTypeName bndr))
 192                 [] [codeName] [enter_meth]
 193   where
 194     enter_meth = Method [Public] enterName [vmArg] [excName]
 195                         (javaExpr vmRETURN rhs)
 196 \end{code}
 197
 198
 199 %************************************************************************
 200 %*                                                                      *
 201 \subsection{Expressions}
 202 %*                                                                      *
 203 %************************************************************************
 204
 205 \begin{code}
 206 javaVar :: Id -> Expr
 207 javaVar v | isGlobalName (idName v) = mkNew (javaGlobType v) []
 208           | otherwise               = Var (javaName v)
 209
 210 javaLit :: Literal.Literal -> Expr
 211 javaLit (MachInt i)  = Literal (IntLit (fromInteger i))
 212 javaLit (MachChar c) = Literal (CharLit c)
 213 javaLit other        = pprPanic "javaLit" (ppr other)
 214
 215 javaExpr :: (Expr -> Expr) -> CoreExpr -> [Statement]
 216 -- Generate code to apply the value of
 217 -- the expression to the arguments aleady on the stack
 218 javaExpr r (CoreSyn.Var v)   = [Return (r (javaVar v))]
 219 javaExpr r (CoreSyn.Lit l)   = [Return (r (javaLit l))]
 220 javaExpr r (CoreSyn.App f a) = javaApp r f [a]
 221 javaExpr r e@(CoreSyn.Lam _ _) = javaLam r (collectBinders e)
 222 javaExpr r (CoreSyn.Case e x alts) = javaCase r e x alts
 223 javaExpr r (CoreSyn.Let bind body) = javaBind bind ++ javaExpr r body
 224 javaExpr r (CoreSyn.Note _ e)    = javaExpr r e
 225
 226 javaCase :: (Expr -> Expr) -> CoreExpr -> Id -> [CoreAlt] -> [Statement]
 227 --      case e of x { Nil      -> r1
 228 --                    Cons p q -> r2 }
 229 -- ==>
 230 --      final Object x = VM.WHNF(...code for e...)
 231 --      else if x instance_of Nil {
 232 --              ...translation of r1...
 233 --      } else if x instance_of Cons {
 234 --              final Object p = ((Cons) x).f1
 235 --              final Object q = ((Cons) x).f2
 236 --              ...translation of r2...
 237 --      } else return null
 238
 239 javaCase r e x alts
 240   =  [var [Final] (javaName x) (vmWHNF (javaArg e)),
 241       IfThenElse (map mk_alt alts) Nothing]
 242   where
 243      mk_alt (DEFAULT, [], rhs)   = (true,           Block (javaExpr r rhs))
 244      mk_alt (DataAlt d, bs, rhs) = (instanceOf x d, Block (bind_args d bs ++ javaExpr r rhs))
 245      mk_alt alt@(LitAlt lit, [], rhs)
 246                                  = (eqLit lit     , Block (javaExpr r rhs))
 247      mk_alt alt@(LitAlt _, _, _) = pprPanic "mk_alt" (ppr alt)
 248
 249
 250      eqLit (MachInt n) = Op (Literal (IntLit n))
 251                             "=="
 252                             (Var (javaName x))
 253      eqLit other       = pprPanic "eqLit" (ppr other)
 254
 255      bind_args d bs = [var [Final] (javaName b)
 256                            (Access (Cast (javaConstrWkrType d) (javaVar x)
 257                                    ) f
 258                            )
 259                       | (b,f) <- filter isId bs
 260                                       `zip` (constrToFields d)
 261                       , not (isDeadBinder b)
 262                       ]
 263
 264 javaBind (NonRec x rhs)
 265 {-
 266         x = ...rhs_x...
 267   ==>
 268         final Object x = new Thunk( new Code() { ...code for rhs_x... } )
 269 -}
 270   = [var [Final] (javaLocName x objectType)
 271                  (newThunk (newCode (javaExpr vmRETURN rhs)))
 272     ]
 273
 274 javaBind (Rec prs)
 275 {-      rec { x = ...rhs_x...; y = ...rhs_y... }
 276   ==>
 277         class x implements Code {
 278           Code x, y;
 279           public Object ENTER() { ...code for rhs_x...}
 280         }
 281         ...ditto for y...
 282
 283         final x x_inst = new x();
 284         ...ditto for y...
 285
 286         final Thunk x = new Thunk( x_inst );
 287         ...ditto for y...
 288
 289         x_inst.x = x;
 290         x_inst.y = y;
 291         ...ditto for y...
 292 -}
 293   = (map mk_class prs) ++ (map mk_inst prs) ++
 294     (map mk_thunk prs) ++ concat (map mk_knot prs)
 295   where
 296     mk_class (b,r) = Declaration (Class [] class_name [] [codeName] stmts)
 297                    where
 298                      class_name = javaLocTypeName b
 299                      stmts = [Field [] (javaLocName b codeType) Nothing | (b,_) <- prs] ++
 300                              [Method [Public] enterName [vmArg] [excName] (javaExpr vmRETURN r)]
 301
 302     mk_inst (b,r) = var [Final] (javaInstName b)
 303                         (mkNew (javaGlobType b) [])
 304
 305     mk_thunk (b,r) = var [Final] (javaLocName b thunkType)
 306                          (New thunkType [Var (javaInstName b)] Nothing)
 307
 308     mk_knot (b,_) = [ ExprStatement (Assign lhs rhs)
 309                     | (b',_) <- prs,
 310                       let lhs = Access (Var (javaInstName b)) (javaName b'),
 311                       let rhs = Var (javaName b')
 312                     ]
 313
 314
 315 -- We are needlessly
 316 javaLam :: (Expr -> Expr) -> ([CoreBndr], CoreExpr) -> [Statement]
 317 javaLam r (bndrs, body)
 318   | null val_bndrs = javaExpr r body
 319   | otherwise
 320   =  vmCOLLECT (length val_bndrs) this
 321   ++ [var [Final] n (vmPOP t) | n@(Name _ t) <- val_bndrs]
 322   ++ javaExpr r body
 323   where
 324     val_bndrs = map javaName (filter isId bndrs)
 325
 326 javaApp :: (Expr -> Expr) -> CoreExpr -> [CoreExpr] -> [Statement]
 327 javaApp r (CoreSyn.App f a) as = javaApp r f (a:as)
 328 javaApp r (CoreSyn.Var f) as
 329   = case isDataConId_maybe f of {
 330         Just dc | length as == dataConRepArity dc
 331                 ->      -- Saturated constructors
 332                    [Return (New (javaGlobType f) (javaArgs as) Nothing)]
 333     ; other ->   -- Not a saturated constructor
 334         java_apply r (CoreSyn.Var f) as
 335     }
 336
 337 javaApp r f as = java_apply r f as
 338
 339 java_apply :: (Expr -> Expr) -> CoreExpr -> [CoreExpr] -> [Statement]
 340 java_apply r f as = [ExprStatement (vmPUSH arg) | arg <- javaArgs as] ++ javaExpr r f
 341 javaArgs :: [CoreExpr] -> [Expr]
 342 javaArgs args = [javaArg a | a <- args, isValArg a]
 343
 344 javaArg :: CoreExpr -> Expr
 345 javaArg (CoreSyn.Type t) = pprPanic "javaArg" (ppr t)
 346 javaArg e | exprIsValue e || exprIsTrivial e = newCode (javaExpr id e)
 347           | otherwise                        = newThunk (newCode (javaExpr id e))
 348 \end{code}
 349
 350 %************************************************************************
 351 %*                                                                      *
 352 \subsection{Helper functions}
 353 %*                                                                      *
 354 %************************************************************************
 355
 356 \begin{code}
 357 true, this :: Expr
 358 this = Var thisName
 359 true = Var (Name "true" (PrimType PrimBoolean))
 360
 361 vmCOLLECT :: Int -> Expr -> [Statement]
 362 vmCOLLECT 0 e = []
 363 vmCOLLECT n e = [ExprStatement
 364                     (Call varVM collectName
 365                         [ Literal (IntLit (toInteger n))
 366                         , e
 367                         ]
 368                     )
 369                 ]
 370
 371 vmPOP :: Type -> Expr
 372 vmPOP ty = Call varVM (Name ("POP" ++ suffix ty) ty) []
 373
 374 vmPUSH :: Expr -> Expr
 375 vmPUSH e = Call varVM (Name ("PUSH" ++ suffix (exprType e)) void) [e]
 376
 377 vmRETURN :: Expr -> Expr
 378 vmRETURN e =
 379      case ty of
 380         PrimType _ -> Call varVM (Name ("RETURN" ++ suffix (exprType e))
 381                                        valueType
 382                                   ) [e]
 383         _ -> e
 384   where
 385         ty = exprType e
 386
 387 var :: [Modifier] -> Name -> Expr -> Statement
 388 var ms field_name value = Declaration (Field ms field_name (Just value))
 389
 390 vmWHNF :: Expr -> Expr
 391 vmWHNF e = Call varVM whnfName [e]
 392
 393 suffix :: Type -> String
 394 suffix (PrimType t) = primName t
 395 suffix _            = ""
 396
 397 primName :: PrimType -> String
 398 primName PrimInt  = "int"
 399 primName PrimChar = "char"
 400 primName _         = error "unsupported primitive"
 401
 402 varVM :: Expr
 403 varVM = Var vmName
 404
 405 instanceOf :: Id -> DataCon -> Expr
 406 instanceOf x data_con
 407   = InstanceOf (Var (javaName x)) (javaConstrWkrType data_con)
 408
 409 newCode :: [Statement] -> Expr
 410 newCode [Return e] = e
 411 newCode stmts      = New codeType [] (Just [Method [Public] enterName [vmArg] [excName] stmts])
 412
 413 newThunk :: Expr -> Expr
 414 newThunk e = New thunkType [e] Nothing
 415
 416 vmArg :: Parameter
 417 vmArg = Parameter [Final] vmName
 418 \end{code}
 419
 420 %************************************************************************
 421 %*                                                                      *
 422 \subsection{Haskell to Java Types}
 423 %*                                                                      *
 424 %************************************************************************
 425
 426 \begin{code}
 427 exprType (Var (Name _ t)) = t
 428 exprType (Literal lit)    = litType lit
 429 exprType (Cast t _)       = t
 430 exprType (New t _ _)      = t
 431 exprType _                = error "can't figure out an expression type"
 432
 433 litType (IntLit i)    = PrimType PrimInt
 434 litType (CharLit i)   = PrimType PrimChar
 435 litType (StringLit i) = error "<string?>"
 436 \end{code}
 437
 438 %************************************************************************
 439 %*                                                                      *
 440 \subsection{Name mangling}
 441 %*                                                                      *
 442 %************************************************************************
 443
 444 \begin{code}
 445 codeName, excName, thunkName :: TypeName
 446 codeName  = "haskell.runtime.Code"
 447 thunkName = "haskell.runtime.Thunk"
 448 excName   = "java.lang.Exception"
 449
 450 enterName, vmName,thisName,collectName, whnfName :: Name
 451 enterName   = Name "ENTER"   objectType
 452 vmName      = Name "VM"      vmType
 453 thisName    = Name "this"    (Type "<this>")
 454 collectName = Name "COLLECT" void
 455 whnfName    = Name "WNNF"    objectType
 456
 457 fieldName :: Int -> Type -> Name        -- Names for fields of a constructor
 458 fieldName n ty = Name ("f" ++ show n) ty
 459
 460 -- TODO: change to idToJavaName :: Id -> Name
 461
 462 javaLocName :: Id -> Type -> Name
 463 javaLocName n t = Name (getOccString n) t
 464
 465 javaName :: Id -> Name
 466 javaName n = if isGlobalName n'
 467              then Name (javaGlobTypeName n)
 468                        (javaGlobType n)
 469              else Name (getOccString n)
 470                        (Type "<loc?>")
 471   where
 472              n' = getName n
 473
 474 -- TypeName's are always global
 475 javaGlobTypeName :: NamedThing a => a -> TypeName
 476 javaGlobTypeName n = (moduleString (nameModule n') ++ "." ++ getOccString n)
 477   where
 478              n' = getName n
 479
 480 javaLocTypeName :: NamedThing a => a -> TypeName
 481 javaLocTypeName n = (moduleString (nameModule n') ++ "." ++ getOccString n)
 482   where
 483              n' = getName n
 484
 485 -- this is used for getting the name of a class when defining it.
 486 shortName :: TypeName -> TypeName
 487 shortName = reverse . takeWhile (/= '.') . reverse
 488
 489 -- The function that makes the constructor name
 490 javaConstrWkrName :: DataCon -> TypeName
 491 javaConstrWkrName con = javaGlobTypeName (dataConId con)
 492
 493 -- Makes x_inst for Rec decls
 494 javaInstName :: NamedThing a => a -> Name
 495 javaInstName n = Name (getOccString n ++ "_inst") (Type "<inst>")
 496 \end{code}
 497
 498 %************************************************************************
 499 %*                                                                      *
 500 \subsection{Types and type mangling}
 501 %*                                                                      *
 502 %************************************************************************
 503
 504 \begin{code}
 505 -- Haskell RTS types
 506 codeType, thunkType, valueType :: Type
 507 codeType   = Type codeName
 508 thunkType  = Type thunkName
 509 valueType  = Type "haskell.runtime.Value"
 510 vmType     = Type "haskell.runtime.VMEngine"
 511
 512 -- Basic Java types
 513 objectType, stringType :: Type
 514 objectType = Type "java.lang.Object"
 515 stringType = Type "java.lang.String"
 516
 517 void :: Type
 518 void = PrimType PrimVoid
 519
 520 inttype :: Type
 521 inttype = PrimType PrimInt
 522
 523 chartype :: Type
 524 chartype = PrimType PrimChar
 525
 526 -- This is where we map from type to possible primitive
 527 mkType "PrelGHC.Intzh"  = inttype
 528 mkType "PrelGHC.Charzh" = chartype
 529 mkType other            = Type other
 530
 531 -- This mapping a global haskell name (typically a function name)
 532 -- to the name of the class that handles it.
 533 -- The name must be global. So foo in module Test maps to (Type "Test.foo")
 534 -- TODO: change to Id
 535
 536 javaGlobType :: NamedThing a => a -> Type
 537 javaGlobType n | '.' `notElem` name
 538                = error ("not using a fully qualified name for javaGlobalType: " ++ name)
 539                | otherwise
 540                = mkType name
 541   where name = javaGlobTypeName n
 542
 543 -- This takes an id, and finds the ids *type* (for example, Int, Bool, a, etc).
 544 javaType :: Id -> Type
 545 javaType id = case (idPrimRep id) of
 546                 IntRep -> inttype
 547                 _ -> if isGlobalName (idName id)
 548                      then Type (javaGlobTypeName id)
 549                      else objectType            -- TODO: ?? for now ??
 550
 551 -- This is used to get inside constructors, to find out the types
 552 -- of the payload elements
 553 javaTauType :: Type.TauType -> Type
 554 javaTauType (TypeRep.TyConApp tycon _) = javaGlobType tycon
 555 javaTauType (TypeRep.NoteTy _ t)       = javaTauType t
 556 javaTauType _                          = objectType
 557
 558 -- The function that makes the constructor name
 559 javaConstrWkrType :: DataCon -> Type
 560 javaConstrWkrType con = Type (javaConstrWkrName con)
 561 \end{code}
 562
 563 %************************************************************************
 564 %*                                                                      *
 565 \subsection{Class Lifting}
 566 %*                                                                      *
 567 %************************************************************************
 568
 569 This is a very simple class lifter. It works by carrying inwards a
 570 list of bound variables (things that might need to be passed to a
 571 lifted inner class).
 572  * Any variable references is check with this list, and if it is
 573    bound, then it is not top level, external reference.
 574  * This means that for the purposes of lifting, it might be free
 575    inside a lifted inner class.
 576  * We remember these "free inside the inner class" values, and
 577    use this list (which is passed, via the monad, outwards)
 578    when lifting.
 579
 580 \begin{code}
 581 {-
 582 type Bound = [Name]
 583 type Frees = [Name]
 584
 585 combine :: [Name] -> [Name] -> [Name]
 586 combine []           names          = names
 587 combine names        []             = names
 588 combine (name:names) (name':names')
 589         | name < name' = name  : combine names (name':names')
 590         | name > name' = name' : combine (name:names) names'
 591         | name == name = name  : combine names names'
 592         | otherwise    = error "names are not a total order"
 593
 594 both :: [Name] -> [Name] -> [Name]
 595 both []           names          = []
 596 both names        []             = []
 597 both (name:names) (name':names')
 598         | name < name' = both names (name':names')
 599         | name > name' = both (name:names) names'
 600         | name == name = name  : both names names'
 601         | otherwise    = error "names are not a total order"
 602
 603 combineEnv :: Env -> [Name] -> Env
 604 combineEnv (Env bound env) new = Env (bound `combine` new) env
 605
 606 addTypeMapping :: Name -> Name -> [Name] -> Env -> Env
 607 addTypeMapping origName newName frees (Env bound env)
 608         = Env bound ((origName,(newName,frees)) : env)
 609
 610 -- This a list of bound vars (with types)
 611 -- and a mapping from types (?) to (result * [arg]) pairs
 612 data Env = Env Bound [(Name,(Name,[Name]))]
 613
 614 newtype LifterM a =
 615         LifterM { unLifterM ::
 616                      Name ->
 617                      Int -> ( a                 -- *
 618                             , Frees             -- frees
 619                             , [Decl]            -- lifted classes
 620                             , Int               -- The uniqs
 621                             )
 622                 }
 623
 624 instance Monad LifterM where
 625         return a = LifterM (\ n s -> (a,[],[],s))
 626         (LifterM m) >>= fn = LifterM (\ n s ->
 627           case m n s of
 628             (a,frees,lifted,s)
 629                  -> case unLifterM (fn a) n s of
 630                      (a,frees2,lifted2,s) -> ( a
 631                                              , combine frees frees2
 632                                              , lifted ++ lifted2
 633                                              , s)
 634           )
 635
 636 access :: Env -> Name -> LifterM ()
 637 access env@(Env bound _) name
 638         | name `elem` bound = LifterM (\ n s -> ((),[name],[],s))
 639         | otherwise         = return ()
 640
 641 scopedName :: Name -> LifterM a -> LifterM a
 642 scopedName name (LifterM m) =
 643    LifterM (\ _ s ->
 644       case m name 1 of
 645         (a,frees,lifted,_) -> (a,frees,lifted,s)
 646       )
 647
 648 genAnonInnerClassName :: LifterM Name
 649 genAnonInnerClassName = LifterM (\ n s ->
 650         ( n ++ "$" ++ show s
 651         , []
 652         , []
 653         , s + 1
 654         )
 655     )
 656
 657 genInnerClassName :: Name -> LifterM Name
 658 genInnerClassName name = LifterM (\ n s ->
 659         ( n ++ "$" ++ name
 660         , []
 661         , []
 662         , s
 663         )
 664     )
 665
 666 getFrees  :: LifterM a -> LifterM (a,Frees)
 667 getFrees (LifterM m) = LifterM (\ n s ->
 668         case m n s of
 669           (a,frees,lifted,n) -> ((a,frees),frees,lifted,n)
 670     )
 671
 672 rememberClass :: Decl -> LifterM ()
 673 rememberClass decl = LifterM (\ n s -> ((),[],[decl],s))
 674
 675
 676 liftCompilationUnit :: CompilationUnit -> CompilationUnit
 677 liftCompilationUnit (Package name ds) =
 678     Package name (concatMap liftCompilationUnit' ds)
 679
 680 liftCompilationUnit' :: Decl -> [Decl]
 681 liftCompilationUnit' decl =
 682     case unLifterM (liftDecls True (Env [] []) [decl]) [] 1 of
 683       (ds,_,ds',_) -> ds ++ ds'
 684
 685
 686 -- The bound vars for the current class have
 687 -- already be captured before calling liftDecl,
 688 -- because they are in scope everywhere inside the class.
 689
 690 liftDecl :: Bool -> Env -> Decl -> LifterM Decl
 691 liftDecl = \ top env decl ->
 692   case decl of
 693     { Import n -> return (Import n)
 694     ; Field mfs t n e ->
 695       do { e <- liftMaybeExpr env e
 696          ; return (Field mfs (liftType env t) n e)
 697          }
 698     ; Constructor mfs n as ss ->
 699       do { let newBound = getBoundAtParameters as
 700          ; (ss,_) <- liftStatements (combineEnv env newBound) ss
 701          ; return (Constructor mfs n (liftParameters env as) ss)
 702          }
 703     ; Method mfs t n as ts ss ->
 704       do { let newBound = getBoundAtParameters as
 705          ; (ss,_) <- liftStatements (combineEnv env newBound) ss
 706          ; return (Method mfs (liftType env t) n (liftParameters env as) ts ss)
 707          }
 708     ; Comment s -> return (Comment s)
 709     ; Interface mfs n is ms -> error "interfaces not supported"
 710     ; Class mfs n x is ms ->
 711       do { let newBound = getBoundAtDecls ms
 712          ; ms <- scopedName n
 713                     (liftDecls False (combineEnv env newBound) ms)
 714          ; return (Class mfs n x is ms)
 715          }
 716     }
 717
 718 liftDecls :: Bool -> Env -> [Decl] -> LifterM [Decl]
 719 liftDecls top env = mapM (liftDecl top env)
 720
 721 getBoundAtDecls :: [Decl] -> Bound
 722 getBoundAtDecls = foldr combine [] . map getBoundAtDecl
 723
 724 -- TODO
 725 getBoundAtDecl :: Decl -> Bound
 726 getBoundAtDecl (Field _ _ n _) = [n]
 727 getBoundAtDecl _               = []
 728
 729 getBoundAtParameters :: [Parameter] -> Bound
 730 getBoundAtParameters = foldr combine [] . map getBoundAtParameter
 731
 732 -- TODO
 733 getBoundAtParameter :: Parameter -> Bound
 734 getBoundAtParameter (Parameter _ _ n) = [n]
 735
 736 liftStatement :: Env -> Statement -> LifterM (Statement,Env)
 737 liftStatement = \ env stmt ->
 738   case stmt of
 739     { Skip -> return (stmt,env)
 740     ; Return e -> do { e <- liftExpr env e
 741                      ; return (Return e,env)
 742                      }
 743     ; Block ss -> do { (ss,env) <- liftStatements env ss
 744                      ; return (Block ss,env)
 745                      }
 746     ; ExprStatement e -> do { e <- liftExpr env e
 747                             ; return (ExprStatement e,env)
 748                             }
 749    ; Declaration decl@(Field mfs t n e) ->
 750       do { e <- liftMaybeExpr env e
 751          ; return ( Declaration (Field mfs t n e)
 752                   , env `combineEnv` getBoundAtDecl decl
 753                   )
 754          }
 755     ; Declaration decl@(Class mfs n x is ms) ->
 756       do { innerName <- genInnerClassName n
 757          ; frees <- liftClass env innerName ms x is
 758          ; return ( Declaration (Comment ["lifted " ++  n])
 759                   , addTypeMapping n innerName frees env
 760                   )
 761          }
 762     ; Declaration d -> error "general Decl not supported"
 763     ; IfThenElse ecs s -> ifthenelse env ecs s
 764     ; Switch e as d -> error "switch not supported"
 765     }
 766
 767 ifthenelse :: Env
 768            -> [(Expr,Statement)]
 769            -> (Maybe Statement)
 770            -> LifterM (Statement,Env)
 771 ifthenelse env pairs may_stmt =
 772   do { let (exprs,stmts) = unzip pairs
 773      ; exprs <- liftExprs env exprs
 774      ; (stmts,_) <- liftStatements env stmts
 775      ; may_stmt <- case may_stmt of
 776                       Just stmt -> do { (stmt,_) <- liftStatement env stmt
 777                                       ; return (Just stmt)
 778                                       }
 779                       Nothing -> return Nothing
 780      ; return (IfThenElse (zip exprs stmts) may_stmt,env)
 781      }
 782
 783 liftStatements :: Env -> [Statement] -> LifterM ([Statement],Env)
 784 liftStatements env []     = return ([],env)
 785 liftStatements env (s:ss) =
 786         do { (s,env) <- liftStatement env s
 787            ; (ss,env) <- liftStatements env ss
 788            ; return (s:ss,env)
 789            }
 790
 791
 792 liftExpr :: Env -> Expr -> LifterM Expr
 793 liftExpr = \ env expr ->
 794  case expr of
 795    { Var n t -> do { access env n
 796                    ; return (Var n t)
 797                    }
 798    ; Literal l _ -> return expr
 799    ; Cast t e -> do { e <- liftExpr env e
 800                     ; return (Cast (liftType env t) e)
 801                     }
 802    ; Access e n -> do { e <- liftExpr env e
 803                         -- do not consider n as an access, because
 804                         -- this is a indirection via a reference
 805                       ; return (Access e n)
 806                       }
 807    ; Assign l r -> do { l <- liftExpr env l
 808                       ; r <- liftExpr env r
 809                       ; return (Assign l r)
 810                       }
 811    ; InstanceOf e t -> do { e <- liftExpr env e
 812                           ; return (InstanceOf e (liftType env t))
 813                           }
 814    ; Call e n es -> do { e <- liftExpr env e
 815                        ; es <- mapM (liftExpr env) es
 816                        ; return (Call e n es)
 817                        }
 818    ; Op e1 o e2 -> do { e1 <- liftExpr env e1
 819                       ; e2 <- liftExpr env e2
 820                       ; return (Op e1 o e2)
 821                       }
 822    ; New n es ds -> new env n es ds
 823    }
 824
 825 liftParameter env (Parameter ms t n) = Parameter ms (liftType env t) n
 826 liftParameters env = map (liftParameter env)
 827
 828 liftExprs :: Env -> [Expr] -> LifterM [Expr]
 829 liftExprs = mapM . liftExpr
 830
 831 liftMaybeExpr :: Env -> (Maybe Expr) -> LifterM (Maybe Expr)
 832 liftMaybeExpr env Nothing     = return Nothing
 833 liftMaybeExpr env (Just stmt) = do { stmt <- liftExpr env stmt
 834                                      ; return (Just stmt)
 835                                      }
 836
 837
 838 new :: Env -> Type -> [Expr] -> Maybe [Decl] -> LifterM Expr
 839 new env@(Env _ pairs) typ args Nothing =
 840   do { args <- liftExprs env args
 841      ; return (listNew env typ args)
 842      }
 843 new env typ [] (Just inner) =
 844   -- anon. inner class
 845   do { innerName <- genAnonInnerClassName
 846      ; frees <- liftClass env innerName inner [] [unType typ]
 847      ; return (New (Type (innerName))
 848               [ Var name (Type "<arg>") | name <- frees ] Nothing)
 849      }
 850   where unType (Type name) = name
 851         unType _             = error "incorrect type style"
 852
 853 new env typ _ (Just inner) = error "cant handle inner class with args"
 854
 855 liftClass :: Env -> Name -> [Decl] -> [Name] -> [Name] -> LifterM [ Name ]
 856 liftClass env@(Env bound _) innerName inner xs is =
 857   do { let newBound = getBoundAtDecls inner
 858      ; (inner,frees) <-
 859            getFrees (liftDecls False (env `combineEnv` newBound) inner)
 860      ; let trueFrees = filter (\ xs -> xs /= "VM") (both frees bound)
 861      ; let freeDefs = [ Field [Final] objectType n Nothing | n <- trueFrees ]
 862      ; let cons = mkCons innerName [(name,objectType) | name <- trueFrees ]
 863      ; let innerClass = Class [] innerName xs is (freeDefs ++ [cons] ++ inner)
 864      ; rememberClass innerClass
 865      ; return trueFrees
 866      }
 867
 868 liftType :: Env -> Type -> Type
 869 liftType (Env _ env) typ@(Type name)
 870    = case lookup name env of
 871         Nothing     -> typ
 872         Just (nm,_) -> Type nm
 873 liftType _           typ = typ
 874
 875 liftNew :: Env -> Type -> [Expr] -> Expr
 876 liftNew (Env _ env) typ@(Type name) exprs
 877    = case lookup name env of
 878         Nothing                     -> New typ exprs Nothing
 879         Just (nm,args) | null exprs
 880                 -> New (Type nm) (map (\ v -> Var v (Type "<arg>")) args) Nothing
 881         _ -> error "pre-lifted constructor with arguments"
 882 listNew _           typ exprs = New typ exprs Nothing
 883
 884 -}
 885 \end{code}