Commit 53a7fa7d authored by andy's avatar andy
Browse files

[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;
  }
}
parent fa2efd1e
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 <expr> <name>
-- 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
......
......@@ -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}
......@@ -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 ->
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment