From 53a7fa7dd4edbf25019cd4764f1b798bd8286975 Mon Sep 17 00:00:00 2001 From: andy Date: Thu, 11 May 2000 07:10:11 +0000 Subject: [PATCH] [project @ 2000-05-11 07:10:11 by andy] First attempt at at class lifter for the GHC GOO backend. This included a cleanup of the Java/GOO abstract syntax - Name is now a string, not a list of string - Type is used instead of name in some places (for example, with new) - other minor tweeks. Andy --------- Example for myS f g x = f x (g x) public class myS implements Code { public Object ENTER () { VM.COLLECT(3, this); final Object f = VM.POP(); final Object g = VM.POP(); final Object x = VM.POP(); VM.PUSH(x); VM.PUSH(new Thunk(new Code(g, x))); return f; } } class myS$1 { final Object g; final Object x; public myS$1 (Object _g_, Object _x_) { g = _g_; x = _x_; } public Object ENTER () { VM.PUSH(x); return g; } } --- ghc/compiler/javaGen/Java.lhs | 33 +++- ghc/compiler/javaGen/JavaGen.lhs | 381 +++++++++++++++++++++++++++++++++--- ghc/compiler/javaGen/PrintJava.lhs | 13 +- 3 files changed, 382 insertions(+), 45 deletions(-) diff --git a/ghc/compiler/javaGen/Java.lhs b/ghc/compiler/javaGen/Java.lhs index 5de371b..3151014 100644 --- a/ghc/compiler/javaGen/Java.lhs +++ b/ghc/compiler/javaGen/Java.lhs @@ -1,4 +1,4 @@ -Abstract syntax for Java subset that is the target of Mondrian. +bstract syntax for Java subset that is the target of Mondrian. The syntax has been taken from "The Java Language Specification". (c) Erik Meijer & Arjan van IJzendoorn @@ -22,9 +22,11 @@ data CompilationUnit deriving (Show) data Decl - = Import Name + = Import [Name] | Field [Modifier] Type Name (Maybe Expr) | Constructor [Modifier] Name [Parameter] [Statement] + -- Add Throws (list of Names) + -- to Method | Method [Modifier] Type Name [Parameter] [Statement] | Comment [String] | Interface [Modifier] Name [Name] [Decl] @@ -54,13 +56,8 @@ data Expr | InstanceOf Expr Type | Call Expr Name [Expr] | Op Expr String Expr - | New Name [Expr] (Maybe [Decl]) -- anonymous innerclass - | NewArray Name [Expr] - deriving (Show) - -data Type - = Type Name - | Array Type + | New Type [Expr] (Maybe [Decl]) -- anonymous innerclass + | NewArray Type [Expr] deriving (Show) data Modifier @@ -69,7 +66,15 @@ data Modifier | Abstract | Final | Native | Synchronized | Transient | Volatile deriving (Show, Eq, Ord) -type Name = [String] +data Type + = PrimType String + | ArrayType Type + | Type [Name] + deriving (Show) + +-- If you want qualified names, use Access +-- Type's are already qualified. +type Name = String data Lit = IntLit Int -- Boxed @@ -79,6 +84,14 @@ data Lit | StringLit String deriving Show +data OType + = ObjectType -- Object * + | UnboxedIntType -- int + | UnboxedCharType -- char + +data OVar = OVar Name OType + -- Object x.y + addModifier :: Modifier -> Decl -> Decl addModifier = \m -> \d -> case d of 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} diff --git a/ghc/compiler/javaGen/PrintJava.lhs b/ghc/compiler/javaGen/PrintJava.lhs index eb0e0f8..e71e527 100644 --- a/ghc/compiler/javaGen/PrintJava.lhs +++ b/ghc/compiler/javaGen/PrintJava.lhs @@ -36,7 +36,7 @@ decls (d:ds) = decl d $$ decls ds decl = \d -> case d of - { Import n -> importDecl (name n) + { Import n -> importDecl (hcat (punctuate dot (map text n))) ; Field mfs t n e -> field (modifiers mfs) (typ t) (name n) e ; Constructor mfs n as ss -> constructor (modifiers mfs) (name n) (parameters as) (statements ss) ; Method mfs t n as ss -> method (modifiers mfs) (typ t) (name n) (parameters as) (statements ss) @@ -96,14 +96,15 @@ extends xs = text "extends" <+> hsep (punctuate comma (map name xs)) implements [] = empty implements xs = text "implements" <+> hsep (punctuate comma (map name xs)) -name ns = hcat (punctuate dot (map text ns)) +name ns = text ns parameters as = map parameter as parameter (Parameter mfs t n) = modifiers mfs <+> typ t <+> name n -typ (Type n) = name n -typ (Array t) = typ t <> text "[]" +typ (PrimType s) = text s +typ (Type n) = hcat (punctuate dot (map text n)) +typ (ArrayType t) = typ t <> text "[]" statements ss = vcat (map statement ss) @@ -162,11 +163,11 @@ expr = \e -> ; Cast t e -> cast (typ t) e ; Access e n -> expr e <> text "." <> name n ; Assign l r -> assign (expr l) r - ; New n es ds -> new (name n) es (maybeClass ds) + ; New n es ds -> new (typ n) es (maybeClass ds) ; Call e n es -> call (expr e) (name n) es ; Op e1 o e2 -> op e1 o e2 ; InstanceOf e t -> expr e <+> text "instanceof" <+> typ t - ; NewArray n es -> newArray (name n) es + ; NewArray n es -> newArray (typ n) es } op = \e1 -> \o -> \e2 -> -- 1.7.10.4