floating-point fix for x86_64

[ghc-hetmet.git] / ghc / compiler / javaGen / JavaGen.lhs

diff --git a/ghc/compiler/javaGen/JavaGen.lhs b/ghc/compiler/javaGen/JavaGen.lhs
index 7164929..a3925b1 100644 (file)
--- a/ghc/compiler/javaGen/JavaGen.lhs
+++ b/ghc/compiler/javaGen/JavaGen.lhs
@@ -47,12 +47,12 @@ module JavaGen( javaGen ) where
 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,
@@ -66,6 +66,7 @@ import Outputable
 
 import Maybe
 import PrimOp
+import Util     ( lengthIs, notNull )
 
 #include "HsVersions.h"
 
@@ -219,7 +220,7 @@ java_top_bind bndr rhs
 
 \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
@@ -227,7 +228,7 @@ 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"
+       str = concatMap renderString (unpackFS fs) ++ "\\000"
        -- This should really handle all the chars 0..31.
        renderString '\NUL' = "\\000"
        renderString other  = [other]
@@ -266,7 +267,7 @@ javaCase :: (Expr -> Statement) -> CoreExpr -> Id -> [CoreAlt] -> [Statement]
 -- 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))) ] ++
@@ -286,37 +287,34 @@ javaCase r e x [(DataAlt d,bs,rhs)] | length bs > 0
                      ]
    
 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))
@@ -336,14 +334,6 @@ javaCase r e x alts
                      , 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.
@@ -430,8 +420,8 @@ 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
+  = 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
@@ -734,7 +724,7 @@ withType (Name n _) t = Name n t
 -- 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))
 
@@ -744,7 +734,7 @@ javaName n
 
 javaIdTypeName :: Id -> TypeName
 javaIdTypeName n
-    | isLocalName n' = renameForKeywords n'
+    | isInternalName n' = renameForKeywords n'
     | otherwise      = moduleString (nameModule n') ++ "." ++ renameForKeywords n'
   where
             n' = getName n
@@ -765,7 +755,7 @@ shortName = reverse . takeWhile (/= '.') . reverse
 -- 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
@@ -901,7 +891,7 @@ newtype LifterM a =
        LifterM { unLifterM ::
                     TypeName ->                -- this class name
                     Int ->                     -- uniq supply
-                         ( a                   -- *
+                         ( a                   --  *
                            , Frees             -- frees
                            , [Decl]            -- lifted classes
                            , Int               -- The uniqs