[project @ 1996-07-15 16:16:46 by partain]

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

diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs
index bc8fac7..20662f8 100644 (file)
--- a/ghc/compiler/simplCore/SimplMonad.lhs
+++ b/ghc/compiler/simplCore/SimplMonad.lhs
@@ -7,7 +7,7 @@
 #include "HsVersions.h"
 
 module SimplMonad (
-       SmplM(..),
+       SYN_IE(SmplM),
        initSmpl, returnSmpl, thenSmpl, thenSmpl_,
        mapSmpl, mapAndUnzipSmpl,
 
@@ -18,26 +18,24 @@ module SimplMonad (
 
        -- Cloning
        cloneId, cloneIds, cloneTyVarSmpl, newIds, newId
-
-       -- and to make the interface self-sufficient...
     ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
+IMPORT_1_3(Ix)
 
-import SmplLoop                -- well, cheating sort of
+IMPORT_DELOOPER(SmplLoop)              -- well, cheating sort of
 
-import Id              ( mkSysLocal )
+import Id              ( mkSysLocal, mkIdWithNewUniq )
+import CoreUnfold      ( SimpleUnfolding )
 import SimplEnv
 import SrcLoc          ( mkUnknownSrcLoc )
+import TyVar           ( cloneTyVar )
 import UniqSupply      ( getUnique, getUniques, splitUniqSupply,
                          UniqSupply
                        )
 import Util            ( zipWithEqual, panic )
 
 infixr 9  `thenSmpl`, `thenSmpl_`
-
-cloneTyVar = panic "cloneTyVar (SimplMonad)"
-mkIdWithNewUniq = panic "mkIdWithNewUniq (SimplMonad)"
 \end{code}
 
 %************************************************************************
@@ -129,6 +127,7 @@ data TickType
   | CaseOfError
   | TyBetaReduction
   | BetaReduction
+  | SpecialisationDone
   {- BEGIN F/B ENTRIES -}
   -- the 8 rules
   | FoldrBuild         -- foldr f z (build g) ==>
@@ -144,9 +143,9 @@ data TickType
   | Foldr_Cons_Nil     -- foldr (:) [] => id
   | Foldr_Cons         -- foldr (:) => flip (++)
 
-  | Str_FoldrStr       -- foldr f z "hello" => unpackFoldrPS# f z "hello"
-  | Str_UnpackCons     -- unpackFoldrPS# (:) z "hello" => unpackAppendPS# z "hello"
-  | Str_UnpackNil      -- unpackAppendPS# [] "hello" => "hello"
+  | Str_FoldrStr       -- foldr f z "hello" => unpackFoldrPS__ f z "hello"
+  | Str_UnpackCons     -- unpackFoldrPS# (:) z "hello" => unpackAppendPS__ z "hello"
+  | Str_UnpackNil      -- unpackAppendPS__ [] "hello" => "hello"
   {- END F/B ENTRIES -}
   deriving (Eq, Ord, Ix)
 
@@ -168,6 +167,9 @@ instance Text TickType where
     showsPrec p CaseOfError    = showString "CaseOfError      "
     showsPrec p TyBetaReduction        = showString "TyBetaReduction  "
     showsPrec p BetaReduction  = showString "BetaReduction    "
+    showsPrec p SpecialisationDone 
+                               = showString "Specialisation   "
+
        -- Foldr/Build Stuff:
     showsPrec p FoldrBuild     = showString "FoldrBuild       "
     showsPrec p FoldrAugment   = showString "FoldrAugment     "
@@ -215,6 +217,7 @@ zeroSimplCount
        (CaseOfError, 0),
        (TyBetaReduction,0),
        (BetaReduction,0),
+       (SpecialisationDone,0),
        -- Foldr/Build Stuff:
        (FoldrBuild, 0),
        (FoldrAugment, 0),
@@ -260,6 +263,8 @@ tick tick_type us (SimplCount n stuff)
 
 tickN :: TickType -> Int -> SmplM ()
 
+tickN tick_type 0 us counts 
+  = ((), counts)
 tickN tick_type IBOX(increment) us (SimplCount n stuff)
   = ((), SimplCount (n _ADD_ increment)
 #ifdef OMIT_SIMPL_COUNTS
@@ -294,7 +299,7 @@ combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
 #else
 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
   = SimplCount (n1 _ADD_ n2)
-              (zipWithEqual (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2)
+              (zipWithEqual "combineSimplCounts" (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2)
 #endif
 \end{code}
 
@@ -313,7 +318,7 @@ newId ty us sc
 
 newIds :: [Type] -> SmplM [Id]
 newIds tys us sc
-  = (zipWithEqual mk_id tys uniqs, sc)
+  = (zipWithEqual "newIds" mk_id tys uniqs, sc)
   where
     uniqs  = getUniques (length tys) us
     mk_id ty uniq = mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc