X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FjavaGen%2FJavaGen.lhs;h=716492991e527ed6a5fda913ad29d607b314ef25;hb=2ea1f1f95ab60183f61461e0a42350dc16e45dad;hp=c9f86d20288848b4019f7a4630183119b1a0dd47;hpb=1abb301c708c5265c15b3f52fadb57d58299c0b4;p=ghc-hetmet.git diff --git a/ghc/compiler/javaGen/JavaGen.lhs b/ghc/compiler/javaGen/JavaGen.lhs index c9f86d2..7164929 100644 --- a/ghc/compiler/javaGen/JavaGen.lhs +++ b/ghc/compiler/javaGen/JavaGen.lhs @@ -1,26 +1,72 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 % \section{Generate Java} +Name mangling for Java. +~~~~~~~~~~~~~~~~~~~~~~ + +Haskell has a number of namespaces. The Java translator uses +the standard Haskell mangles (see OccName.lhs), and some extra +mangles. + +All names are hidden inside packages. + +module name: + - becomes a first level java package. + - can not clash with java, because haskell modules are upper case, + java default packages are lower case. + +function names: + - these turn into classes + - java keywords (eg. private) have the suffix "zdk" ($k) added. + +data *types* + - These have a base class, so need to appear in the + same name space as other object. for example data Foo = Foo + - We add a postfix to types: "zdc" ($c) + - Types are upper case, so never clash with keywords + +data constructors + - There are tWO classes for each Constructor + (1) - Class with the payload extends the relevent datatype baseclass. + - This class has the prefix zdw ($w) + (2) - Constructor *wrapper* just use their own name. + - Constructors are upper case, so never clash with keywords + - So Foo would become 2 classes. + * Foo -- the constructor wrapper + * zdwFoo -- the worker, with the payload + + +$i for instances. +$k for keyword nameclash avoidance. + \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 Id ( Id, isDataConId_maybe, isId, idName, isDeadBinder, idPrimRep + , isPrimOpId_maybe ) +import Name ( NamedThing(..), getOccString, isGlobalName, isLocalName + , nameModule ) +import PrimRep ( PrimRep(..) ) +import DataCon ( DataCon, dataConRepArity, dataConRepArgTys, dataConId ) +import qualified Type +import qualified CoreSyn import CoreSyn ( CoreBind, CoreExpr, CoreAlt, CoreBndr, - Bind(..), Alt, AltCon(..), collectBinders, isValArg + Bind(..), AltCon(..), collectBinders, isValArg ) -import CoreUtils( exprIsValue, exprIsTrivial ) +import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) +import qualified CoreUtils import Module ( Module, moduleString ) import TyCon ( TyCon, isDataTyCon, tyConDataCons ) import Outputable +import Maybe +import PrimOp + #include "HsVersions.h" \end{code} @@ -30,11 +76,13 @@ 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] ++ + decls = [Import "haskell.runtime.*"] ++ + [Import (moduleString mod) | mod <- import_mods] ++ concat (map javaTyCon (filter isDataTyCon tycons)) ++ concat (map javaTopBind binds) + package = Package (moduleString mod) decls \end{code} @@ -54,23 +102,87 @@ javaTyCon :: TyCon -> [Decl] -- public class $wNil extends List {} javaTyCon tycon - = tycon_jclass : map constr_class constrs + = tycon_jclass : concat (map constr_class constrs) where constrs = tyConDataCons tycon - tycon_jclass_jname = javaName tycon - tycon_jclass = Class [Public] tycon_jclass_jname [] [] [] + tycon_jclass_jname = javaTyConTypeName tycon ++ "zdc" + tycon_jclass = Class [Public] (shortName tycon_jclass_jname) [] [] [] constr_class data_con - = Class [Public] constr_jname [tycon_jclass_jname] [] field_decls + = [ Class [Public] constr_jname [tycon_jclass_jname] [] + (field_decls ++ [cons_meth,debug_meth]) + ] 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)] + constr_jname = shortName (javaConstrWkrName data_con) + + field_names = constrToFields data_con + field_decls = [ Field [Public] n Nothing + | n <- field_names + ] + + cons_meth = mkCons constr_jname field_names + + debug_meth = Method [Public] (Name "toString" stringType) + [] + [] + ( [ Declaration (Field [] txt Nothing) ] + ++ [ ExprStatement + (Assign (Var txt) + (mkStr + ("( " ++ + getOccString data_con ++ + " ") + ) + ) + ] + ++ [ ExprStatement + (Assign (Var txt) + (Op (Var txt) + "+" + (Op (Var n) "+" litSp) + ) + ) + | n <- field_names + ] + ++ [ Return (Op (Var txt) + "+" + (mkStr ")") + ) + ] + ) + + litSp = mkStr " " + txt = Name "__txt" stringType + + +-- This checks to see the type is reasonable to call new with. +-- primitives might use a static method later. +mkNew :: Type -> [Expr] -> Expr +mkNew t@(PrimType primType) _ = error "new primitive -- fix it???" +mkNew t@(Type _) es = New t es Nothing +mkNew _ _ = error "new with strange arguments" + +constrToFields :: DataCon -> [Name] +constrToFields cons = + [ fieldName i t + | (i,t) <- zip [1..] (map primRepToType + (map Type.typePrimRep + (dataConRepArgTys cons) + ) + ) + ] + +mkCons :: TypeName -> [Name] -> Decl +mkCons name args = Constructor [Public] name + [ Parameter [] n | n <- args ] + [ ExprStatement (Assign + (Access this n) + (Var n) + ) + | n <- args ] + +mkStr :: String -> Expr +mkStr str = Literal (StringLit str) \end{code} %************************************************************************ @@ -89,12 +201,16 @@ java_top_bind :: Id -> CoreExpr -> Decl -- public Object ENTER() { ...translation of rhs... } -- } java_top_bind bndr rhs - = Class [Public] (javaName bndr) [] [codeName] [enter_meth] + = Class [Public] (shortName (javaIdTypeName bndr)) + [] [codeName] [enter_meth] where - enter_meth = Method [Public] objectType enterName [] (javaExpr rhs) + enter_meth = Method [Public] + enterName + [vmArg] + [excName] + (javaExpr vmRETURN rhs) \end{code} - %************************************************************************ %* * \subsection{Expressions} @@ -103,27 +219,34 @@ java_top_bind bndr rhs \begin{code} javaVar :: Id -> Expr -javaVar v | isGlobalName (idName v) = New (javaName v) [] Nothing - | otherwise = Var (javaName v) +javaVar v | isGlobalName (idName v) = mkNew (javaIdType v) [] + | otherwise = Var (javaName v) +javaLit :: Literal.Literal -> Expr +javaLit (MachInt i) = Literal (IntLit (fromInteger i)) +javaLit (MachChar c) = Literal (CharLit c) +javaLit (MachStr fs) = Literal (StringLit str) + where + str = concatMap renderString (_UNPK_ fs) ++ "\\000" + -- This should really handle all the chars 0..31. + renderString '\NUL' = "\\000" + renderString other = [other] -javaLit :: Literal.Literal -> Lit -javaLit (MachInt i) = UIntLit (fromInteger i) -javaLit (MachChar c) = UCharLit c javaLit other = pprPanic "javaLit" (ppr other) -javaExpr :: CoreExpr -> [Statement] +-- Pass in the 'shape' of the result. +javaExpr :: (Expr -> Statement) -> 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] +javaExpr r (CoreSyn.Var v) = [r (javaVar v)] +javaExpr r (CoreSyn.Lit l) = [r (javaLit l)] +javaExpr r (CoreSyn.App f a) = javaApp r f [a] +javaExpr r e@(CoreSyn.Lam _ _) = javaLam r (collectBinders e) +javaExpr r (CoreSyn.Case e x alts) = javaCase r e x alts +javaExpr r (CoreSyn.Let bind body) = javaBind bind ++ javaExpr r body +javaExpr r (CoreSyn.Note _ e) = javaExpr r e + +javaCase :: (Expr -> Statement) -> CoreExpr -> Id -> [CoreAlt] -> [Statement] -- case e of x { Nil -> r1 -- Cons p q -> r2 } -- ==> @@ -134,29 +257,122 @@ javaCase :: CoreExpr -> Id -> [CoreAlt] -> [Statement] -- final Object p = ((Cons) x).f1 -- final Object q = ((Cons) x).f2 -- ...translation of r2... --- } else return null +-- } else throw java.lang.Exception + +-- This first special case happens a lot, typically +-- during dictionary deconstruction. +-- We need to access at least *one* field, to check to see +-- if we have correct constructor. +-- If we've got the wrong one, this is _|_, and the +-- casting will catch this with an exception. + +javaCase r e x [(DataAlt d,bs,rhs)] | length bs > 0 + = java_expr PushExpr e ++ + [ var [Final] (javaName x) + (whnf primRep (vmPOP (primRepToType primRep))) ] ++ + bind_args d bs ++ + javaExpr r rhs + where + primRep = idPrimRep x + whnf PtrRep = vmWHNF -- needs evaluation + whnf _ = id -- anything else does notg -javaCase e x alts - = [var [Final] objectType (javaName x) (vmWHNF (javaArg e)), - IfThenElse (map mk_alt alts) Nothing] + bind_args d bs = [var [Final] (javaName b) + (Access (Cast (javaConstrWkrType d) (javaVar x) + ) f + ) + | (b,f) <- filter isId bs `zip` (constrToFields d) + , not (isDeadBinder b) + ] + +javaCase r e x alts + | isIfThenElse && isPrimCmp = + javaIfThenElse r (fromJust maybePrim) tExpr fExpr + | otherwise = + java_expr PushExpr e ++ + [ var [Final] (javaName x) + (whnf primRep (vmPOP (primRepToType primRep))) + , mkIfThenElse (map mk_alt alts) + ] 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)) + isIfThenElse = CoreUtils.exprType e == boolTy + -- also need to check that x is not free in + -- any of the branches. + maybePrim = findCmpPrim e [] + isPrimCmp = isJust maybePrim + tExpr = matches trueDataCon alts + fExpr = matches falseDataCon alts + + matches con [] = error "no match for true or false branch of if/then/else" + matches con ((DataAlt d,[],rhs):rest) | con == d = rhs + matches con ((DEFAULT,[],rhs):_) = rhs + matches con (other:rest) = matches con rest + + primRep = idPrimRep x + whnf PtrRep = vmWHNF -- needs evaluation + whnf _ = id + + mk_alt (DEFAULT, [], rhs) = (true, Block (javaExpr r rhs)) + mk_alt (DataAlt d, bs, rhs) = (instanceOf x d, Block (bind_args d bs ++ javaExpr r rhs)) + mk_alt alt@(LitAlt lit, [], rhs) + = (eqLit lit , Block (javaExpr r 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) + + eqLit (MachInt n) = Op (Literal (IntLit n)) + + "==" + (Var (javaName x)) + eqLit (MachChar n) = Op (Literal (CharLit n)) + "==" + (Var (javaName x)) + eqLit other = pprPanic "eqLit" (ppr other) + + bind_args d bs = [var [Final] (javaName b) + (Access (Cast (javaConstrWkrType d) (javaVar x) + ) f + ) + | (b,f) <- filter isId bs `zip` (constrToFields d) + , not (isDeadBinder b) ] + +mkIfThenElse [(Var (Name "true" _),code)] = code +mkIfThenElse other = IfThenElse other + (Just (ExprStatement + (Raise excName [Literal (StringLit "case failure")]) + ) + ) + +javaIfThenElse r cmp tExpr fExpr +{- + - Now what we need to do is generate code for the if/then/else. + - [all arguments are already check for simpleness (Var or Lit).] + - + - if ( arg1 arg2 arg3 ...) { + - trueCode + - } else { + - falseCode + - } + -} + = [IfThenElse [(cmp,j_tExpr)] (Just j_fExpr)] + where + j_tExpr, j_fExpr :: Statement + j_tExpr = Block (javaExpr r tExpr) + j_fExpr = Block (javaExpr r fExpr) + 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)] + + = java_expr (SetVar name) rhs + where + name = case coreTypeToType rhs of + ty@(PrimType _) -> javaName x `withType` ty + _ -> javaName x `withType` codeType javaBind (Rec prs) {- rec { x = ...rhs_x...; y = ...rhs_y... } @@ -180,57 +396,158 @@ javaBind (Rec prs) = (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) + mk_class (b,r) = Declaration (Class [] class_name [] [codeName] stmts) where - stmts = [Field [] codeType (javaName b) Nothing | (b,_) <- prs] ++ - [Method [Public] objectType enterName [] (javaExpr r)] + class_name = javaIdTypeName b + stmts = [Field [] (javaName b `withType` codeType) Nothing | (b,_) <- prs] ++ + [Method [Public] enterName [vmArg] [excName] (javaExpr vmRETURN r)] - mk_inst (b,r) = var [Final] (Type (javaName b)) (javaInstName b) - (New (javaName b) [] Nothing) + mk_inst (b,r) = var [Final] name (mkNew ty []) + where + name@(Name _ ty) = javaInstName b - mk_thunk (b,r) = var [Final] thunkType (javaName b) - (New thunkName [Var (javaInstName b)] Nothing) + mk_thunk (b,r) = var [Final] (javaName b `withType` codeType) + (mkNew thunkType [Var (javaInstName b)]) - mk_knot (b,_) = [ExprStatement (Assign lhs rhs) + 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 + +javaLam :: (Expr -> Statement) -> ([CoreBndr], CoreExpr) -> [Statement] +javaLam r (bndrs, body) + | null val_bndrs = javaExpr r body | otherwise - = vmCOLLECT (length val_bndrs) (Var thisName) - ++ [var [Final] objectType (javaName n) vmPOP | n <- val_bndrs] - ++ javaExpr body + = vmCOLLECT (length val_bndrs) this + ++ [var [Final] n (vmPOP t) | n@(Name _ t) <- val_bndrs] + ++ javaExpr r body where - val_bndrs = filter isId bndrs + val_bndrs = map javaName (filter isId bndrs) -javaApp :: CoreExpr -> [CoreExpr] -> [Statement] -javaApp (CoreSyn.App f a) as = javaApp f (a:as) -javaApp (CoreSyn.Var f) as +javaApp :: (Expr -> Statement) -> CoreExpr -> [CoreExpr] -> [Statement] +javaApp r (CoreSyn.App f a) as + | isValArg a = javaApp r f (a:as) + | otherwise = javaApp r f as +javaApp r (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 + -- NOTE: Saturated constructors never returning a primitive at this point + -- + -- We push the arguments backwards, because we are using + -- the (ugly) semantics of the order of evaluation of arguments, + -- to avoid making up local names. Oh to have a namesupply... + -- + -> javaArgs (reverse as) ++ + [r (New (javaIdType f) + (javaPops as) + Nothing + ) + ] + | otherwise -> + -- build a local + let stmts = + vmCOLLECT (dataConRepArity dc) this ++ + [ vmRETURN + (New (javaIdType f) + [ vmPOP ty | (Name _ ty) <- constrToFields dc ] + Nothing + ) + ] + in javaArgs (reverse as) ++ [r (newCode stmts)] + ; other -> java_apply r (CoreSyn.Var f) as } -javaApp f as = java_apply f as +javaApp r f as = java_apply r f as + +-- This means, given a expression an a list of arguments, +-- generate code for "pushing the arguments on the stack, +-- and the executing the expression." + +java_apply :: (Expr -> Statement) -> CoreExpr -> [CoreExpr] -> [Statement] +java_apply r f as = javaArgs as ++ javaExpr r f + +-- This generates statements that have the net effect +-- of pushing values (perhaps thunks) onto the stack. + +javaArgs :: [CoreExpr] -> [Statement] +javaArgs args = concat [ java_expr PushExpr a | a <- args, isValArg a] + +javaPops :: [CoreExpr] -> [Expr] +javaPops args = [ vmPOP (primRepToType (Type.typePrimRep (CoreUtils.exprType a))) + | a <- args + , isValArg a + ] + + +-- The result is a list of statments that have the effect of +-- pushing onto the stack (via one of the VM.PUSH* commands) +-- the argument, (or returning, or setting a variable) +-- perhaps thunked. + +{- This is mixing two things. + (1) Optimizations for things like primitives, whnf calls, etc. + (2) If something needs a thunk constructor round it. + - Seperate them at some point! + -} +data ExprRetStyle = SetVar Name | PushExpr | ReturnExpr + +java_expr :: ExprRetStyle -> CoreExpr -> [Statement] +java_expr _ (CoreSyn.Type t) = pprPanic "java_expr" (ppr t) +java_expr ret e + | isPrimCall = [push (fromJust maybePrim)] + -- This is a shortcut, + -- basic names and literals do not need a code block + -- to compute the value. + | isPrim primty && CoreUtils.exprIsTrivial e = javaExpr push e + | isPrim primty = + let expr = javaExpr vmRETURN e + code = access (vmWHNF (newCode expr)) (primRepToType primty) + in [push code] + | otherwise = + let expr = javaExpr vmRETURN e + code = newCode expr + code' = if CoreUtils.exprIsValue e + || CoreUtils.exprIsTrivial e + || isPrim primty + then code + else newThunk code + in [push code'] + where + maybePrim = findFnPrim e [] + isPrimCall = isJust maybePrim -java_apply :: CoreExpr -> [CoreExpr] -> [Statement] -java_apply f as = [ExprStatement (vmPUSH arg) | arg <- javaArgs as] ++ javaExpr f + push e = case ret of + SetVar name -> var [Final] name e + PushExpr -> vmPUSH e + ReturnExpr -> vmRETURN e + corety = CoreUtils.exprType e + primty = Type.typePrimRep corety + isPrim PtrRep = False -- only this needs updated + isPrim _ = True -javaArgs :: [CoreExpr] -> [Expr] -javaArgs args = [javaArg a | a <- args, isValArg a] +coreTypeToType = primRepToType . Type.typePrimRep . CoreUtils.exprType + +renameForKeywords :: (NamedThing name) => name -> String +renameForKeywords name + | str `elem` keywords = "zdk" ++ str + | otherwise = str + where + str = getOccString name + +keywords :: [String] +keywords = + [ "return" + , "if" + , "then" + , "else" + , "class" + , "instance" + , "import" + , "throw" + , "try" + ] -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} %************************************************************************ @@ -240,37 +557,152 @@ javaArg e | exprIsValue e || exprIsTrivial e = newCode (javaExpr e) %************************************************************************ \begin{code} -true, this :: Expr -this = Var thisName - -true = Var ["true"] +true, this,javaNull :: Expr +this = Var thisName +true = Var (Name "true" (PrimType PrimBoolean)) +javaNull = Var (Name "null" objectType) vmCOLLECT :: Int -> Expr -> [Statement] vmCOLLECT 0 e = [] -vmCOLLECT n e = [ExprStatement (Call (Var vmName) ["COLLECT"] [Literal (IntLit n), e])] +vmCOLLECT n e = [ExprStatement + (Call varVM collectName + [ Literal (IntLit (toInteger n)) + , e + ] + ) + ] -vmPOP :: Expr -vmPOP = Call (Var vmName) ["POP"] [] +vmPOP :: Type -> Expr +vmPOP ty = Call varVM (Name ("POP" ++ suffix ty) ty) [] -vmPUSH :: Expr -> Expr -vmPUSH e = Call (Var vmName) ["PUSH"] [e] +vmPUSH :: Expr -> Statement +vmPUSH e = ExprStatement + (Call varVM (Name ("PUSH" ++ suffix (exprType e)) void) [e]) -var :: [Modifier] -> Type -> Name -> Expr -> Statement -var ms ty field_name value = Declaration (Field ms ty field_name (Just value)) +vmRETURN :: Expr -> Statement +vmRETURN e = Return ( + case ty of + PrimType _ -> Call varVM (Name ("RETURN" ++ suffix ty) + valueType + ) [e] + _ -> e) + where + ty = exprType e + +var :: [Modifier] -> Name -> Expr -> Statement +var ms field_name@(Name _ ty) value + | exprType value == ty = Declaration (Field ms field_name (Just value)) + | otherwise = var ms field_name (Cast ty value) vmWHNF :: Expr -> Expr -vmWHNF e = Call (Var vmName) ["WHNF"] [e] +vmWHNF e = Call varVM whnfName [e] + +suffix :: Type -> String +suffix (PrimType t) = primName t +suffix _ = "" + +primName :: PrimType -> String +primName PrimInt = "int" +primName PrimChar = "char" +primName PrimByte = "byte" +primName PrimBoolean = "boolean" +primName _ = error "unsupported primitive" + +varVM :: Expr +varVM = Var vmName 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] enterName [vmArg] [excName] stmts]) newThunk :: Expr -> Expr -newThunk e = New thunkName [e] Nothing +newThunk e = New thunkType [e] Nothing + +vmArg :: Parameter +vmArg = Parameter [Final] vmName + +-- This is called with boolean compares, checking +-- to see if we can do an obvious shortcut. +-- If there is, we return a (GOO) expression for doing this, + +-- So if, we have case (#< x y) of { True -> e1; False -> e2 }, +-- we will call findCmpFn with (#< x y), this return Just (Op x "<" y) + +findCmpPrim :: CoreExpr -> [Expr] -> Maybe Expr +findCmpPrim (CoreSyn.App f a) as = + case a of + CoreSyn.Var v -> findCmpPrim f (javaVar v:as) + CoreSyn.Lit l -> findCmpPrim f (javaLit l:as) + _ -> Nothing +findCmpPrim (CoreSyn.Var p) as = + case isPrimOpId_maybe p of + Just prim -> find_cmp_prim prim as + Nothing -> Nothing +findCmpPrim _ as = Nothing + +find_cmp_prim cmpPrim args@[a,b] = + case cmpPrim of + IntGtOp -> fn ">" + IntGeOp -> fn ">=" + IntEqOp -> fn "==" + IntNeOp -> fn "/=" + IntLtOp -> fn "<" + IntLeOp -> fn "<=" + _ -> Nothing + where + fn op = Just (Op a op b) +find_cmp_prim _ _ = Nothing + +findFnPrim :: CoreExpr -> [Expr] -> Maybe Expr +findFnPrim (CoreSyn.App f a) as = + case a of + CoreSyn.Var v -> findFnPrim f (javaVar v:as) + CoreSyn.Lit l -> findFnPrim f (javaLit l:as) + _ -> Nothing +findFnPrim (CoreSyn.Var p) as = + case isPrimOpId_maybe p of + Just prim -> find_fn_prim prim as + Nothing -> Nothing +findFnPrim _ as = Nothing + +find_fn_prim cmpPrim args@[a,b] = + case cmpPrim of + IntAddOp -> fn "+" + IntSubOp -> fn "-" + IntMulOp -> fn "*" + _ -> Nothing + where + fn op = Just (Op a op b) +find_fn_prim _ _ = Nothing +\end{code} + +%************************************************************************ +%* * +\subsection{Haskell to Java Types} +%* * +%************************************************************************ + +\begin{code} +exprType (Var (Name _ t)) = t +exprType (Literal lit) = litType lit +exprType (Cast t _) = t +exprType (New t _ _) = t +exprType (Call _ (Name _ t) _) = t +exprType (Access _ (Name _ t)) = t +exprType (Raise t _) = error "do not know the type of raise!" +exprType (Op _ op _) | op `elem` ["==","/=","<","<=","=>",">"] + = PrimType PrimBoolean +exprType (Op x op _) | op `elem` ["+","-","*"] + = exprType x +exprType expr = error ("can't figure out an expression type: " ++ show expr) + +litType (IntLit i) = PrimType PrimInt +litType (CharLit i) = PrimType PrimChar +litType (StringLit i) = stringType -- later, might use char array? \end{code} %************************************************************************ @@ -280,38 +712,465 @@ newThunk e = New thunkName [e] Nothing %************************************************************************ \begin{code} -codeName, enterName, vmName :: Name -codeName = ["Code"] -thunkName = ["Thunk"] -enterName = ["ENTER"] -vmName = ["VM"] -thisName = ["this"] +codeName, excName, thunkName :: TypeName +codeName = "haskell.runtime.Code" +thunkName = "haskell.runtime.Thunk" +excName = "java.lang.Exception" -fieldName :: Int -> Name -- Names for fields of a constructor -fieldName n = ["f" ++ show n] +enterName, vmName,thisName,collectName, whnfName :: Name +enterName = Name "ENTER" objectType +vmName = Name "VM" vmType +thisName = Name "this" (Type "") +collectName = Name "COLLECT" void +whnfName = Name "WHNF" objectType -javaName :: NamedThing a => a -> Name -javaName n = [getOccString n] +fieldName :: Int -> Type -> Name -- Names for fields of a constructor +fieldName n ty = Name ("f" ++ show n) ty -javaConstrWkrName :: DataCon -> Name --- The function that makes the constructor -javaConstrWkrName con = [getOccString (dataConId con)] +withType :: Name -> Type -> Name +withType (Name n _) t = Name n t + +-- This maps (local only) names Ids to Names, +-- using the same string as the Id. +javaName :: Id -> Name +javaName n + | isGlobalName (idName n) = error "useing javaName on global" + | otherwise = Name (getOccString n) + (primRepToType (idPrimRep n)) + +-- TypeName's are almost always global. This would typically return something +-- like Test.foo or Test.Foozdc or PrelBase.foldr. +-- Local might use locally bound types, (which do not have '.' in them). + +javaIdTypeName :: Id -> TypeName +javaIdTypeName n + | isLocalName n' = renameForKeywords n' + | otherwise = moduleString (nameModule n') ++ "." ++ renameForKeywords n' + where + n' = getName n + +-- There is no such thing as a local type constructor. + +javaTyConTypeName :: TyCon -> TypeName +javaTyConTypeName n = (moduleString (nameModule n') ++ "." ++ renameForKeywords n') + where + n' = getName n + +-- this is used for getting the name of a class when defining it. +shortName :: TypeName -> TypeName +shortName = reverse . takeWhile (/= '.') . reverse + +-- The function that makes the constructor name +-- The constructor "Foo ..." in module Test, +-- would return the name "Test.Foo". + +javaConstrWkrName :: DataCon -> TypeName +javaConstrWkrName = javaIdTypeName . dataConId -javaInstName :: NamedThing a => a -> Name -- Makes x_inst for Rec decls -javaInstName n = [getOccString n ++ "_inst"] +-- They are *never* is primitive +-- and always have local (type) names. +javaInstName :: Id -> Name +javaInstName n = Name (renameForKeywords n ++ "zdi_inst") + (Type (renameForKeywords n)) \end{code} %************************************************************************ %* * -\subsection{Type mangling} +\subsection{Types and type mangling} %* * %************************************************************************ \begin{code} -codeType, thunkType, objectType :: Type -objectType = Type ["Object"] -codeType = Type codeName -thunkType = Type thunkName +-- Haskell RTS types +codeType, thunkType, valueType :: Type +codeType = Type codeName +thunkType = Type thunkName +valueType = Type "haskell.runtime.Value" +vmType = Type "haskell.runtime.VMEngine" + +-- Basic Java types +objectType, stringType :: Type +objectType = Type "java.lang.Object" +stringType = Type "java.lang.String" + +void :: Type +void = PrimType PrimVoid + +inttype :: Type +inttype = PrimType PrimInt + +chartype :: Type +chartype = PrimType PrimChar + +bytetype :: Type +bytetype = PrimType PrimByte + +-- This lets you get inside a possible "Value" type, +-- to access the internal unboxed object. +access :: Expr -> Type -> Expr +access expr (PrimType prim) = accessPrim (Cast valueType expr) prim +access expr other = expr + +accessPrim expr PrimInt = Call expr (Name "intValue" inttype) [] +accessPrim expr PrimChar = Call expr (Name "charValue" chartype) [] +accessPrim expr PrimByte = Call expr (Name "byteValue" bytetype) [] +accessPrim expr other = pprPanic "accessPrim" (text (show other)) + +-- This is where we map from typename to types, +-- allowing to match possible primitive types. +mkType :: TypeName -> Type +mkType "PrelGHC.Intzh" = inttype +mkType "PrelGHC.Charzh" = chartype +mkType other = Type other + +-- Turns a (global) Id into a Type (fully qualified name). +javaIdType :: Id -> Type +javaIdType = mkType . javaIdTypeName + +javaLocalIdType :: Id -> Type +javaLocalIdType = primRepToType . idPrimRep + +primRepToType ::PrimRep -> Type +primRepToType PtrRep = objectType +primRepToType IntRep = inttype +primRepToType CharRep = chartype +primRepToType Int8Rep = bytetype +primRepToType AddrRep = objectType +primRepToType other = pprPanic "primRepToType" (ppr other) + +-- The function that makes the constructor name +javaConstrWkrType :: DataCon -> Type +javaConstrWkrType con = Type (javaConstrWkrName con) \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 :: TypeName -> TypeName -> [Name] -> Env -> Env +addTypeMapping origName newName frees (Env bound env) + = Env bound ((origName,(newName,frees)) : env) + +-- This a list of bound vars (with types) +-- and a mapping from old class name +-- to inner class name (with a list of frees that need passed +-- to the inner class.) + +data Env = Env Bound [(TypeName,(TypeName,[Name]))] + +newtype LifterM a = + LifterM { unLifterM :: + TypeName -> -- this class name + Int -> -- uniq supply + ( 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) + ) + +liftAccess :: Env -> Name -> LifterM () +liftAccess env@(Env bound _) name + | name `elem` bound = LifterM (\ n s -> ((),[name],[],s)) + | otherwise = return () + +scopedName :: TypeName -> LifterM a -> LifterM a +scopedName name (LifterM m) = + LifterM (\ _ s -> + case m name 1 of + (a,frees,lifted,_) -> (a,frees,lifted,s) + ) + +genAnonInnerClassName :: LifterM TypeName +genAnonInnerClassName = LifterM (\ n s -> + ( n ++ "$" ++ show s + , [] + , [] + , s + 1 + ) + ) + +genInnerClassName :: TypeName -> LifterM TypeName +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) = + Package name (concatMap liftCompilationUnit' ds) + +liftCompilationUnit' :: Decl -> [Decl] +liftCompilationUnit' decl = + case unLifterM (liftDecls True (Env [] []) [decl]) [] 1 of + (ds,_,ds',_) -> 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 n e -> + do { e <- liftMaybeExpr env e + ; return (Field mfs (liftName env 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 n as ts ss -> + do { let newBound = getBoundAtParameters as + ; (ss,_) <- liftStatements (combineEnv env newBound) ss + ; return (Method mfs (liftName env n) (liftParameters env as) ts 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 + +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 n e) -> + do { e <- liftMaybeExpr env e + ; return ( Declaration (Field mfs (liftName env 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 { liftAccess env n + ; return (Var (liftName env 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)) + } + ; Raise n es -> do { es <- liftExprs env es + ; return (Raise n es) + } + ; 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 e2 + ; return (Op e1 o e2) + } + ; New n es ds -> new env n es ds + } + +liftParameter env (Parameter ms n) = Parameter ms (liftName env n) +liftParameters env = map (liftParameter env) + +liftName env (Name n t) = Name n (liftType env t) + +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 (liftNew env typ args) + } +new env typ [] (Just inner) = + -- anon. inner class + do { innerName <- genAnonInnerClassName + ; frees <- liftClass env innerName inner [] [unType typ] + ; return (New (Type (innerName)) + (map Var frees) + Nothing) + } + where unType (Type name) = name + unType _ = error "incorrect type style" +new env typ _ (Just inner) = error "cant handle inner class with args" + + +liftClass :: Env -> TypeName -> [Decl] -> [TypeName] -> [TypeName] -> 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 = filter (\ (Name xs _) -> xs /= "VM") (both frees bound) + ; let freeDefs = [ Field [Final] n Nothing | n <- trueFrees ] + ; let cons = mkCons innerName trueFrees + ; 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 + +liftNew :: Env -> Type -> [Expr] -> Expr +liftNew (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" +\end{code}