X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgBindery.lhs;h=2ea13f6ad86e625587cbdb019c62dd53bc402b02;hp=f78edda6554b1f8376159ac3ae015181b0acae1f;hb=30c122df62ec75f9ed7f392f24c2925675bf1d06;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1

diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs
index f78edda..2ea13f6 100644
--- a/compiler/codeGen/CgBindery.lhs
+++ b/compiler/codeGen/CgBindery.lhs
@@ -1,16 +1,25 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[CgBindery]{Utility functions related to doing @CgBindings@}
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module CgBindery (
 	CgBindings, CgIdInfo,
 	StableLoc, VolatileLoc,
 
 	cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF,
 
-	stableIdInfo, heapIdInfo, 
+	stableIdInfo, heapIdInfo,
+        taggedStableIdInfo, taggedHeapIdInfo,
 	letNoEscapeIdInfo, idInfoToAmode,
 
 	addBindC, addBindsC,
@@ -18,10 +27,11 @@ module CgBindery (
 	nukeVolatileBinds,
 	nukeDeadBindings,
 	getLiveStackSlots,
+        getLiveStackBindings,
 
 	bindArgsToStack,  rebindToStack,
-	bindNewToNode, bindNewToReg, bindArgsToRegs,
-	bindNewToTemp, 
+	bindNewToNode, bindNewToUntagNode, bindNewToReg, bindArgsToRegs,
+	bindNewToTemp,
 	getArgAmode, getArgAmodes, 
 	getCgIdInfo, 
 	getCAddrModeIfVolatile, getVolatileRegs,
@@ -31,27 +41,29 @@ module CgBindery (
 #include "HsVersions.h"
 
 import CgMonad
-import CgHeapery	( getHpRelOffset )
-import CgStackery	( freeStackSlots, getSpRelOffset )
-import CgUtils		( cgLit, cmmOffsetW )
-import CLabel		( mkClosureLabel, pprCLabel )
-import ClosureInfo	( mkLFImported, mkLFArgument, LambdaFormInfo )
+import CgHeapery
+import CgStackery
+import CgUtils
+import CLabel
+import ClosureInfo
+import Constants
 
 import Cmm
 import PprCmm		( {- instance Outputable -} )
-import SMRep		( CgRep(..), WordOff, isFollowableArg, 
-			  isVoidArg, cgRepSizeW, argMachRep, 
-			  idCgRep, typeCgRep )
-import Id		( Id, idName )
+import SMRep
+import Id
+import DataCon
 import VarEnv
-import VarSet		( varSetElems )
-import Literal		( literalType )
-import Maybes		( catMaybes )
-import Name		( isExternalName )
-import StgSyn		( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg )
-import Unique           ( Uniquable(..) )
-import UniqSet		( elementOfUniqSet )
+import VarSet
+import Literal
+import Maybes
+import Name
+import StgSyn
+import Unique
+import UniqSet
 import Outputable
+import FastString
+
 \end{code}
 
 
@@ -80,23 +92,44 @@ data CgIdInfo
 	, cg_rep :: CgRep
 	, cg_vol :: VolatileLoc
 	, cg_stb :: StableLoc
-	, cg_lf  :: LambdaFormInfo }
+	, cg_lf  :: LambdaFormInfo 
+        , cg_tag :: {-# UNPACK #-} !Int  -- tag to be added in idInfoToAmode
+         }
 
 mkCgIdInfo id vol stb lf
   = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, 
-	       cg_lf = lf, cg_rep = idCgRep id }
+	       cg_lf = lf, cg_rep = idCgRep id, cg_tag = tag }
+  where
+    tag
+      | Just con <- isDataConWorkId_maybe id,
+          {- Is this an identifier for a static constructor closure? -}
+        isNullaryRepDataCon con
+          {- If yes, is this a nullary constructor?
+             If yes, we assume that the constructor is evaluated and can
+             be tagged.
+           -}
+      = tagForCon con
+
+      | otherwise
+      = funTagLFInfo lf
 
 voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc
 			 , cg_stb = VoidLoc, cg_lf = mkLFArgument id
-			 , cg_rep = VoidArg }
+			 , cg_rep = VoidArg, cg_tag = 0 }
 	-- Used just for VoidRep things
 
 data VolatileLoc	-- These locations die across a call
   = NoVolatileLoc
   | RegLoc	CmmReg		   -- In one of the registers (global or local)
   | VirHpLoc	VirtualHpOffset  -- Hp+offset (address of closure)
-  | VirNodeLoc	VirtualHpOffset  -- Cts of offset indirect from Node
-				   -- ie *(Node+offset)
+  | VirNodeLoc	ByteOff            -- Cts of offset indirect from Node
+				   -- ie *(Node+offset).
+                                   -- NB. Byte offset, because we subtract R1's
+                                   -- tag from the offset.
+
+mkTaggedCgIdInfo id vol stb lf con
+  = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, 
+	       cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon con }
 \end{code}
 
 @StableLoc@ encodes where an Id can be found, used by
