X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FjavaGen%2FJavaGen.lhs;h=0fd4b9e9c14e3de85837565f3c3da7ed88965b41;hb=53a7fa7dd4edbf25019cd4764f1b798bd8286975;hp=c9f86d20288848b4019f7a4630183119b1a0dd47;hpb=fa2efd1ea7fe23ccb8a1b029e3a8c9047b462045;p=ghc-hetmet.git

diff --git a/ghc/compiler/javaGen/JavaGen.lhs b/ghc/compiler/javaGen/JavaGen.lhs
index c9f86d2..0fd4b9e 100644
--- a/ghc/compiler/javaGen/JavaGen.lhs
+++ b/ghc/compiler/javaGen/JavaGen.lhs
@@ -30,11 +30,12 @@ import Outputable
 javaGen :: Module -> [Module] -> [TyCon] -> [CoreBind] -> CompilationUnit
 
 javaGen mod import_mods tycons binds
-  = Package [moduleString mod] decls
+  = liftCompilationUnit package
   where
     decls = [Import [moduleString mod] | mod <- import_mods] ++
 	    concat (map javaTyCon (filter isDataTyCon tycons)) ++ 
 	    concat (map javaTopBind binds)
+    package = Package (moduleString mod) decls
 \end{code}
 
 
@@ -64,13 +65,14 @@ javaTyCon tycon
 	= Class [Public] constr_jname [tycon_jclass_jname] [] field_decls
 	where
 	  constr_jname = javaConstrWkrName data_con
+	  constr_jtype = javaConstrWkrType data_con
 	  enter_meth   = Method [Public] objectType enterName [] stmts
 	  n_val_args   = dataConRepArity data_con
 	  field_names  = map fieldName [1..n_val_args]
 	  field_decls  = [Field [Public] objectType f Nothing | f <- field_names]
 	  stmts	       = vmCOLLECT n_val_args (Var thisName) ++
 		     	 [var [Final] objectType f vmPOP | f <- field_names] ++
-		     	 [Return (New constr_jname (map Var field_names) Nothing)]
+		     	 [Return (New constr_jtype (map Var field_names) Nothing)]
 \end{code}
 
 %************************************************************************
@@ -103,10 +105,9 @@ java_top_bind bndr rhs
 
 \begin{code}
 javaVar :: Id -> Expr
-javaVar v | isGlobalName (idName v) = New (javaName v) [] Nothing
+javaVar v | isGlobalName (idName v) = New (javaType v) [] Nothing
 	  | otherwise	  	    = Var (javaName v)
 
-
 javaLit :: Literal.Literal -> Lit
 javaLit (MachInt i)  = UIntLit (fromInteger i)
 javaLit (MachChar c) = UCharLit c
@@ -145,7 +146,7 @@ javaCase e x alts
      mk_alt alt@(LitAlt _, _, _) = pprPanic "mk_alt" (ppr alt)
 
      bind_args d bs = [var [Final] objectType (javaName b) 
-			   (Access (Cast (Type (javaConstrWkrName d)) (javaVar x)) f)
+			   (Access (Cast (javaConstrWkrType d) (javaVar x)) f)
 		      | (b, f) <- filter isId bs `zip` map fieldName [1..],
 			not (isDeadBinder b)
 		      ]
@@ -185,11 +186,11 @@ javaBind (Rec prs)
 		     stmts = [Field [] codeType (javaName b) Nothing | (b,_) <- prs] ++
 			     [Method [Public] objectType enterName [] (javaExpr r)]	
 
-    mk_inst (b,r) = var [Final] (Type (javaName b)) (javaInstName b)
-			(New (javaName b) [] Nothing)
+    mk_inst (b,r) = var [Final] (javaType b) (javaInstName b)
+			(New (javaType b) [] Nothing)
 
     mk_thunk (b,r) = var [Final] thunkType (javaName b)
-			 (New thunkName [Var (javaInstName b)] Nothing)
+			 (New thunkType [Var (javaInstName b)] Nothing)
 
     mk_knot (b,_) = [ExprStatement (Assign lhs rhs) 
 		    | (b',_) <- prs,
@@ -213,7 +214,7 @@ javaApp (CoreSyn.Var f) as
   = case isDataConId_maybe f of {
 	Just dc | length as == dataConRepArity dc
 		-> 	-- Saturated constructors
-		   [Return (New (javaName f) (javaArgs as) Nothing)]
+		   [Return (New (javaType f) (javaArgs as) Nothing)]
 
     ; other ->   -- Not a saturated constructor
 	java_apply (CoreSyn.Var f) as
@@ -243,34 +244,34 @@ javaArg e | exprIsValue e || exprIsTrivial e = newCode (javaExpr e)
 true, this :: Expr
 this = Var thisName
 
-true = Var ["true"]
+true = Var "true"
 
 vmCOLLECT :: Int -> Expr -> [Statement]
 vmCOLLECT 0 e = []
-vmCOLLECT n e = [ExprStatement (Call (Var vmName) ["COLLECT"] [Literal (IntLit n), e])]
+vmCOLLECT n e = [ExprStatement (Call (Var vmName) "COLLECT" [Literal (IntLit n), e])]
 
 vmPOP :: Expr
-vmPOP = Call (Var vmName) ["POP"] []
+vmPOP = Call (Var vmName) "POP" []
 
 vmPUSH :: Expr -> Expr
-vmPUSH e = Call (Var vmName) ["PUSH"] [e]
+vmPUSH e = Call (Var vmName) "PUSH" [e]
 
 var :: [Modifier] -> Type -> Name -> Expr -> Statement
 var ms ty field_name value = Declaration (Field ms ty field_name (Just value))
 
 vmWHNF :: Expr -> Expr
-vmWHNF e = Call (Var vmName) ["WHNF"] [e]
+vmWHNF e = Call (Var vmName) "WHNF" [e]
 
 instanceOf :: Id -> DataCon -> Expr
 instanceOf x data_con
-  = InstanceOf (Var (javaName x)) (Type (javaConstrWkrName data_con))
+  = InstanceOf (Var (javaName x)) (javaConstrWkrType data_con)
 
 newCode :: [Statement] -> Expr
 newCode [Return e] = e
-newCode stmts	   = New codeName [] (Just [Method [Public] objectType enterName [] stmts])
+newCode stmts	   = New codeType [] (Just [Method [Public] objectType enterName [] stmts])
 
 newThunk :: Expr -> Expr
-newThunk e = New thunkName [e] Nothing
+newThunk e = New thunkType [e] Nothing
 \end{code}
 
 %************************************************************************
@@ -281,25 +282,25 @@ newThunk e = New thunkName [e] Nothing
 
 \begin{code}
 codeName, enterName, vmName :: Name
-codeName  = ["Code"]
-thunkName = ["Thunk"]
-enterName = ["ENTER"]
-vmName    = ["VM"]
-thisName  = ["this"]
+codeName  = "Code"
+thunkName = "Thunk"
+enterName = "ENTER"
+vmName    = "VM"
+thisName  = "this"
 
 fieldName :: Int -> Name	-- Names for fields of a constructor
-fieldName n = ["f" ++ show n]
+fieldName n = "f" ++ show n
 
 javaName :: NamedThing a => a -> Name
-javaName n = [getOccString n]
+javaName n = getOccString n
 
-javaConstrWkrName :: DataCon ->  Name
+javaConstrWkrName :: DataCon -> Name
 -- The function that makes the constructor
-javaConstrWkrName con = [getOccString (dataConId con)]
+javaConstrWkrName con = getOccString (dataConId con)
 
 javaInstName :: NamedThing a => a -> Name
 -- Makes x_inst for Rec decls
-javaInstName n = [getOccString n ++ "_inst"]
+javaInstName n = getOccString n ++ "_inst"
 \end{code}
 
 %************************************************************************
@@ -309,9 +310,331 @@ javaInstName n = [getOccString n ++ "_inst"]
 %************************************************************************
 
 \begin{code}
+javaType :: NamedThing a => a -> Type
+javaType n = Type [javaName n]
+
+javaConstrWkrType :: DataCon -> Type
+-- The function that makes the constructor
+javaConstrWkrType con = Type [javaConstrWkrName con]
+
 codeType, thunkType, objectType :: Type
 objectType = Type ["Object"]
-codeType  = Type codeName
-thunkType = Type thunkName
+codeType   = Type [codeName]
+thunkType  = Type [thunkName]
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection{Class Lifting}
+%*									*
+%************************************************************************
+
+This is a very simple class lifter. It works by carrying inwards a
+list of bound variables (things that might need to be passed to a
+lifted inner class). 
+ * Any variable references is check with this list, and if it is
+   bound, then it is not top level, external reference. 
+ * This means that for the purposes of lifting, it might be free
+   inside a lifted inner class.
+ * We remember these "free inside the inner class" values, and 
+   use this list (which is passed, via the monad, outwards)
+   when lifting.
+
+\begin{code}
+type Bound = [Name]
+type Frees = [Name]
+
+combine :: [Name] -> [Name] -> [Name]
+combine []           names          = names
+combine names        []             = names
+combine (name:names) (name':names') 
+	| name < name' = name  : combine names (name':names')
+	| name > name' = name' : combine (name:names) names'
+	| name == name = name  : combine names names'
+	| otherwise    = error "names are not a total order"
+
+both :: [Name] -> [Name] -> [Name]
+both []           names          = []
+both names        []             = []
+both (name:names) (name':names') 
+	| name < name' = both names (name':names')
+	| name > name' = both (name:names) names'
+	| name == name = name  : both names names'
+	| otherwise    = error "names are not a total order"
+
+combineEnv :: Env -> [Name] -> Env
+combineEnv (Env bound env) new = Env (bound `combine` new) env
+
+addTypeMapping :: Name -> Name -> [Name] -> Env -> Env
+addTypeMapping origName newName frees (Env bound env) 
+	= Env bound ((origName,(newName,frees)) : env)
+
+data Env = Env Bound [(Name,(Name,[Name]))]
+
+newtype LifterM a = 
+  	LifterM { unLifterM ::
+		     Name ->
+		     Int -> ( a			-- *
+			    , Frees		-- frees
+			    , [Decl]		-- lifted classes
+			    , Int		-- The uniqs
+			    )
+		}
+
+instance Monad LifterM where
+	return a = LifterM (\ n s -> (a,[],[],s))
+	(LifterM m) >>= fn = LifterM (\ n s ->
+	  case m n s of
+	    (a,frees,lifted,s) 
+	         -> case unLifterM (fn a) n s of
+	 	     (a,frees2,lifted2,s) -> ( a
+					     , combine frees frees2
+					     , lifted ++ lifted2
+					     , s)
+	  )
+
+access :: Env -> Name -> LifterM ()
+access env@(Env bound _) name 
+	| name `elem` bound = LifterM (\ n s -> ((),[name],[],s))
+	| otherwise         = return ()
+
+scopedName :: Name -> LifterM a -> LifterM a
+scopedName name (LifterM m) =
+   LifterM (\ _ s -> 
+      case m name 1 of
+	(a,frees,lifted,_) -> (a,frees,lifted,s)
+      )
+
+genAnonInnerClassName :: LifterM Name
+genAnonInnerClassName = LifterM (\ n s ->
+	( n ++ "$" ++ show s
+	, []
+	, []
+	, s + 1
+	)
+    )
+
+genInnerClassName :: Name -> LifterM Name
+genInnerClassName name = LifterM (\ n s ->
+	( n ++ "$" ++ name 
+	, []
+	, []
+	, s
+	)
+    )
+
+getFrees  :: LifterM a -> LifterM (a,Frees)
+getFrees (LifterM m) = LifterM (\ n s ->
+	case m n s of
+	  (a,frees,lifted,n) -> ((a,frees),frees,lifted,n)
+    )
+
+rememberClass :: Decl -> LifterM ()
+rememberClass decl = LifterM (\ n s -> ((),[],[decl],s))
+
+
+liftCompilationUnit :: CompilationUnit -> CompilationUnit
+liftCompilationUnit (Package name ds) =
+    case unLifterM (liftDecls True (Env [] []) ds) [] 1 of
+      (ds,_,ds',_) -> Package name (ds ++ ds')
+
+-- The bound vars for the current class have
+-- already be captured before calling liftDecl,
+-- because they are in scope everywhere inside the class.
+
+liftDecl :: Bool -> Env -> Decl -> LifterM Decl
+liftDecl = \ top env decl ->
+  case decl of
+    { Import n -> return (Import n)
+    ; Field mfs t n e -> 
+      do { e <- liftMaybeExpr env e
+	 ; return (Field mfs (liftType env t) n e)
+	 }
+    ; Constructor mfs n as ss -> 
+      do { let newBound = getBoundAtParameters as
+	 ; (ss,_) <- liftStatements (combineEnv env newBound) ss
+	 ; return (Constructor mfs n (liftParameters env as) ss)
+	 }
+    ; Method mfs t n as ss -> 
+      do { let newBound = getBoundAtParameters as
+	 ; (ss,_) <- liftStatements (combineEnv env newBound) ss
+	 ; return (Method mfs (liftType env t) n (liftParameters env as) ss)
+	 }
+    ; Comment s -> return (Comment s)
+    ; Interface mfs n is ms -> error "interfaces not supported"
+    ; Class mfs n x is ms -> 
+      do { let newBound = getBoundAtDecls ms
+	 ; ms <- scopedName n
+		    (liftDecls False (combineEnv env newBound) ms)
+	 ; return (Class mfs n x is ms)
+	 }
+    }
+
+liftDecls :: Bool -> Env -> [Decl] -> LifterM [Decl]
+liftDecls top env = mapM (liftDecl top env)
+
+getBoundAtDecls :: [Decl] -> Bound
+getBoundAtDecls = foldr combine [] . map getBoundAtDecl
+
+-- TODO
+getBoundAtDecl :: Decl -> Bound
+getBoundAtDecl (Field _ _ n _) = [n]
+getBoundAtDecl _               = []
+
+getBoundAtParameters :: [Parameter] -> Bound
+getBoundAtParameters = foldr combine [] . map getBoundAtParameter
+
+-- TODO
+getBoundAtParameter :: Parameter -> Bound
+getBoundAtParameter (Parameter _ _ n) = [n]
+
+liftStatement :: Env -> Statement -> LifterM (Statement,Env)
+liftStatement = \ env stmt ->
+  case stmt of 
+    { Skip -> return (stmt,env)
+    ; Return e -> do { e <- liftExpr env e
+		     ; return (Return e,env)
+		     } 
+    ; Block ss -> do { (ss,env) <- liftStatements env ss
+		     ; return (Block ss,env)
+		     }
+    ; ExprStatement e -> do { e <- liftExpr env e
+			    ; return (ExprStatement e,env)
+			    }
+   ; Declaration decl@(Field mfs t n e) ->
+      do { e <- liftMaybeExpr env e
+	 ; return ( Declaration (Field mfs t n e)
+		  , env `combineEnv` getBoundAtDecl decl
+		  )
+	 }
+    ; Declaration decl@(Class mfs n x is ms) ->
+      do { innerName <- genInnerClassName n
+	 ; frees <- liftClass env innerName ms x is
+	 ; return ( Declaration (Comment ["lifted " ++  n])
+		  , addTypeMapping n innerName frees env
+		  )
+	 }
+    ; Declaration d -> error "general Decl not supported"
+    ; IfThenElse ecs s -> ifthenelse env ecs s
+    ; Switch e as d -> error "switch not supported"
+    } 
+
+ifthenelse :: Env 
+	   -> [(Expr,Statement)] 
+	   -> (Maybe Statement) 
+	   -> LifterM (Statement,Env)
+ifthenelse env pairs may_stmt =
+  do { let (exprs,stmts) = unzip pairs
+     ; exprs <- liftExprs env exprs
+     ; (stmts,_) <- liftStatements env stmts
+     ; may_stmt <- case may_stmt of
+		      Just stmt -> do { (stmt,_) <- liftStatement env stmt
+				      ; return (Just stmt)
+				      }
+		      Nothing -> return Nothing
+     ; return (IfThenElse (zip exprs stmts) may_stmt,env)
+     }
+
+liftStatements :: Env -> [Statement] -> LifterM ([Statement],Env)
+liftStatements env []     = return ([],env)
+liftStatements env (s:ss) = 
+	do { (s,env) <- liftStatement env s
+	   ; (ss,env) <- liftStatements env ss
+	   ; return (s:ss,env) 
+	   }
+
+
+liftExpr :: Env -> Expr -> LifterM Expr
+liftExpr = \ env expr ->
+ case expr of
+   { Var n -> do { access env n 
+		 ; return (Var n)
+	         }
+   ; Literal l -> return expr
+   ; Cast t e -> do { e <- liftExpr env e
+	            ; return (Cast (liftType env t) e) 
+	            }
+   ; Access e n -> do { e <- liftExpr env e 
+			-- do not consider n as an access, because
+			-- this is a indirection via a reference
+		      ; return (Access e n) 
+		      }
+   ; Assign l r -> do { l <- liftExpr env l
+		      ; r <- liftExpr env r
+		      ; return (Assign l r)
+		      } 
+   ; InstanceOf e t -> do { e <- liftExpr env e
+			  ; return (InstanceOf e (liftType env t))
+			  }	    
+   ; Call e n es -> do { e <- liftExpr env e
+		       ; es <- mapM (liftExpr env) es
+		       ; return (Call e n es) 
+		       }
+   ; Op e1 o e2 -> do { e1 <- liftExpr env e1
+		      ;	e2 <- liftExpr env e1
+		      ; return (Op e1 o e2)
+		      }
+   ; New n es ds -> new env n es ds
+   ; NewArray n es -> error "array not (yet) supported"
+   }
+
+liftParameter env (Parameter ms t n) = Parameter ms (liftType env t) n
+liftParameters env = map (liftParameter env)
+
+liftExprs :: Env -> [Expr] -> LifterM [Expr]
+liftExprs = mapM . liftExpr
+
+liftMaybeExpr :: Env -> (Maybe Expr) -> LifterM (Maybe Expr)
+liftMaybeExpr env Nothing     = return Nothing
+liftMaybeExpr env (Just stmt) = do { stmt <- liftExpr env stmt
+				     ; return (Just stmt)
+				     }
+
+
+new :: Env -> Type -> [Expr] -> Maybe [Decl] -> LifterM Expr
+new env@(Env _ pairs) typ args Nothing =
+  do { args <- liftExprs env args
+     ; return (mkNew env typ args)
+     }
+new env typ [] (Just inner) =
+  -- anon. inner class
+  do { innerName <- genAnonInnerClassName 
+     ; frees <- liftClass env innerName inner [] []
+     ; return (mkNew env typ [ Var name | name <- frees ])
+     }
+new env typ _ (Just inner) = error "cant handle inner class with args"
+
+liftClass :: Env -> Name -> [Decl] -> [Name] -> [Name] -> LifterM [ Name ]
+liftClass env@(Env bound _) innerName inner xs is =
+  do { let newBound = getBoundAtDecls inner
+     ; (inner,frees) <- 
+	   getFrees (liftDecls False (env `combineEnv` newBound) inner)
+     ; let trueFrees = both frees bound
+     ; let mirrorFrees = [ "_" ++ name ++ "_" | name <- trueFrees ]
+     ; let freeDefs = [ Field [Final] objectType n Nothing | n <- trueFrees ]
+     ; let cons = Constructor [Public] innerName 
+		    [ Parameter [] objectType name | name <- mirrorFrees ]
+		    [ ExprStatement (Assign (Var true) (Var mirror))
+		    | (true,mirror) <- zip trueFrees mirrorFrees
+		    ]
+     ; let innerClass = Class [] innerName xs is (freeDefs ++ [cons] ++ inner)
+     ; rememberClass innerClass
+     ; return trueFrees
+     }
+
+liftType :: Env -> Type -> Type
+liftType (Env _ env) typ@(Type [name]) 
+   = case lookup name env of
+	Nothing     -> typ
+	Just (nm,_) -> Type [nm]
+liftType _           typ = typ
+
+mkNew :: Env -> Type -> [Expr] -> Expr
+mkNew (Env _ env) typ@(Type [name]) exprs
+   = case lookup name env of
+	Nothing                     -> New typ exprs Nothing
+	Just (nm,args) | null exprs 
+		-> New (Type [nm]) (map Var args) Nothing
+	_ -> error "pre-lifted constructor with arguments"
+mkNew _           typ exprs = New typ exprs Nothing
+\end{code}