X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplCore.lhs;h=9e43be6081cad0ca51d8c6aed23f16c6af2f1fea;hb=132c92f70c00bb465cfd33178338287eb587a63c;hp=a7f0eb3eaf3f165d36f6fe81328a08b67adb32e2;hpb=2c8f04b5b883db74f449dfc8c224929fe28b027d;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index a7f0eb3..9e43be6 100644
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -27,14 +27,14 @@ import CoreSyn
 import CoreUtils	( coreExprType )
 import SimplUtils	( etaCoreExpr, typeOkForCase )
 import CoreUnfold
-import Literal		( Literal(..), literalType, mkMachInt )
+import Literal		( Literal(..), literalType, mkMachInt, mkMachInt_safe )
 import ErrUtils		( ghcExit, dumpIfSet, doIfSet )
 import FiniteMap	( FiniteMap, emptyFM )
 import FloatIn		( floatInwards )
 import FloatOut		( floatOutwards )
 import FoldrBuildWW	( mkFoldrBuildWW )
 import MkId		( mkSysLocal, mkUserId )
-import Id		( setIdVisibility, 
+import Id		( setIdVisibility, getIdSpecialisation, setIdSpecialisation,
                           getIdDemandInfo, idType,
 			  nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
  			  lookupIdEnv, IdEnv, 
@@ -62,8 +62,9 @@ import SAT		( doStaticArgs )
 import SimplMonad	( zeroSimplCount, showSimplCount, SimplCount )
 import SimplPgm		( simplifyPgm )
 import Specialise
+import SpecEnv		( substSpecEnv, isEmptySpecEnv )
 import StrictAnal	( saWwTopBinds )
-import TyVar		( TyVar, nameTyVar )
+import TyVar		( TyVar, nameTyVar, emptyTyVarEnv )
 import Unique		( Unique{-instance Eq-}, Uniquable(..),
 			  integerTyConKey, ratioTyConKey,
 			  mkUnique, incrUnique,
@@ -72,7 +73,7 @@ import Unique		( Unique{-instance Eq-}, Uniquable(..),
 import UniqSupply	( UniqSupply, mkSplitUniqSupply, 
                           splitUniqSupply, getUnique
 		        )
-import UniqFM           ( UniqFM, lookupUFM, addToUFM )
+import UniqFM           ( UniqFM, lookupUFM, addToUFM, delFromUFM )
 import Util		( mapAccumL )
 import SrcLoc		( noSrcLoc )
 import Constants	( tARGET_MIN_INT, tARGET_MAX_INT )
@@ -481,10 +482,10 @@ tidyCoreArg (TyArg ty)   = tidyTy ty 	`thenTM` \ ty' ->
 \end{code}
 
 \begin{code}
-tidyPrimOp (CCallOp fn casm gc tys ty)
+tidyPrimOp (CCallOp fn casm gc cconv tys ty)
   = mapTM tidyTy tys	`thenTM` \ tys' ->
     tidyTy ty		`thenTM` \ ty' ->
-    returnTM (CCallOp fn casm gc tys' ty')
+    returnTM (CCallOp fn casm gc cconv tys' ty')
 
 tidyPrimOp other_prim_op = returnTM other_prim_op
 \end{code}    
@@ -512,7 +513,7 @@ litToRep (NoRepStr s)
 	  then	 -- Must cater for NULs in literal string
 		mkGenApp (Var unpackCString2Id)
 			 [LitArg (MachStr s),
-		      	  LitArg (mkMachInt (toInteger (_LENGTH_ s)))]
+		      	  LitArg (mkMachInt_safe (toInteger (_LENGTH_ s)))]
 
 	  else	-- No NULs in the string
 		App (Var unpackCStringId) (LitArg (MachStr s))
@@ -535,7 +536,7 @@ litToRep (NoRepInteger i integer_ty)
   
   	| i > tARGET_MIN_INT &&		-- Small enough, so start from an Int
 	  i < tARGET_MAX_INT
-	= Prim Int2IntegerOp [LitArg (mkMachInt i)]
+	= Prim Int2IntegerOp [LitArg (mkMachInt (fromInteger i))]
   
   	| otherwise 			-- Big, so start from a string
 	= Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
@@ -608,19 +609,49 @@ mapTM f (x:xs) = f x	`thenTM` \ r ->
 
 \begin{code}
 -- Need to extend the environment when we munge a binder, so that occurrences
--- of the binder will print the correct way (i.e. as a global not a local)
+-- of the binder will print the correct way (e.g. as a global not a local)
 mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
 mungeTopBinder id thing_inside mod env us
   =  	-- Give it a new print-name unless it's an exported thing
 	-- setNameVisibility also does the local/global thing
     let
-	(id', us')  | isExported id = (id, us)
+	(id1, us')  | isExported id = (id, us)
 		    | otherwise
 		    = (setIdVisibility (Just mod) us id, 
 		       incrUnique us)
-	new_env    = addToUFM env id (ValBinder id')
+
+	-- Tidy the Id's SpecEnv
+	spec_env   = getIdSpecialisation id
+	id2 | isEmptySpecEnv spec_env = id1
+	    | otherwise		      = setIdSpecialisation id1 (tidySpecEnv env spec_env)
+
+	new_env    = addToUFM env id (ValBinder id2)
     in
-    thing_inside id' mod new_env us'
+    thing_inside id2 mod new_env us'
+
+tidySpecEnv env spec_env
+  = substSpecEnv 
+	emptyTyVarEnv		-- Top level only
+	(tidy_spec_rhs env)
+	spec_env
+  where
+	-- tidy_spec_rhs is another horrid little hacked-up function for
+	-- the RHS of specialisation templates.
+	-- It assumes there is no type substitution.
+	--
+	-- See also SimplVar.substSpecEnvRhs Urgh
+    tidy_spec_rhs env (Var v) = case lookupUFM env v of
+				  Just (ValBinder v') -> Var v'
+				  Nothing	      -> Var v
+    tidy_spec_rhs env (App f (VarArg v)) = App (tidy_spec_rhs env f) (case lookupUFM env v of
+								        Just (ValBinder v') -> VarArg v'
+								        Nothing	            -> VarArg v)
+    tidy_spec_rhs env (App f arg) = App (tidy_spec_rhs env f) arg
+    tidy_spec_rhs env (Lam b e)   = Lam b (tidy_spec_rhs env' e)
+				  where
+				    env' = case b of
+					     ValBinder id -> delFromUFM env id
+					     TyBinder _   -> env
 
 mungeTopBinders []     k = k []
 mungeTopBinders (b:bs) k = mungeTopBinder b	$ \ b' ->