import Java
import Literal ( Literal(..) )
-import Id ( Id, isDataConId_maybe, isId, idName, isDeadBinder, idPrimRep
+import Id ( Id, isDataConWorkId_maybe, isId, idName, isDeadBinder, idPrimRep
, isPrimOpId_maybe )
-import Name ( NamedThing(..), getOccString, isGlobalName, isLocalName
+import Name ( NamedThing(..), getOccString, isExternalName, isInternalName
, nameModule )
import PrimRep ( PrimRep(..) )
-import DataCon ( DataCon, dataConRepArity, dataConRepArgTys, dataConId )
+import DataCon ( DataCon, dataConRepArity, dataConRepArgTys, dataConWorkId )
import qualified Type
import qualified CoreSyn
import CoreSyn ( CoreBind, CoreExpr, CoreAlt, CoreBndr,
import Maybe
import PrimOp
+import Util ( lengthIs, notNull )
#include "HsVersions.h"
\begin{code}
javaVar :: Id -> Expr
-javaVar v | isGlobalName (idName v) = mkNew (javaIdType v) []
+javaVar v | isExternalName (idName v) = mkNew (javaIdType v) []
| otherwise = Var (javaName v)
javaLit :: Literal.Literal -> Expr
javaLit (MachChar c) = Literal (CharLit c)
javaLit (MachStr fs) = Literal (StringLit str)
where
- str = concatMap renderString (_UNPK_ fs) ++ "\\000"
+ str = concatMap renderString (unpackFS fs) ++ "\\000"
-- This should really handle all the chars 0..31.
renderString '\NUL' = "\\000"
renderString other = [other]
-- 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
+javaCase r e x [(DataAlt d,bs,rhs)] | notNull bs
= java_expr PushExpr e ++
[ var [Final] (javaName x)
(whnf primRep (vmPOP (primRepToType primRep))) ] ++
]
javaCase r e x alts
- | isIfThenElse && isPrimCmp =
- javaIfThenElse r (fromJust maybePrim) tExpr fExpr
- | otherwise =
- java_expr PushExpr e ++
+ | 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)
+ , IfThenElse (map mk_alt con_alts) (Just default_code)
]
where
- isIfThenElse = CoreUtils.exprType e == boolTy
+ isIfThenElse = CoreUtils.exprType e `Type.eqType` 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
+ (_,_,tExpr) = CoreUtils.findAlt (DataAlt trueDataCon) alts
+ (_,_,fExpr) = CoreUtils.findAlt (DataAlt falseDataCon) alts
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)
+ (con_alts, maybe_default) = CoreUtils.findDefault alts
+ default_code = case maybe_default of
+ Nothing -> ExprStatement (Raise excName [Literal (StringLit "case failure")])
+ Just rhs -> Block (javaExpr r rhs)
+
+ mk_alt (DataAlt d, bs, rhs) = (instanceOf x d, Block (bind_args d bs ++ javaExpr r rhs))
+ mk_alt (LitAlt lit, bs, rhs) = (eqLit lit , Block (javaExpr r rhs))
eqLit (MachInt n) = Op (Literal (IntLit n))
, 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.
| 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
+ = case isDataConWorkId_maybe f of {
+ Just dc | as `lengthIs` dataConRepArity dc
-- NOTE: Saturated constructors never returning a primitive at this point
--
-- We push the arguments backwards, because we are using
-- using the same string as the Id.
javaName :: Id -> Name
javaName n
- | isGlobalName (idName n) = error "useing javaName on global"
+ | isExternalName (idName n) = error "useing javaName on global"
| otherwise = Name (getOccString n)
(primRepToType (idPrimRep n))
javaIdTypeName :: Id -> TypeName
javaIdTypeName n
- | isLocalName n' = renameForKeywords n'
+ | isInternalName n' = renameForKeywords n'
| otherwise = moduleString (nameModule n') ++ "." ++ renameForKeywords n'
where
n' = getName n
-- would return the name "Test.Foo".
javaConstrWkrName :: DataCon -> TypeName
-javaConstrWkrName = javaIdTypeName . dataConId
+javaConstrWkrName = javaIdTypeName . dataConWorkId
-- Makes x_inst for Rec decls
-- They are *never* is primitive