@@ -121,7 +154,7 @@ data StableLoc
 
 \begin{code}
 instance Outputable CgIdInfo where
-  ppr (CgIdInfo id rep vol stb lf)
+  ppr (CgIdInfo id rep vol stb lf _) -- TODO, pretty pring the tag info
     = ppr id <+> ptext SLIT("-->") <+> vcat [ppr vol, ppr stb]
 
 instance Outputable VolatileLoc where
@@ -149,19 +182,29 @@ stableIdInfo id amode   lf_info = mkCgIdInfo id NoVolatileLoc (StableLoc amode)
 heapIdInfo id offset    lf_info = mkCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info
 letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info
 stackIdInfo id sp	lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info
-nodeIdInfo id offset    lf_info = mkCgIdInfo id (VirNodeLoc offset) NoStableLoc lf_info
+nodeIdInfo id offset    lf_info = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset)) NoStableLoc lf_info
 regIdInfo id reg        lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info
 
+taggedStableIdInfo id amode lf_info con
+  = mkTaggedCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info con
+taggedHeapIdInfo id offset lf_info con
+  = mkTaggedCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info con
+untagNodeIdInfo id offset    lf_info tag
+  = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset - tag)) NoStableLoc lf_info
+
+
 idInfoToAmode :: CgIdInfo -> FCode CmmExpr
 idInfoToAmode info
   = case cg_vol info of {
       RegLoc reg 	-> returnFC (CmmReg reg) ;
-      VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetW (CmmReg nodeReg) nd_off) mach_rep) ;
-      VirHpLoc hp_off   -> getHpRelOffset hp_off ;
+      VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetB (CmmReg nodeReg) nd_off)
+                                             mach_rep) ;
+      VirHpLoc hp_off   -> do { off <- getHpRelOffset hp_off
+                              ; return $! maybeTag off };
       NoVolatileLoc -> 
 
     case cg_stb info of
-      StableLoc amode  -> returnFC amode
+      StableLoc amode  -> returnFC $! maybeTag amode
       VirStkLoc sp_off -> do { sp_rel <- getSpRelOffset sp_off
 			     ; return (CmmLoad sp_rel mach_rep) }
 
@@ -177,6 +220,11 @@ idInfoToAmode info
   where
     mach_rep = argMachRep (cg_rep info)
 
+    maybeTag amode  -- add the tag, if we have one
+      | tag == 0   = amode
+      | otherwise  = cmmOffsetB amode tag
+      where tag = cg_tag info
+
 cgIdInfoId :: CgIdInfo -> Id
 cgIdInfoId = cg_id 
 
@@ -240,8 +288,7 @@ getCgIdInfo id
 	    name = idName id
 	in
 	if isExternalName name then do
-	    hmods <- getHomeModules 
-	    let ext_lbl = CmmLit (CmmLabel (mkClosureLabel hmods name))
+	    let ext_lbl = CmmLit (CmmLabel (mkClosureLabel name))
 	    return (stableIdInfo id ext_lbl (mkLFImported id))
 	else
 	if isVoidArg (idCgRep id) then
@@ -389,16 +436,23 @@ bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code
 bindNewToNode id offset lf_info
   = addBindC id (nodeIdInfo id offset lf_info)
 
+bindNewToUntagNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Int -> Code
+bindNewToUntagNode id offset lf_info tag
+  = addBindC id (untagNodeIdInfo id offset lf_info tag)
+
 -- Create a new temporary whose unique is that in the id,
 -- bind the id to it, and return the addressing mode for the
 -- temporary.
-bindNewToTemp :: Id -> FCode CmmReg
+bindNewToTemp :: Id -> FCode LocalReg
 bindNewToTemp id
-  = do	addBindC id (regIdInfo id temp_reg lf_info)
+  = do	addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info)
 	return temp_reg
   where
     uniq     = getUnique id
-    temp_reg = CmmLocal (LocalReg uniq (argMachRep (idCgRep id)))
+    temp_reg = LocalReg uniq (argMachRep (idCgRep id)) kind
+    kind     = if isFollowableArg (idCgRep id)
+               then GCKindPtr
+               else GCKindNonPtr
     lf_info  = mkLFArgument id	-- Always used of things we
 				-- know nothing about
 
@@ -492,3 +546,14 @@ getLiveStackSlots
 				   cg_rep = rep } <- varEnvElts binds, 
 		        isFollowableArg rep] }
 \end{code}
+
+\begin{code}
+getLiveStackBindings :: FCode [(VirtualSpOffset, CgIdInfo)]
+getLiveStackBindings
+  = do { binds <- getBinds
+       ; return [(off, bind) |
+                 bind <- varEnvElts binds,
+                 CgIdInfo { cg_stb = VirStkLoc off,
+                            cg_rep = rep} <- [bind],
+                 isFollowableArg rep] }
+\end{code}