[project @ 1999-04-09 01:55:15 by kglynn]

[ghc-hetmet.git] / ghc / compiler / simplCore / SimplCore.lhs

diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index e89e36b..dfd9ac5 100644 (file)
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -39,23 +39,20 @@ import IdInfo               ( InlinePragInfo(..), specInfo, setSpecInfo,
                        )
 import VarEnv
 import VarSet
+import Module          ( Module )
 import Name            ( mkLocalName, tidyOccName, tidyTopName, initTidyOccEnv, isExported,
-                         Module, NamedThing(..), OccName
+                         NamedThing(..), OccName
                        )
 import TyCon           ( TyCon, isDataTyCon )
 import PrimOp          ( PrimOp(..) )
-import PrelInfo                ( unpackCStringId, unpackCString2Id,
-                         integerZeroId, integerPlusOneId,
-                         integerPlusTwoId, integerMinusOneId,
-                         int2IntegerId, addr2IntegerId
-                       )
+import PrelInfo                ( unpackCStringId, unpackCString2Id, addr2IntegerId )
 import Type            ( Type, splitAlgTyConApp_maybe, 
-                         isUnLiftedType, mkTyVarTy, 
+                         isUnLiftedType,
                          tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
                          Type
                        )
 import Class           ( Class, classSelIds )
-import TysWiredIn      ( isIntegerTy )
+import TysWiredIn      ( smallIntegerDataCon, isIntegerTy )
 import LiberateCase    ( liberateCase )
 import SAT             ( doStaticArgs )
 import Specialise      ( specProgram)
@@ -68,10 +65,13 @@ import Unique               ( Unique, Uniquable(..),
 import UniqSupply      ( UniqSupply, splitUniqSupply, uniqFromSupply )
 import Constants       ( tARGET_MIN_INT, tARGET_MAX_INT )
 import Util            ( mapAccumL )
+import SrcLoc          ( noSrcLoc )
 import Bag
 import Maybes
 import IO              ( hPutStr, stderr )
 import Outputable
+
+import Ratio           ( numerator, denominator )
 \end{code}
 
 \begin{code}
@@ -114,6 +114,9 @@ doCorePass us binds CoreDoFullLaziness       = _scc_ "CoreFloating"   floatOutwa
 doCorePass us binds CoreDoStaticArgs        = _scc_ "CoreStaticArgs" doStaticArgs us binds
 doCorePass us binds CoreDoStrictness        = _scc_ "CoreStranal"    saWwTopBinds us binds
 doCorePass us binds CoreDoSpecialising      = _scc_ "Specialise"     specProgram us binds
+doCorePass us binds CoreDoPrintCore         = _scc_ "PrintCore"      do
+                                                                       putStr (showSDoc $ pprCoreBindings binds)
+                                                                      return binds
 \end{code}
 
 
@@ -195,10 +198,11 @@ simplifyPgm sw_chkr us binds
          (us1, us2) = splitUniqSupply us
 
 
-simplTopBinds []              = returnSmpl []
-simplTopBinds (bind1 : binds) = (simplBind bind1       $
-                                simplTopBinds binds)   `thenSmpl` \ (binds1', binds') ->
-                               returnSmpl (binds1' ++ binds')
+simplTopBinds binds = go binds         `thenSmpl` \ (binds', _) ->
+                     returnSmpl binds'
+                   where
+                     go []              = returnSmpl ([], ())
+                     go (bind1 : binds) = simplBind bind1 (go binds)
 \end{code}
 
 
@@ -304,6 +308,8 @@ tidyAlt env (con, vs, rhs)   = (con, vs', tidyExpr env' rhs)
                               (env', vs') = mapAccumL tidyNestedBndr env vs
 
 tidyNote env (Coerce t1 t2)  = Coerce (tidyType env t1) (tidyType env t2)
+
+tidyNote env note            = note
 \end{code}
 
 \begin{code}
@@ -318,7 +324,8 @@ tidyNestedBndr env@(tidy_env, var_env) id
   =    -- Non-top-level variables
     let 
        -- Give the Id a fresh print-name, *and* rename its type
-       name'             = mkLocalName (getUnique id) occ'
+       -- The SrcLoc isn't important now, though we could extract it from the Id
+       name'             = mkLocalName (getUnique id) occ' noSrcLoc
        (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
         ty'              = tidyType env (idType id)
        id'               = mkUserId name' ty'
@@ -361,7 +368,7 @@ tidyIdInfo env info
     info3 = noUnfolding `setUnfoldingInfo` info2
 
     tidy_item (tyvars, tys, rhs)
-       = (tyvars', tidyTypes env' tys, tidyExpr env rhs)
+       = (tyvars', tidyTypes env' tys, tidyExpr env' rhs)
        where
          (env', tyvars') = tidyTyVars env tyvars
 \end{code}
@@ -627,20 +634,15 @@ litToRep (NoRepStr s ty)
 
 If an Integer is small enough (Haskell implementations must support
 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
-otherwise, wrap with @litString2Integer@.
+otherwise, wrap with @addr2Integer@.
 
 \begin{code}
 litToRep (NoRepInteger i integer_ty)
   = returnPM (integer_ty, rhs)
   where
-    rhs | i == 0    = Var integerZeroId                -- Extremely convenient to look out for
-       | i == 1    = Var integerPlusOneId      -- a few very common Integer literals!
-       | i == 2    = Var integerPlusTwoId
-       | i == (-1) = Var integerMinusOneId
-  
-       | i > tARGET_MIN_INT &&         -- Small enough, so start from an Int
+    rhs | i > tARGET_MIN_INT &&                -- Small enough, so start from an Int
          i < tARGET_MAX_INT
-       = App (Var int2IntegerId) (Con (Literal (mkMachInt i)) [])
+       = Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]
   
        | otherwise                     -- Big, so start from a string
        = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])