ghc/compiler/javaGen/JavaGen.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section{Generate Java}
   5
   6 \begin{code}
   7 module JavaGen( javaGen ) where
   8
   9 import Java
  10
  11 import Literal  ( Literal(..) )
  12 import Id       ( Id, isDataConId_maybe, isId, idName, isDeadBinder )
  13 import Name     ( NamedThing(..), getOccString, isGlobalName )
  14 import DataCon  ( DataCon, dataConRepArity, dataConId )
  15 import qualified CoreSyn
  16 import CoreSyn  ( CoreBind, CoreExpr, CoreAlt, CoreBndr,
  17                   Bind(..), Alt, AltCon(..), collectBinders, isValArg
  18                 )
  19 import CoreUtils( exprIsValue, exprIsTrivial )
  20 import Module   ( Module, moduleString )
  21 import TyCon    ( TyCon, isDataTyCon, tyConDataCons )
  22 import Outputable
  23
  24 #include "HsVersions.h"
  25
  26 \end{code}
  27
  28
  29 \begin{code}
  30 javaGen :: Module -> [Module] -> [TyCon] -> [CoreBind] -> CompilationUnit
  31
  32 javaGen mod import_mods tycons binds
  33   = liftCompilationUnit package
  34   where
  35     decls = [Import [moduleString mod] | mod <- import_mods] ++
  36             concat (map javaTyCon (filter isDataTyCon tycons)) ++
  37             concat (map javaTopBind binds)
  38     package = Package (moduleString mod) decls
  39 \end{code}
  40
  41
  42 %************************************************************************
  43 %*                                                                      *
  44 \subsection{Type declarations}
  45 %*                                                                      *
  46 %************************************************************************
  47
  48 \begin{code}
  49 javaTyCon :: TyCon -> [Decl]
  50 --      public class List {}
  51 --
  52 --      public class $wCons extends List {
  53 --              Object f1; Object f2
  54 --      }
  55 --      public class $wNil extends List {}
  56
  57 javaTyCon tycon
  58   = tycon_jclass : map constr_class constrs
  59   where
  60     constrs = tyConDataCons tycon
  61     tycon_jclass_jname = javaName tycon
  62     tycon_jclass = Class [Public] tycon_jclass_jname [] [] []
  63
  64     constr_class data_con
  65         = Class [Public] constr_jname [tycon_jclass_jname] [] field_decls
  66         where
  67           constr_jname = javaConstrWkrName data_con
  68           constr_jtype = javaConstrWkrType data_con
  69           enter_meth   = Method [Public] objectType enterName [] stmts
  70           n_val_args   = dataConRepArity data_con
  71           field_names  = map fieldName [1..n_val_args]
  72           field_decls  = [Field [Public] objectType f Nothing | f <- field_names]
  73           stmts        = vmCOLLECT n_val_args (Var thisName) ++
  74                          [var [Final] objectType f vmPOP | f <- field_names] ++
  75                          [Return (New constr_jtype (map Var field_names) Nothing)]
  76 \end{code}
  77
  78 %************************************************************************
  79 %*                                                                      *
  80 \subsection{Bindings}
  81 %*                                                                      *
  82 %************************************************************************
  83
  84 \begin{code}
  85 javaTopBind :: CoreBind -> [Decl]
  86 javaTopBind (NonRec bndr rhs) = [java_top_bind bndr rhs]
  87 javaTopBind (Rec prs)         = [java_top_bind bndr rhs | (bndr,rhs) <- prs]
  88
  89 java_top_bind :: Id -> CoreExpr -> Decl
  90 --      public class f implements Code {
  91 --        public Object ENTER() { ...translation of rhs... }
  92 --      }
  93 java_top_bind bndr rhs
  94   = Class [Public] (javaName bndr) [] [codeName] [enter_meth]
  95   where
  96     enter_meth = Method [Public] objectType enterName [] (javaExpr rhs)
  97 \end{code}
  98
  99
 100 %************************************************************************
 101 %*                                                                      *
 102 \subsection{Expressions}
 103 %*                                                                      *
 104 %************************************************************************
 105
 106 \begin{code}
 107 javaVar :: Id -> Expr
 108 javaVar v | isGlobalName (idName v) = New (javaType v) [] Nothing
 109           | otherwise               = Var (javaName v)
 110
 111 javaLit :: Literal.Literal -> Lit
 112 javaLit (MachInt i)  = UIntLit (fromInteger i)
 113 javaLit (MachChar c) = UCharLit c
 114 javaLit other        = pprPanic "javaLit" (ppr other)
 115
 116 javaExpr :: CoreExpr -> [Statement]
 117 -- Generate code to apply the value of
 118 -- the expression to the arguments aleady on the stack
 119 javaExpr (CoreSyn.Var v)   = [Return (javaVar v)]
 120 javaExpr (CoreSyn.Lit l)   = [Return (Literal (javaLit l))]
 121 javaExpr (CoreSyn.App f a) = javaApp f [a]
 122 javaExpr e@(CoreSyn.Lam _ _) = javaLam (collectBinders e)
 123 javaExpr (CoreSyn.Case e x alts) = javaCase e x alts
 124 javaExpr (CoreSyn.Let bind body) = javaBind bind ++ javaExpr body
 125 javaExpr (CoreSyn.Note _ e)      = javaExpr e
 126
 127 javaCase :: CoreExpr -> Id -> [CoreAlt] -> [Statement]
 128 --      case e of x { Nil      -> r1
 129 --                    Cons p q -> r2 }
 130 -- ==>
 131 --      final Object x = VM.WHNF(...code for e...)
 132 --      else if x instance_of Nil {
 133 --              ...translation of r1...
 134 --      } else if x instance_of Cons {
 135 --              final Object p = ((Cons) x).f1
 136 --              final Object q = ((Cons) x).f2
 137 --              ...translation of r2...
 138 --      } else return null
 139
 140 javaCase e x alts
 141   =  [var [Final] objectType (javaName x) (vmWHNF (javaArg e)),
 142       IfThenElse (map mk_alt alts) Nothing]
 143   where
 144      mk_alt (DEFAULT, [], rhs)   = (true,           Block (javaExpr rhs))
 145      mk_alt (DataAlt d, bs, rhs) = (instanceOf x d, Block (bind_args d bs ++ javaExpr rhs))
 146      mk_alt alt@(LitAlt _, _, _) = pprPanic "mk_alt" (ppr alt)
 147
 148      bind_args d bs = [var [Final] objectType (javaName b)
 149                            (Access (Cast (javaConstrWkrType d) (javaVar x)) f)
 150                       | (b, f) <- filter isId bs `zip` map fieldName [1..],
 151                         not (isDeadBinder b)
 152                       ]
 153
 154 javaBind (NonRec x rhs)
 155 {-
 156         x = ...rhs_x...
 157   ==>
 158         final Object x = new Thunk( new Code() { ...code for rhs_x... } )
 159 -}
 160   = [var [Final] objectType (javaName x) (javaArg rhs)]
 161
 162 javaBind (Rec prs)
 163 {-      rec { x = ...rhs_x...; y = ...rhs_y... }
 164   ==>
 165         class x implements Code {
 166           Code x, y;
 167           public Object ENTER() { ...code for rhs_x...}
 168         }
 169         ...ditto for y...
 170
 171         final x x_inst = new x();
 172         ...ditto for y...
 173
 174         final Thunk x = new Thunk( x_inst );
 175         ...ditto for y...
 176
 177         x_inst.x = x;
 178         x_inst.y = y;
 179         ...ditto for y...
 180 -}
 181   = (map mk_class prs) ++ (map mk_inst prs) ++
 182     (map mk_thunk prs) ++ concat (map mk_knot prs)
 183   where
 184     mk_class (b,r) = Declaration (Class [] (javaName b) [] [codeName] stmts)
 185                    where
 186                      stmts = [Field [] codeType (javaName b) Nothing | (b,_) <- prs] ++
 187                              [Method [Public] objectType enterName [] (javaExpr r)]
 188
 189     mk_inst (b,r) = var [Final] (javaType b) (javaInstName b)
 190                         (New (javaType b) [] Nothing)
 191
 192     mk_thunk (b,r) = var [Final] thunkType (javaName b)
 193                          (New thunkType [Var (javaInstName b)] Nothing)
 194
 195     mk_knot (b,_) = [ExprStatement (Assign lhs rhs)
 196                     | (b',_) <- prs,
 197                       let lhs = Access (Var (javaInstName b)) (javaName b'),
 198                       let rhs = Var (javaName b')
 199                     ]
 200
 201 javaLam :: ([CoreBndr], CoreExpr) -> [Statement]
 202 javaLam (bndrs, body)
 203   | null val_bndrs = javaExpr body
 204   | otherwise
 205   =  vmCOLLECT (length val_bndrs) (Var thisName)
 206   ++ [var [Final] objectType (javaName n) vmPOP | n <- val_bndrs]
 207   ++ javaExpr body
 208   where
 209     val_bndrs = filter isId bndrs
 210
 211 javaApp :: CoreExpr -> [CoreExpr] -> [Statement]
 212 javaApp (CoreSyn.App f a) as = javaApp f (a:as)
 213 javaApp (CoreSyn.Var f) as
 214   = case isDataConId_maybe f of {
 215         Just dc | length as == dataConRepArity dc
 216                 ->      -- Saturated constructors
 217                    [Return (New (javaType f) (javaArgs as) Nothing)]
 218
 219     ; other ->   -- Not a saturated constructor
 220         java_apply (CoreSyn.Var f) as
 221     }
 222
 223 javaApp f as = java_apply f as
 224
 225 java_apply :: CoreExpr -> [CoreExpr] -> [Statement]
 226 java_apply f as = [ExprStatement (vmPUSH arg) | arg <- javaArgs as] ++ javaExpr f
 227
 228 javaArgs :: [CoreExpr] -> [Expr]
 229 javaArgs args = [javaArg a | a <- args, isValArg a]
 230
 231 javaArg :: CoreExpr -> Expr
 232 javaArg (CoreSyn.Type t) = pprPanic "javaArg" (ppr t)
 233 javaArg e | exprIsValue e || exprIsTrivial e = newCode (javaExpr e)
 234           | otherwise                        = newThunk (newCode (javaExpr e))
 235 \end{code}
 236
 237 %************************************************************************
 238 %*                                                                      *
 239 \subsection{Helper functions}
 240 %*                                                                      *
 241 %************************************************************************
 242
 243 \begin{code}
 244 true, this :: Expr
 245 this = Var thisName
 246
 247 true = Var "true"
 248
 249 vmCOLLECT :: Int -> Expr -> [Statement]
 250 vmCOLLECT 0 e = []
 251 vmCOLLECT n e = [ExprStatement (Call (Var vmName) "COLLECT" [Literal (IntLit n), e])]
 252
 253 vmPOP :: Expr
 254 vmPOP = Call (Var vmName) "POP" []
 255
 256 vmPUSH :: Expr -> Expr
 257 vmPUSH e = Call (Var vmName) "PUSH" [e]
 258
 259 var :: [Modifier] -> Type -> Name -> Expr -> Statement
 260 var ms ty field_name value = Declaration (Field ms ty field_name (Just value))
 261
 262 vmWHNF :: Expr -> Expr
 263 vmWHNF e = Call (Var vmName) "WHNF" [e]
 264
 265 instanceOf :: Id -> DataCon -> Expr
 266 instanceOf x data_con
 267   = InstanceOf (Var (javaName x)) (javaConstrWkrType data_con)
 268
 269 newCode :: [Statement] -> Expr
 270 newCode [Return e] = e
 271 newCode stmts      = New codeType [] (Just [Method [Public] objectType enterName [] stmts])
 272
 273 newThunk :: Expr -> Expr
 274 newThunk e = New thunkType [e] Nothing
 275 \end{code}
 276
 277 %************************************************************************
 278 %*                                                                      *
 279 \subsection{Name mangling}
 280 %*                                                                      *
 281 %************************************************************************
 282
 283 \begin{code}
 284 codeName, enterName, vmName :: Name
 285 codeName  = "Code"
 286 thunkName = "Thunk"
 287 enterName = "ENTER"
 288 vmName    = "VM"
 289 thisName  = "this"
 290
 291 fieldName :: Int -> Name        -- Names for fields of a constructor
 292 fieldName n = "f" ++ show n
 293
 294 javaName :: NamedThing a => a -> Name
 295 javaName n = getOccString n
 296
 297 javaConstrWkrName :: DataCon -> Name
 298 -- The function that makes the constructor
 299 javaConstrWkrName con = getOccString (dataConId con)
 300
 301 javaInstName :: NamedThing a => a -> Name
 302 -- Makes x_inst for Rec decls
 303 javaInstName n = getOccString n ++ "_inst"
 304 \end{code}
 305
 306 %************************************************************************
 307 %*                                                                      *
 308 \subsection{Type mangling}
 309 %*                                                                      *
 310 %************************************************************************
 311
 312 \begin{code}
 313 javaType :: NamedThing a => a -> Type
 314 javaType n = Type [javaName n]
 315
 316 javaConstrWkrType :: DataCon -> Type
 317 -- The function that makes the constructor
 318 javaConstrWkrType con = Type [javaConstrWkrName con]
 319
 320 codeType, thunkType, objectType :: Type
 321 objectType = Type ["Object"]
 322 codeType   = Type [codeName]
 323 thunkType  = Type [thunkName]
 324 \end{code}
 325
 326 %************************************************************************
 327 %*                                                                      *
 328 \subsection{Class Lifting}
 329 %*                                                                      *
 330 %************************************************************************
 331
 332 This is a very simple class lifter. It works by carrying inwards a
 333 list of bound variables (things that might need to be passed to a
 334 lifted inner class).
 335  * Any variable references is check with this list, and if it is
 336    bound, then it is not top level, external reference.
 337  * This means that for the purposes of lifting, it might be free
 338    inside a lifted inner class.
 339  * We remember these "free inside the inner class" values, and
 340    use this list (which is passed, via the monad, outwards)
 341    when lifting.
 342
 343 \begin{code}
 344 type Bound = [Name]
 345 type Frees = [Name]
 346
 347 combine :: [Name] -> [Name] -> [Name]
 348 combine []           names          = names
 349 combine names        []             = names
 350 combine (name:names) (name':names')
 351         | name < name' = name  : combine names (name':names')
 352         | name > name' = name' : combine (name:names) names'
 353         | name == name = name  : combine names names'
 354         | otherwise    = error "names are not a total order"
 355
 356 both :: [Name] -> [Name] -> [Name]
 357 both []           names          = []
 358 both names        []             = []
 359 both (name:names) (name':names')
 360         | name < name' = both names (name':names')
 361         | name > name' = both (name:names) names'
 362         | name == name = name  : both names names'
 363         | otherwise    = error "names are not a total order"
 364
 365 combineEnv :: Env -> [Name] -> Env
 366 combineEnv (Env bound env) new = Env (bound `combine` new) env
 367
 368 addTypeMapping :: Name -> Name -> [Name] -> Env -> Env
 369 addTypeMapping origName newName frees (Env bound env)
 370         = Env bound ((origName,(newName,frees)) : env)
 371
 372 data Env = Env Bound [(Name,(Name,[Name]))]
 373
 374 newtype LifterM a =
 375         LifterM { unLifterM ::
 376                      Name ->
 377                      Int -> ( a                 -- *
 378                             , Frees             -- frees
 379                             , [Decl]            -- lifted classes
 380                             , Int               -- The uniqs
 381                             )
 382                 }
 383
 384 instance Monad LifterM where
 385         return a = LifterM (\ n s -> (a,[],[],s))
 386         (LifterM m) >>= fn = LifterM (\ n s ->
 387           case m n s of
 388             (a,frees,lifted,s)
 389                  -> case unLifterM (fn a) n s of
 390                      (a,frees2,lifted2,s) -> ( a
 391                                              , combine frees frees2
 392                                              , lifted ++ lifted2
 393                                              , s)
 394           )
 395
 396 access :: Env -> Name -> LifterM ()
 397 access env@(Env bound _) name
 398         | name `elem` bound = LifterM (\ n s -> ((),[name],[],s))
 399         | otherwise         = return ()
 400
 401 scopedName :: Name -> LifterM a -> LifterM a
 402 scopedName name (LifterM m) =
 403    LifterM (\ _ s ->
 404       case m name 1 of
 405         (a,frees,lifted,_) -> (a,frees,lifted,s)
 406       )
 407
 408 genAnonInnerClassName :: LifterM Name
 409 genAnonInnerClassName = LifterM (\ n s ->
 410         ( n ++ "$" ++ show s
 411         , []
 412         , []
 413         , s + 1
 414         )
 415     )
 416
 417 genInnerClassName :: Name -> LifterM Name
 418 genInnerClassName name = LifterM (\ n s ->
 419         ( n ++ "$" ++ name
 420         , []
 421         , []
 422         , s
 423         )
 424     )
 425
 426 getFrees  :: LifterM a -> LifterM (a,Frees)
 427 getFrees (LifterM m) = LifterM (\ n s ->
 428         case m n s of
 429           (a,frees,lifted,n) -> ((a,frees),frees,lifted,n)
 430     )
 431
 432 rememberClass :: Decl -> LifterM ()
 433 rememberClass decl = LifterM (\ n s -> ((),[],[decl],s))
 434
 435
 436 liftCompilationUnit :: CompilationUnit -> CompilationUnit
 437 liftCompilationUnit (Package name ds) =
 438     case unLifterM (liftDecls True (Env [] []) ds) [] 1 of
 439       (ds,_,ds',_) -> Package name (ds ++ ds')
 440
 441 -- The bound vars for the current class have
 442 -- already be captured before calling liftDecl,
 443 -- because they are in scope everywhere inside the class.
 444
 445 liftDecl :: Bool -> Env -> Decl -> LifterM Decl
 446 liftDecl = \ top env decl ->
 447   case decl of
 448     { Import n -> return (Import n)
 449     ; Field mfs t n e ->
 450       do { e <- liftMaybeExpr env e
 451          ; return (Field mfs (liftType env t) n e)
 452          }
 453     ; Constructor mfs n as ss ->
 454       do { let newBound = getBoundAtParameters as
 455          ; (ss,_) <- liftStatements (combineEnv env newBound) ss
 456          ; return (Constructor mfs n (liftParameters env as) ss)
 457          }
 458     ; Method mfs t n as ss ->
 459       do { let newBound = getBoundAtParameters as
 460          ; (ss,_) <- liftStatements (combineEnv env newBound) ss
 461          ; return (Method mfs (liftType env t) n (liftParameters env as) ss)
 462          }
 463     ; Comment s -> return (Comment s)
 464     ; Interface mfs n is ms -> error "interfaces not supported"
 465     ; Class mfs n x is ms ->
 466       do { let newBound = getBoundAtDecls ms
 467          ; ms <- scopedName n
 468                     (liftDecls False (combineEnv env newBound) ms)
 469          ; return (Class mfs n x is ms)
 470          }
 471     }
 472
 473 liftDecls :: Bool -> Env -> [Decl] -> LifterM [Decl]
 474 liftDecls top env = mapM (liftDecl top env)
 475
 476 getBoundAtDecls :: [Decl] -> Bound
 477 getBoundAtDecls = foldr combine [] . map getBoundAtDecl
 478
 479 -- TODO
 480 getBoundAtDecl :: Decl -> Bound
 481 getBoundAtDecl (Field _ _ n _) = [n]
 482 getBoundAtDecl _               = []
 483
 484 getBoundAtParameters :: [Parameter] -> Bound
 485 getBoundAtParameters = foldr combine [] . map getBoundAtParameter
 486
 487 -- TODO
 488 getBoundAtParameter :: Parameter -> Bound
 489 getBoundAtParameter (Parameter _ _ n) = [n]
 490
 491 liftStatement :: Env -> Statement -> LifterM (Statement,Env)
 492 liftStatement = \ env stmt ->
 493   case stmt of
 494     { Skip -> return (stmt,env)
 495     ; Return e -> do { e <- liftExpr env e
 496                      ; return (Return e,env)
 497                      }
 498     ; Block ss -> do { (ss,env) <- liftStatements env ss
 499                      ; return (Block ss,env)
 500                      }
 501     ; ExprStatement e -> do { e <- liftExpr env e
 502                             ; return (ExprStatement e,env)
 503                             }
 504    ; Declaration decl@(Field mfs t n e) ->
 505       do { e <- liftMaybeExpr env e
 506          ; return ( Declaration (Field mfs t n e)
 507                   , env `combineEnv` getBoundAtDecl decl
 508                   )
 509          }
 510     ; Declaration decl@(Class mfs n x is ms) ->
 511       do { innerName <- genInnerClassName n
 512          ; frees <- liftClass env innerName ms x is
 513          ; return ( Declaration (Comment ["lifted " ++  n])
 514                   , addTypeMapping n innerName frees env
 515                   )
 516          }
 517     ; Declaration d -> error "general Decl not supported"
 518     ; IfThenElse ecs s -> ifthenelse env ecs s
 519     ; Switch e as d -> error "switch not supported"
 520     }
 521
 522 ifthenelse :: Env
 523            -> [(Expr,Statement)]
 524            -> (Maybe Statement)
 525            -> LifterM (Statement,Env)
 526 ifthenelse env pairs may_stmt =
 527   do { let (exprs,stmts) = unzip pairs
 528      ; exprs <- liftExprs env exprs
 529      ; (stmts,_) <- liftStatements env stmts
 530      ; may_stmt <- case may_stmt of
 531                       Just stmt -> do { (stmt,_) <- liftStatement env stmt
 532                                       ; return (Just stmt)
 533                                       }
 534                       Nothing -> return Nothing
 535      ; return (IfThenElse (zip exprs stmts) may_stmt,env)
 536      }
 537
 538 liftStatements :: Env -> [Statement] -> LifterM ([Statement],Env)
 539 liftStatements env []     = return ([],env)
 540 liftStatements env (s:ss) =
 541         do { (s,env) <- liftStatement env s
 542            ; (ss,env) <- liftStatements env ss
 543            ; return (s:ss,env)
 544            }
 545
 546
 547 liftExpr :: Env -> Expr -> LifterM Expr
 548 liftExpr = \ env expr ->
 549  case expr of
 550    { Var n -> do { access env n
 551                  ; return (Var n)
 552                  }
 553    ; Literal l -> return expr
 554    ; Cast t e -> do { e <- liftExpr env e
 555                     ; return (Cast (liftType env t) e)
 556                     }
 557    ; Access e n -> do { e <- liftExpr env e
 558                         -- do not consider n as an access, because
 559                         -- this is a indirection via a reference
 560                       ; return (Access e n)
 561                       }
 562    ; Assign l r -> do { l <- liftExpr env l
 563                       ; r <- liftExpr env r
 564                       ; return (Assign l r)
 565                       }
 566    ; InstanceOf e t -> do { e <- liftExpr env e
 567                           ; return (InstanceOf e (liftType env t))
 568                           }
 569    ; Call e n es -> do { e <- liftExpr env e
 570                        ; es <- mapM (liftExpr env) es
 571                        ; return (Call e n es)
 572                        }
 573    ; Op e1 o e2 -> do { e1 <- liftExpr env e1
 574                       ; e2 <- liftExpr env e1
 575                       ; return (Op e1 o e2)
 576                       }
 577    ; New n es ds -> new env n es ds
 578    ; NewArray n es -> error "array not (yet) supported"
 579    }
 580
 581 liftParameter env (Parameter ms t n) = Parameter ms (liftType env t) n
 582 liftParameters env = map (liftParameter env)
 583
 584 liftExprs :: Env -> [Expr] -> LifterM [Expr]
 585 liftExprs = mapM . liftExpr
 586
 587 liftMaybeExpr :: Env -> (Maybe Expr) -> LifterM (Maybe Expr)
 588 liftMaybeExpr env Nothing     = return Nothing
 589 liftMaybeExpr env (Just stmt) = do { stmt <- liftExpr env stmt
 590                                      ; return (Just stmt)
 591                                      }
 592
 593
 594 new :: Env -> Type -> [Expr] -> Maybe [Decl] -> LifterM Expr
 595 new env@(Env _ pairs) typ args Nothing =
 596   do { args <- liftExprs env args
 597      ; return (mkNew env typ args)
 598      }
 599 new env typ [] (Just inner) =
 600   -- anon. inner class
 601   do { innerName <- genAnonInnerClassName
 602      ; frees <- liftClass env innerName inner [] []
 603      ; return (mkNew env typ [ Var name | name <- frees ])
 604      }
 605 new env typ _ (Just inner) = error "cant handle inner class with args"
 606
 607 liftClass :: Env -> Name -> [Decl] -> [Name] -> [Name] -> LifterM [ Name ]
 608 liftClass env@(Env bound _) innerName inner xs is =
 609   do { let newBound = getBoundAtDecls inner
 610      ; (inner,frees) <-
 611            getFrees (liftDecls False (env `combineEnv` newBound) inner)
 612      ; let trueFrees = both frees bound
 613      ; let mirrorFrees = [ "_" ++ name ++ "_" | name <- trueFrees ]
 614      ; let freeDefs = [ Field [Final] objectType n Nothing | n <- trueFrees ]
 615      ; let cons = Constructor [Public] innerName
 616                     [ Parameter [] objectType name | name <- mirrorFrees ]
 617                     [ ExprStatement (Assign (Var true) (Var mirror))
 618                     | (true,mirror) <- zip trueFrees mirrorFrees
 619                     ]
 620      ; let innerClass = Class [] innerName xs is (freeDefs ++ [cons] ++ inner)
 621      ; rememberClass innerClass
 622      ; return trueFrees
 623      }
 624
 625 liftType :: Env -> Type -> Type
 626 liftType (Env _ env) typ@(Type [name])
 627    = case lookup name env of
 628         Nothing     -> typ
 629         Just (nm,_) -> Type [nm]
 630 liftType _           typ = typ
 631
 632 mkNew :: Env -> Type -> [Expr] -> Expr
 633 mkNew (Env _ env) typ@(Type [name]) exprs
 634    = case lookup name env of
 635         Nothing                     -> New typ exprs Nothing
 636         Just (nm,args) | null exprs
 637                 -> New (Type [nm]) (map Var args) Nothing
 638         _ -> error "pre-lifted constructor with arguments"
 639 mkNew _           typ exprs = New typ exprs Nothing
 640 \end{code}