javaGen :: Module -> [Module] -> [TyCon] -> [CoreBind] -> CompilationUnit
javaGen mod import_mods tycons binds
- = liftCompilationUnit package
+ = id {-liftCompilationUnit-} package
where
decls = [Import "haskell.runtime.*"] ++
[Import (moduleString mod) | mod <- import_mods] ++
= tycon_jclass : concat (map constr_class constrs)
where
constrs = tyConDataCons tycon
- tycon_jclass_jname = addCons (javaName tycon)
+ tycon_jclass_jname = javaGlobTypeName tycon ++ "zdc"
tycon_jclass = Class [Public] (shortName tycon_jclass_jname) [] [] []
constr_class data_con
constr_jtype = javaConstrWkrType data_con
field_names = constrToFields data_con
- field_decls = [ Field [Public] t f Nothing
- | (f,t) <- field_names
+ field_decls = [ Field [Public] n Nothing
+ | n <- field_names
]
cons_meth = mkCons (shortName constr_jname) field_names
- debug_meth = Method [Public] stringT
- "toString"
+ debug_meth = Method [Public] (Name "toString" stringType)
[]
[]
- ( [ Declaration (Field [] stringT "__txt" Nothing) ]
+ ( [ Declaration (Field [] txt Nothing) ]
++ [ ExprStatement
- (Assign txt (Literal
- (StringLit
+ (Assign (Var txt)
+ (mkStr
("( " ++
getOccString data_con ++
" ")
- )
- stringT
- )
+ )
)
]
++ [ ExprStatement
- (Assign txt
- (Op txt "+"
- (Op (Var f t) "+" litSp)
+ (Assign (Var txt)
+ (Op (Var txt)
+ "+"
+ (Op (Var n) "+" litSp)
)
)
- | (f,t) <- field_names
+ | n <- field_names
]
- ++ [ Return (Op txt "+"
- (Literal (StringLit ")") stringT)
+ ++ [ Return (Op (Var txt)
+ "+"
+ (mkStr ")")
)
]
)
- stringT = Type "java.lang.String"
- litSp = Literal (StringLit " ") stringT
- txt = Var "__txt" stringT
+ litSp = mkStr " "
+ txt = Name "__txt" stringType
mkNew :: Type -> [Expr] -> Expr
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 javaTauType (dataConRepArgTys cons))
+ ]
-addCons :: Name -> Name
-addCons name = name ++ "zdc"
-
-constrToFields :: DataCon -> [(Name,Type)]
-constrToFields cons = zip (map fieldName [1..])
- (map javaTauType (dataConRepArgTys cons))
-
-mkCons :: Name -> [(Name,Type)] -> Decl
+mkCons :: TypeName -> [Name] -> Decl
mkCons name args = Constructor [Public] name
- [ Parameter [] t n | (n,t) <- args ]
+ [ Parameter [] n | n <- args ]
[ ExprStatement (Assign
(Access this n)
- (Var n t)
+ (Var n)
)
- | (n,t) <- args ]
+ | n <- args ]
+
+mkStr :: String -> Expr
+mkStr str = Literal (StringLit str)
\end{code}
%************************************************************************
-- public Object ENTER() { ...translation of rhs... }
-- }
java_top_bind bndr rhs
- = Class [Public] (shortName (javaName bndr)) [] [codeName] [enter_meth]
+ = Class [Public] (shortName (javaGlobTypeName bndr))
+ [] [codeName] [enter_meth]
where
- enter_meth = Method [Public] objectType enterName [vmArg] [excName]
+ enter_meth = Method [Public] enterName [vmArg] [excName]
(javaExpr vmRETURN rhs)
\end{code}
\begin{code}
javaVar :: Id -> Expr
javaVar v | isGlobalName (idName v) = mkNew (javaGlobType v) []
- | otherwise = Var (javaName v) (javaType v)
+ | otherwise = Var (javaName v)
javaLit :: Literal.Literal -> Expr
-javaLit (MachInt i) = Literal (IntLit (fromInteger i)) (PrimType PrimInt)
-javaLit (MachChar c) = Literal (CharLit c) (PrimType PrimChar)
+javaLit (MachInt i) = Literal (IntLit (fromInteger i))
+javaLit (MachChar c) = Literal (CharLit c)
javaLit other = pprPanic "javaLit" (ppr other)
javaExpr :: (Expr -> Expr) -> CoreExpr -> [Statement]
-- } else return null
javaCase r e x alts
- = [var [Final] objectType (javaName x) (vmWHNF (javaArg e)),
+ = [var [Final] (javaName x) (vmWHNF (javaArg e)),
IfThenElse (map mk_alt alts) Nothing]
where
mk_alt (DEFAULT, [], rhs) = (true, Block (javaExpr r rhs))
mk_alt alt@(LitAlt _, _, _) = pprPanic "mk_alt" (ppr alt)
- eqLit (MachInt n) = Op (Literal (IntLit n) (PrimType PrimInt))
+ eqLit (MachInt n) = Op (Literal (IntLit n))
"=="
- (Var (javaName x) (PrimType PrimInt))
+ (Var (javaName x))
eqLit other = pprPanic "eqLit" (ppr other)
- bind_args d bs = [var [Final] t (javaName b)
- (Access (Cast (javaConstrWkrType d) (javaVar x)) f)
- | (b, (f,t)) <- filter isId bs `zip` (constrToFields d)
+ 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)
]
==>
final Object x = new Thunk( new Code() { ...code for rhs_x... } )
-}
- = [var [Final] objectType (javaName x) (newThunk (newCode (javaExpr vmRETURN rhs)))]
+ = [var [Final] (javaLocName x objectType)
+ (newThunk (newCode (javaExpr vmRETURN rhs)))
+ ]
javaBind (Rec prs)
{- rec { x = ...rhs_x...; y = ...rhs_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)
+ mk_class (b,r) = Declaration (Class [] class_name [] [codeName] stmts)
where
- stmts = [Field [] codeType (javaName b) Nothing | (b,_) <- prs] ++
- [Method [Public] objectType enterName [vmArg] [excName] (javaExpr vmRETURN r)]
+ class_name = javaLocTypeName b
+ stmts = [Field [] (javaLocName b codeType) Nothing | (b,_) <- prs] ++
+ [Method [Public] enterName [vmArg] [excName] (javaExpr vmRETURN r)]
- mk_inst (b,r) = var [Final] (javaGlobType b) (javaInstName b)
- (New (javaGlobType b) [] Nothing)
+ mk_inst (b,r) = var [Final] (javaInstName b)
+ (mkNew (javaGlobType b) [])
- mk_thunk (b,r) = var [Final] thunkType (javaName b)
- (New thunkType [Var (javaInstName b) (Type "<inst>")] Nothing)
+ mk_thunk (b,r) = var [Final] (javaLocName b thunkType)
+ (New thunkType [Var (javaInstName b)] Nothing)
- mk_knot (b,_) = [ExprStatement (Assign lhs rhs)
+ mk_knot (b,_) = [ ExprStatement (Assign lhs rhs)
| (b',_) <- prs,
- let lhs = Access (Var (javaInstName b) (Type "<inst>")) (javaName b'),
- let rhs = Var (javaName b') (Type "<inst>")
+ let lhs = Access (Var (javaInstName b)) (javaName b'),
+ let rhs = Var (javaName b')
]
+-- We are needlessly
javaLam :: (Expr -> Expr) -> ([CoreBndr], CoreExpr) -> [Statement]
javaLam r (bndrs, body)
| null val_bndrs = javaExpr r body
| otherwise
= vmCOLLECT (length val_bndrs) this
- ++ [var [Final] t (javaName n) (vmPOP t) | (n,t) <- val_bndrs]
+ ++ [var [Final] n (vmPOP t) | n@(Name _ t) <- val_bndrs]
++ javaExpr r body
where
- val_bndrs = map (\ id -> (id,javaType id)) (filter isId bndrs)
+ val_bndrs = map javaName (filter isId bndrs)
javaApp :: (Expr -> Expr) -> CoreExpr -> [CoreExpr] -> [Statement]
javaApp r (CoreSyn.App f a) as = javaApp r f (a:as)
Just dc | length as == dataConRepArity dc
-> -- Saturated constructors
[Return (New (javaGlobType f) (javaArgs as) Nothing)]
-
; other -> -- Not a saturated constructor
java_apply r (CoreSyn.Var f) as
}
java_apply :: (Expr -> Expr) -> CoreExpr -> [CoreExpr] -> [Statement]
java_apply r f as = [ExprStatement (vmPUSH arg) | arg <- javaArgs as] ++ javaExpr r f
-
javaArgs :: [CoreExpr] -> [Expr]
javaArgs args = [javaArg a | a <- args, isValArg a]
\begin{code}
true, this :: Expr
-this = Var thisName (Type "<this>")
-true = Var "true" (PrimType PrimBoolean)
+this = Var thisName
+true = Var (Name "true" (PrimType PrimBoolean))
vmCOLLECT :: Int -> Expr -> [Statement]
vmCOLLECT 0 e = []
-vmCOLLECT n e = [ExprStatement (Call varVM "COLLECT"
- [Literal (IntLit (toInteger n)) (PrimType PrimInt), e])]
+vmCOLLECT n e = [ExprStatement
+ (Call varVM collectName
+ [ Literal (IntLit (toInteger n))
+ , e
+ ]
+ )
+ ]
vmPOP :: Type -> Expr
-vmPOP ty = Call varVM ("POP" ++ suffix ty) []
+vmPOP ty = Call varVM (Name ("POP" ++ suffix ty) ty) []
vmPUSH :: Expr -> Expr
-vmPUSH e = Call varVM ("PUSH" ++ suffix (exprType e)) [e]
+vmPUSH e = Call varVM (Name ("PUSH" ++ suffix (exprType e)) void) [e]
vmRETURN :: Expr -> Expr
vmRETURN e =
case ty of
- PrimType _ -> Call varVM ("RETURN" ++ suffix (exprType e)) [e]
+ PrimType _ -> Call varVM (Name ("RETURN" ++ suffix (exprType e))
+ valueType
+ ) [e]
_ -> e
where
ty = exprType e
-var :: [Modifier] -> Type -> Name -> Expr -> Statement
-var ms ty field_name value = Declaration (Field ms ty field_name (Just value))
+var :: [Modifier] -> Name -> Expr -> Statement
+var ms field_name value = Declaration (Field ms field_name (Just value))
vmWHNF :: Expr -> Expr
-vmWHNF e = Call varVM "WHNF" [e]
+vmWHNF e = Call varVM whnfName [e]
suffix :: Type -> String
suffix (PrimType t) = primName t
primName _ = error "unsupported primitive"
varVM :: Expr
-varVM = Var vmName (Type "haskell.runtime.VMEngine")
+varVM = Var vmName
instanceOf :: Id -> DataCon -> Expr
instanceOf x data_con
- = InstanceOf (Var (javaName x) (Type "<instof>")) (javaConstrWkrType data_con)
+ = InstanceOf (Var (javaName x)) (javaConstrWkrType data_con)
newCode :: [Statement] -> Expr
newCode [Return e] = e
-newCode stmts = New codeType [] (Just [Method [Public] objectType enterName [vmArg] [excName] stmts])
+newCode stmts = New codeType [] (Just [Method [Public] enterName [vmArg] [excName] stmts])
newThunk :: Expr -> Expr
newThunk e = New thunkType [e] Nothing
vmArg :: Parameter
-vmArg = Parameter [Final] (Type "haskell.runtime.VMEngine") vmName
+vmArg = Parameter [Final] vmName
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-exprType (Var _ t) = t
-exprType (Literal _ t) = t
-exprType (Cast t _) = t
-exprType (New t _ _) = t
-exprType _ = error "can't figure out an expression type"
+exprType (Var (Name _ t)) = t
+exprType (Literal lit) = litType lit
+exprType (Cast t _) = t
+exprType (New t _ _) = t
+exprType _ = error "can't figure out an expression type"
+
+litType (IntLit i) = PrimType PrimInt
+litType (CharLit i) = PrimType PrimChar
+litType (StringLit i) = error "<string?>"
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-codeName, thunkName, enterName, vmName,excName :: Name
+codeName, excName, thunkName :: TypeName
codeName = "haskell.runtime.Code"
thunkName = "haskell.runtime.Thunk"
-enterName = "ENTER"
-vmName = "VM"
-thisName = "this"
-excName = "Exception"
+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 "<this>")
+collectName = Name "COLLECT" void
+whnfName = Name "WNNF" objectType
-javaName :: NamedThing a => a -> Name
+fieldName :: Int -> Type -> Name -- Names for fields of a constructor
+fieldName n ty = Name ("f" ++ show n) ty
+
+-- TODO: change to idToJavaName :: Id -> Name
+
+javaLocName :: Id -> Type -> Name
+javaLocName n t = Name (getOccString n) t
+
+javaName :: Id -> Name
javaName n = if isGlobalName n'
- then moduleString (nameModule n') ++ "." ++ getOccString n
- else getOccString n
+ then Name (javaGlobTypeName n)
+ (javaGlobType n)
+ else Name (getOccString n)
+ (Type "<loc?>")
+ where
+ n' = getName n
+
+-- TypeName's are always global
+javaGlobTypeName :: NamedThing a => a -> TypeName
+javaGlobTypeName n = (moduleString (nameModule n') ++ "." ++ getOccString n)
+ where
+ n' = getName n
+
+javaLocTypeName :: NamedThing a => a -> TypeName
+javaLocTypeName n = (moduleString (nameModule n') ++ "." ++ getOccString 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
-javaConstrWkrName :: DataCon -> Name
--- The function that makes the constructor
-javaConstrWkrName con = javaName (dataConId con)
+-- The function that makes the constructor name
+javaConstrWkrName :: DataCon -> TypeName
+javaConstrWkrName con = javaGlobTypeName (dataConId con)
-javaInstName :: NamedThing a => a -> Name
-- Makes x_inst for Rec decls
-javaInstName n = getOccString n ++ "_inst"
+javaInstName :: NamedThing a => a -> Name
+javaInstName n = Name (getOccString n ++ "_inst") (Type "<inst>")
\end{code}
%************************************************************************
%* *
-\subsection{Type mangling}
+\subsection{Types and type mangling}
%* *
%************************************************************************
\begin{code}
+-- 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
+
+-- This is where we map from type to possible primitive
+mkType "PrelGHC.Intzh" = inttype
+mkType "PrelGHC.Charzh" = chartype
+mkType other = Type other
+
-- This mapping a global haskell name (typically a function name)
-- to the name of the class that handles it.
--- The name must be global. So "Test.foo" maps to Type "Test.foo"
+-- The name must be global. So foo in module Test maps to (Type "Test.foo")
+-- TODO: change to Id
javaGlobType :: NamedThing a => a -> Type
javaGlobType n | '.' `notElem` name
= error ("not using a fully qualified name for javaGlobalType: " ++ name)
| otherwise
= mkType name
- where name = javaName n
+ where name = javaGlobTypeName n
-- This takes an id, and finds the ids *type* (for example, Int, Bool, a, etc).
javaType :: Id -> Type
javaType id = case (idPrimRep id) of
- IntRep -> PrimType PrimInt
+ IntRep -> inttype
_ -> if isGlobalName (idName id)
- then Type (javaName id)
+ then Type (javaGlobTypeName id)
else objectType -- TODO: ?? for now ??
--- This is where we map from type to possible primitive
-mkType "PrelGHC.Intzh" = PrimType PrimInt
-mkType other = Type other
-
+-- This is used to get inside constructors, to find out the types
+-- of the payload elements
javaTauType :: Type.TauType -> Type
javaTauType (TypeRep.TyConApp tycon _) = javaGlobType tycon
javaTauType (TypeRep.NoteTy _ t) = javaTauType t
javaTauType _ = objectType
+-- The function that makes the constructor name
javaConstrWkrType :: DataCon -> Type
--- The function that makes the constructor
javaConstrWkrType con = Type (javaConstrWkrName con)
-
-codeType, thunkType, objectType :: Type
-objectType = Type ("java.lang.Object")
-codeType = Type codeName
-thunkType = Type thunkName
\end{code}
%************************************************************************
when lifting.
\begin{code}
+{-
type Bound = [Name]
type Frees = [Name]
-> New (Type nm) (map (\ v -> Var v (Type "<arg>")) args) Nothing
_ -> error "pre-lifted constructor with arguments"
listNew _ typ exprs = New typ exprs Nothing
+
+-}
\end{code}
projects / ghc-hetmet.git / commitdiff