From 1abb301c708c5265c15b3f52fadb57d58299c0b4 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 20 Apr 2000 16:45:16 +0000 Subject: [PATCH 1/1] [project @ 2000-04-20 16:45:16 by simonpj] Add support for Java generation, written in a lightning day with Erik Meijer ghc -J Foo.hs will do the business, generating Foo.java The code is in a new directory, javaGen/, so you'll need to cvs update -d. I've reorganised main/CodeOutput quite a bit; it is now much much tidier, and will accommodate new languages quite easily. I've also fiddled with the flags that communicate between the driver and hsc. GONE: -S= -C= NEW: -olang=xxx output language xxx xxx can be: C, asm, java -ofile=xxx put the output code in file xxx BEWARE that I might have broken some of the more cryptic stuff in ghc.lprl. Simon --- ghc/compiler/javaGen/Java.lhs | 110 +++++++++++++ ghc/compiler/javaGen/JavaGen.lhs | 317 ++++++++++++++++++++++++++++++++++++ ghc/compiler/javaGen/PrintJava.lhs | 215 ++++++++++++++++++++++++ 3 files changed, 642 insertions(+) create mode 100644 ghc/compiler/javaGen/Java.lhs create mode 100644 ghc/compiler/javaGen/JavaGen.lhs create mode 100644 ghc/compiler/javaGen/PrintJava.lhs diff --git a/ghc/compiler/javaGen/Java.lhs b/ghc/compiler/javaGen/Java.lhs new file mode 100644 index 0000000..5de371b --- /dev/null +++ b/ghc/compiler/javaGen/Java.lhs @@ -0,0 +1,110 @@ +Abstract 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 + +November 1999 + +\begin{code} +module Java where + +\end{code} + +%************************************************************************ +%* * +\subsection{Java type declararations} +%* * +%************************************************************************ + +\begin{code} +data CompilationUnit + = Package Name [Decl] + deriving (Show) + +data Decl + = Import Name + | Field [Modifier] Type Name (Maybe Expr) + | Constructor [Modifier] Name [Parameter] [Statement] + | Method [Modifier] Type Name [Parameter] [Statement] + | Comment [String] + | Interface [Modifier] Name [Name] [Decl] + | Class [Modifier] Name [Name] [Name] [Decl] + deriving (Show) + +data Parameter + = Parameter [Modifier] Type Name + deriving (Show) + +data Statement + = Skip + | Return Expr + | Block [Statement] + | ExprStatement Expr + | Declaration Decl -- variable = inner Field, Class = innerclass + | IfThenElse [(Expr,Statement)] (Maybe Statement) + | Switch Expr [(Expr, [Statement])] (Maybe [Statement]) + deriving (Show) + +data Expr + = Var Name + | Literal Lit + | Cast Type Expr + | Access Expr Name + | Assign Expr 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 + deriving (Show) + +data Modifier + = Public | Protected | Private + | Static + | Abstract | Final | Native | Synchronized | Transient | Volatile + deriving (Show, Eq, Ord) + +type Name = [String] + +data Lit + = IntLit Int -- Boxed + | UIntLit Int -- Unboxed + | CharLit Char -- Boxed + | UCharLit Char -- Unboxed + | StringLit String + deriving Show + +addModifier :: Modifier -> Decl -> Decl +addModifier = \m -> \d -> + case d of + { Import n -> Import n + ; Field ms t n e -> Field (m:ms) t n e + ; Constructor ms n as ss -> Constructor (m:ms) n as ss + ; Method ms t n as ss -> Method (m:ms) t n as ss + ; Comment ss -> Comment ss + ; Interface ms n xs ds -> Interface (m:ms) n xs ds + ; Class ms n xs is ds -> Class (m:ms) n xs is ds + } + +areSimple :: [Expr] -> Bool +areSimple = \es -> all isSimple es + +isSimple :: Expr -> Bool +isSimple = \e -> + case e of + { Cast t e -> isSimple e + ; Access e n -> isSimple e + ; Assign l r -> isSimple l && isSimple r + ; InstanceOf e t -> isSimple e + ; Call e n es -> isSimple e && areSimple es + ; Op e1 o e2 -> False + ; New n es Nothing -> areSimple es + ; New n es (Just ds) -> False + ; otherwise -> True + } +\end{code} diff --git a/ghc/compiler/javaGen/JavaGen.lhs b/ghc/compiler/javaGen/JavaGen.lhs new file mode 100644 index 0000000..c9f86d2 --- /dev/null +++ b/ghc/compiler/javaGen/JavaGen.lhs @@ -0,0 +1,317 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% +\section{Generate Java} + +\begin{code} +module JavaGen( javaGen ) where + +import Java + +import Literal ( Literal(..) ) +import Id ( Id, isDataConId_maybe, isId, idName, isDeadBinder ) +import Name ( NamedThing(..), getOccString, isGlobalName ) +import DataCon ( DataCon, dataConRepArity, dataConId ) +import qualified CoreSyn +import CoreSyn ( CoreBind, CoreExpr, CoreAlt, CoreBndr, + Bind(..), Alt, AltCon(..), collectBinders, isValArg + ) +import CoreUtils( exprIsValue, exprIsTrivial ) +import Module ( Module, moduleString ) +import TyCon ( TyCon, isDataTyCon, tyConDataCons ) +import Outputable + +#include "HsVersions.h" + +\end{code} + + +\begin{code} +javaGen :: Module -> [Module] -> [TyCon] -> [CoreBind] -> CompilationUnit + +javaGen mod import_mods tycons binds + = Package [moduleString mod] decls + where + decls = [Import [moduleString mod] | mod <- import_mods] ++ + concat (map javaTyCon (filter isDataTyCon tycons)) ++ + concat (map javaTopBind binds) +\end{code} + + +%************************************************************************ +%* * +\subsection{Type declarations} +%* * +%************************************************************************ + +\begin{code} +javaTyCon :: TyCon -> [Decl] +-- public class List {} +-- +-- public class $wCons extends List { +-- Object f1; Object f2 +-- } +-- public class $wNil extends List {} + +javaTyCon tycon + = tycon_jclass : map constr_class constrs + where + constrs = tyConDataCons tycon + tycon_jclass_jname = javaName tycon + tycon_jclass = Class [Public] tycon_jclass_jname [] [] [] + + constr_class data_con + = Class [Public] constr_jname [tycon_jclass_jname] [] field_decls + where + constr_jname = javaConstrWkrName 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)] +\end{code} + +%************************************************************************ +%* * +\subsection{Bindings} +%* * +%************************************************************************ + +\begin{code} +javaTopBind :: CoreBind -> [Decl] +javaTopBind (NonRec bndr rhs) = [java_top_bind bndr rhs] +javaTopBind (Rec prs) = [java_top_bind bndr rhs | (bndr,rhs) <- prs] + +java_top_bind :: Id -> CoreExpr -> Decl +-- public class f implements Code { +-- public Object ENTER() { ...translation of rhs... } +-- } +java_top_bind bndr rhs + = Class [Public] (javaName bndr) [] [codeName] [enter_meth] + where + enter_meth = Method [Public] objectType enterName [] (javaExpr rhs) +\end{code} + + +%************************************************************************ +%* * +\subsection{Expressions} +%* * +%************************************************************************ + +\begin{code} +javaVar :: Id -> Expr +javaVar v | isGlobalName (idName v) = New (javaName v) [] Nothing + | otherwise = Var (javaName v) + + +javaLit :: Literal.Literal -> Lit +javaLit (MachInt i) = UIntLit (fromInteger i) +javaLit (MachChar c) = UCharLit c +javaLit other = pprPanic "javaLit" (ppr other) + +javaExpr :: CoreExpr -> [Statement] +-- Generate code to apply the value of +-- the expression to the arguments aleady on the stack +javaExpr (CoreSyn.Var v) = [Return (javaVar v)] +javaExpr (CoreSyn.Lit l) = [Return (Literal (javaLit l))] +javaExpr (CoreSyn.App f a) = javaApp f [a] +javaExpr e@(CoreSyn.Lam _ _) = javaLam (collectBinders e) +javaExpr (CoreSyn.Case e x alts) = javaCase e x alts +javaExpr (CoreSyn.Let bind body) = javaBind bind ++ javaExpr body +javaExpr (CoreSyn.Note _ e) = javaExpr e + +javaCase :: CoreExpr -> Id -> [CoreAlt] -> [Statement] +-- case e of x { Nil -> r1 +-- Cons p q -> r2 } +-- ==> +-- final Object x = VM.WHNF(...code for e...) +-- else if x instance_of Nil { +-- ...translation of r1... +-- } else if x instance_of Cons { +-- final Object p = ((Cons) x).f1 +-- final Object q = ((Cons) x).f2 +-- ...translation of r2... +-- } else return null + +javaCase e x alts + = [var [Final] objectType (javaName x) (vmWHNF (javaArg e)), + IfThenElse (map mk_alt alts) Nothing] + where + mk_alt (DEFAULT, [], rhs) = (true, Block (javaExpr rhs)) + mk_alt (DataAlt d, bs, rhs) = (instanceOf x d, Block (bind_args d bs ++ javaExpr rhs)) + 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) + | (b, f) <- filter isId bs `zip` map fieldName [1..], + not (isDeadBinder b) + ] + +javaBind (NonRec x rhs) +{- + x = ...rhs_x... + ==> + final Object x = new Thunk( new Code() { ...code for rhs_x... } ) +-} + = [var [Final] objectType (javaName x) (javaArg rhs)] + +javaBind (Rec prs) +{- rec { x = ...rhs_x...; y = ...rhs_y... } + ==> + class x implements Code { + Code x, y; + public Object ENTER() { ...code for rhs_x...} + } + ...ditto for y... + + final x x_inst = new x(); + ...ditto for y... + + final Thunk x = new Thunk( x_inst ); + ...ditto for y... + + x_inst.x = x; + x_inst.y = y; + ...ditto for y... +-} + = (map mk_class prs) ++ (map mk_inst prs) ++ + (map mk_thunk prs) ++ concat (map mk_knot prs) + where + mk_class (b,r) = Declaration (Class [] (javaName b) [] [codeName] stmts) + where + 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_thunk (b,r) = var [Final] thunkType (javaName b) + (New thunkName [Var (javaInstName b)] Nothing) + + mk_knot (b,_) = [ExprStatement (Assign lhs rhs) + | (b',_) <- prs, + let lhs = Access (Var (javaInstName b)) (javaName b'), + let rhs = Var (javaName b') + ] + +javaLam :: ([CoreBndr], CoreExpr) -> [Statement] +javaLam (bndrs, body) + | null val_bndrs = javaExpr body + | otherwise + = vmCOLLECT (length val_bndrs) (Var thisName) + ++ [var [Final] objectType (javaName n) vmPOP | n <- val_bndrs] + ++ javaExpr body + where + val_bndrs = filter isId bndrs + +javaApp :: CoreExpr -> [CoreExpr] -> [Statement] +javaApp (CoreSyn.App f a) as = javaApp f (a:as) +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)] + + ; other -> -- Not a saturated constructor + java_apply (CoreSyn.Var f) as + } + +javaApp f as = java_apply f as + +java_apply :: CoreExpr -> [CoreExpr] -> [Statement] +java_apply f as = [ExprStatement (vmPUSH arg) | arg <- javaArgs as] ++ javaExpr f + +javaArgs :: [CoreExpr] -> [Expr] +javaArgs args = [javaArg a | a <- args, isValArg a] + +javaArg :: CoreExpr -> Expr +javaArg (CoreSyn.Type t) = pprPanic "javaArg" (ppr t) +javaArg e | exprIsValue e || exprIsTrivial e = newCode (javaExpr e) + | otherwise = newThunk (newCode (javaExpr e)) +\end{code} + +%************************************************************************ +%* * +\subsection{Helper functions} +%* * +%************************************************************************ + +\begin{code} +true, this :: Expr +this = Var thisName + +true = Var ["true"] + +vmCOLLECT :: Int -> Expr -> [Statement] +vmCOLLECT 0 e = [] +vmCOLLECT n e = [ExprStatement (Call (Var vmName) ["COLLECT"] [Literal (IntLit n), e])] + +vmPOP :: Expr +vmPOP = Call (Var vmName) ["POP"] [] + +vmPUSH :: Expr -> Expr +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] + +instanceOf :: Id -> DataCon -> Expr +instanceOf x data_con + = InstanceOf (Var (javaName x)) (Type (javaConstrWkrName data_con)) + +newCode :: [Statement] -> Expr +newCode [Return e] = e +newCode stmts = New codeName [] (Just [Method [Public] objectType enterName [] stmts]) + +newThunk :: Expr -> Expr +newThunk e = New thunkName [e] Nothing +\end{code} + +%************************************************************************ +%* * +\subsection{Name mangling} +%* * +%************************************************************************ + +\begin{code} +codeName, enterName, vmName :: Name +codeName = ["Code"] +thunkName = ["Thunk"] +enterName = ["ENTER"] +vmName = ["VM"] +thisName = ["this"] + +fieldName :: Int -> Name -- Names for fields of a constructor +fieldName n = ["f" ++ show n] + +javaName :: NamedThing a => a -> Name +javaName n = [getOccString n] + +javaConstrWkrName :: DataCon -> Name +-- The function that makes the constructor +javaConstrWkrName con = [getOccString (dataConId con)] + +javaInstName :: NamedThing a => a -> Name +-- Makes x_inst for Rec decls +javaInstName n = [getOccString n ++ "_inst"] +\end{code} + +%************************************************************************ +%* * +\subsection{Type mangling} +%* * +%************************************************************************ + +\begin{code} +codeType, thunkType, objectType :: Type +objectType = Type ["Object"] +codeType = Type codeName +thunkType = Type thunkName +\end{code} + diff --git a/ghc/compiler/javaGen/PrintJava.lhs b/ghc/compiler/javaGen/PrintJava.lhs new file mode 100644 index 0000000..eb0e0f8 --- /dev/null +++ b/ghc/compiler/javaGen/PrintJava.lhs @@ -0,0 +1,215 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% +\section{Generate Java} + +\begin{code} +module PrintJava( compilationUnit ) where + +import Java +import Outputable +import Char( toLower ) +\end{code} + +\begin{code} +indent :: SDoc -> SDoc +indent = nest 2 +\end{code} + +%************************************************************************ +%* * +\subsection{Pretty printer} +%* * +%************************************************************************ + +\begin{code} +compilationUnit :: CompilationUnit -> SDoc +compilationUnit (Package n ds) = package n (decls ds) + +package = \n -> \ds -> + text "package" <+> name n <> text ";" + $$ + ds + +decls [] = empty +decls (d:ds) = decl d $$ decls ds + +decl = \d -> + case d of + { Import n -> importDecl (name 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) + ; Comment s -> comment s + ; Interface mfs n is ms -> interface (modifiers mfs) (name n) (extends is) (decls ms) + ; Class mfs n x is ms -> clazz (modifiers mfs) (name n) (extends x) (implements is) (decls ms) + } + +importDecl n = text "import" <+> n <> text ";" + +field = \mfs -> \t -> \n -> \e -> + case e of + { Nothing -> mfs <+> t <+> n <> text ";" + ; Just e -> lay [mfs <+> t <+> n <+> text "=", indent (expr e <> text ";")] + where + lay | isSimple e = hsep + | otherwise = sep + } + +constructor = \mfs -> \n -> \as -> \ss -> + mfs <+> n <+> parens (hsep (punctuate comma as)) <+> text "{" + $$ indent ss + $$ text "}" + +method = \mfs -> \t -> \n -> \as -> \ss -> + mfs <+> t <+> n <+> parens (hsep (punctuate comma as)) <+> text "{" + $$ indent ss + $$ text "}" + +comment = \ss -> + text "/**" + $$ indent (vcat [ text s | s <- ss]) + $$ text "**/" + +interface = \mfs -> \n -> \xs -> \ms -> + mfs <+> n <+> xs <+> text "{" + $$ indent ms + $$ text "}" + +clazz = \mfs -> \n -> \x -> \is -> \ms -> + mfs <+> text "class" <+> n <+> x <+> is <+> text "{" + $$ indent ms + $$ text "}" + +staticblock = \ss -> + text "static" <+> text "{" + $$ indent ss + $$ text "}" + +modifiers mfs = hsep (map modifier mfs) + +modifier mf = text $ map toLower (show mf) + +extends [] = empty +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)) + +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 "[]" + +statements ss = vcat (map statement ss) + +statement = \s -> + case s of + { Skip -> skip + ; Return e -> returnStat (expr e) + ; Block ss -> vcat [statement s | s <- ss] + ; ExprStatement e -> exprStatement (expr e) + ; Declaration d -> declStatement (decl d) + ; IfThenElse ecs s -> ifthenelse [ (expr e, statement s) | (e,s) <- ecs ] (maybe Nothing (Just .statement) s) + ; Switch e as d -> switch (expr e) (arms as) (deflt d) + } + +skip = empty + +returnStat e = sep [text "return", indent e <> semi] + +exprStatement e = e <> semi + +declStatement d = d + +ifthenelse ((e,s):ecs) ms = sep [text "if", + indent (parens e) <+> text "{", + indent s, + thenelse ecs ms] + +thenelse ((e,s):ecs) ms = sep [ text "} else if", + indent (parens e) <+> text "{", + indent s, + thenelse ecs ms] + +thenelse [] Nothing = text "}" +thenelse [] (Just s) = sep [text "} else {", indent s, text "}"] + +switch = \e -> \as -> \d -> + text "switch" <+> parens e <+> text "{" + $$ indent (as $$ d) + $$ text "}" + +deflt Nothing = empty +deflt (Just ss) = text "default:" $$ indent (statements ss) + +arms [] = empty +arms ((e,ss):as) = text "case" <+> expr e <> colon + $$ indent (statements ss) + $$ arms as + +maybeExpr Nothing = Nothing +maybeExpr (Just e) = Just (expr e) + +expr = \e -> + case e of + { Var n -> name n + ; Literal l -> literal l + ; 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) + ; 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 + } + +op = \e1 -> \o -> \e2 -> + ( if isSimple e1 + then expr e1 + else parens (expr e1) + ) + <+> + text o + <+> + ( if isSimple e2 + then expr e2 + else parens (expr e2) + ) + +assign = \l -> \r -> + if isSimple r + then l <+> text "=" <+> (expr r) + else l <+> text "=" $$ indent (expr r) + +cast = \t -> \e -> + if isSimple e + then parens (parens t <> expr e) + else parens (parens t $$ indent (expr e)) + +new n [] (Just ds) = sep [text "new" <+> n <+> text "()" <+> text "{", + indent ds, + text "}"] +new n es Nothing = text "new" <+> n <> parens (hsep (punctuate comma (map expr es))) + +newArray n es = text "new" <+> n <> text "[]" <+> braces (hsep (punctuate comma (map expr es))) + +call e n es = e <> dot <> n <> parens (hsep (punctuate comma (map expr es))) + +literal = \l -> + case l of + { IntLit i -> text (show i) + ; UIntLit i -> text (show i) + ; CharLit c -> text (show c) + ; UCharLit c -> text (show c) + ; StringLit s -> text (show s) + } + +maybeClass Nothing = Nothing +maybeClass (Just ds) = Just (decls ds) +\end{code} -- 1.7.10.4