Commit 1abb301c authored by simonpj's avatar simonpj

[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
parent 8f674b1c
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}
%
% (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}
%
% (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}
Markdown is supported
0% or .
You are about to add 0 people to the