Remove StgRubbishArg and CmmArg
[ghc.git] / compiler / codeGen / StgCmmEnv.hs
index 1d6f386..44d3df8 100644 (file)
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 -----------------------------------------------------------------------------
 --
 -- Stg to C-- code generation: the binding environment
 module StgCmmEnv (
         CgIdInfo,
 
-        cgIdInfoId, cgIdInfoLF,
-
         litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,
         idInfoToAmode,
 
-        NonVoid(..), isVoidId, nonVoidIds,
+        NonVoid(..), unsafe_stripNV, nonVoidIds,
 
         addBindC, addBindsC,
 
         bindArgsToRegs, bindToReg, rebindToReg,
         bindArgToReg, idToReg,
         getArgAmode, getNonVoidArgAmodes,
-        getCgIdInfo, 
-        maybeLetNoEscape, 
+        getCgIdInfo,
+        maybeLetNoEscape,
     ) where
 
 #include "HsVersions.h"
@@ -33,18 +33,17 @@ import StgCmmClosure
 
 import CLabel
 
-import DynFlags
-import MkGraph
 import BlockId
 import CmmExpr
 import CmmUtils
-import FastString
+import DynFlags
 import Id
-import VarEnv
-import Control.Monad
+import MkGraph
 import Name
-import StgSyn
 import Outputable
+import StgSyn
+import UniqFM
+import VarEnv
 
 -------------------------------------
 --        Non-void types
@@ -55,12 +54,13 @@ import Outputable
 newtype NonVoid a = NonVoid a
   deriving (Eq, Show)
 
+-- Use with care; if used inappropriately, it could break invariants.
+unsafe_stripNV :: NonVoid a -> a
+unsafe_stripNV (NonVoid a) = a
+
 instance (Outputable a) => Outputable (NonVoid a) where
   ppr (NonVoid a) = ppr a
 
-isVoidId :: Id -> Bool
-isVoidId = isVoidRep . idPrimRep
-
 nonVoidIds :: [Id] -> [NonVoid Id]
 nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))]
 
@@ -68,25 +68,22 @@ nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))]
 --        Manipulating CgIdInfo
 -------------------------------------
 
-mkCgIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
-mkCgIdInfo dflags id lf expr
+mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
+mkCgIdInfo id lf expr
   = CgIdInfo { cg_id = id, cg_lf = lf
-             , cg_loc = CmmLoc expr, 
-               cg_tag = lfDynTag dflags lf }
+             , cg_loc = CmmLoc expr }
 
 litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
 litIdInfo dflags id lf lit
   = CgIdInfo { cg_id = id, cg_lf = lf
-             , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) 
-             , cg_tag = tag }
+             , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) }
   where
     tag = lfDynTag dflags lf
 
 lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo
 lneIdInfo dflags id regs
   = CgIdInfo { cg_id = id, cg_lf = lf
-             , cg_loc = LneLoc blk_id (map (idToReg dflags) regs)
-             , cg_tag = lfDynTag dflags lf }
+             , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) }
   where
     lf     = mkLFLetNoEscape
     blk_id = mkBlockId (idUnique id)
@@ -96,7 +93,7 @@ rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
 rhsIdInfo id lf_info
   = do dflags <- getDynFlags
        reg <- newTemp (gcWord dflags)
-       return (mkCgIdInfo dflags id lf_info (CmmReg (CmmLocal reg)), reg)
+       return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)
 
 mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
 mkRhsInit dflags reg lf_info expr
@@ -112,12 +109,6 @@ addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr
 -- A tag adds a byte offset to the pointer
 addDynTag dflags expr tag = cmmOffsetB dflags expr tag
 
-cgIdInfoId :: CgIdInfo -> Id
-cgIdInfoId = cg_id 
-
-cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
-cgIdInfoLF = cg_lf
-
 maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
 maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
 maybeLetNoEscape _other                                      = Nothing
@@ -126,15 +117,15 @@ maybeLetNoEscape _other                                      = Nothing
 
 ---------------------------------------------------------
 --        The binding environment
--- 
--- There are three basic routines, for adding (addBindC), 
+--
+-- There are three basic routines, for adding (addBindC),
 -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
 ---------------------------------------------------------
 
-addBindC :: Id -> CgIdInfo -> FCode ()
-addBindC name stuff_to_bind = do
+addBindC :: CgIdInfo -> FCode ()
+addBindC stuff_to_bind = do
         binds <- getBinds
-        setBinds $ extendVarEnv binds name stuff_to_bind
+        setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind
 
 addBindsC :: [CgIdInfo] -> FCode ()
 addBindsC new_bindings = do
@@ -146,59 +137,47 @@ addBindsC new_bindings = do
 
 getCgIdInfo :: Id -> FCode CgIdInfo
 getCgIdInfo id
-  = do        {         -- Try local bindings first
-        ; local_binds  <- getBinds
+  = do  { dflags <- getDynFlags
+        ; local_binds <- getBinds -- Try local bindings first
         ; case lookupVarEnv local_binds id of {
             Just info -> return info ;
-            Nothing   -> do
-
-        {         -- Try top-level bindings
-          static_binds <- getStaticBinds
-        ; case lookupVarEnv static_binds id of {
-            Just info -> return info ;
-            Nothing   ->
+            Nothing   -> do {
 
                 -- Should be imported; make up a CgIdInfo for it
-        let 
-            name = idName id
-        in
-        if isExternalName name then do
-            let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
-            dflags <- getDynFlags
-            return (litIdInfo dflags id (mkLFImported id) ext_lbl)
-        else
-            -- Bug        
-            cgLookupPanic id
-        }}}}
-    
+          let name = idName id
+        ; if isExternalName name then
+              let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
+              in return (litIdInfo dflags id (mkLFImported id) ext_lbl)
+          else
+              cgLookupPanic id -- Bug
+        }}}
+
 cgLookupPanic :: Id -> FCode a
 cgLookupPanic id
-  = do  static_binds <- getStaticBinds
-        local_binds <- getBinds
+  = do  local_binds <- getBinds
         pprPanic "StgCmmEnv: variable not found"
                 (vcat [ppr id,
-                ptext (sLit "static binds for:"),
-                vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
-                ptext (sLit "local binds for:"),
-                vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ]
+                text "local binds for:",
+                pprUFM local_binds $ \infos ->
+                  vcat [ ppr (cg_id info) | info <- infos ]
               ])
 
 
 --------------------
 getArgAmode :: NonVoid StgArg -> FCode CmmExpr
-getArgAmode (NonVoid (StgVarArg var))  =
-  do { info  <- getCgIdInfo var; return (idInfoToAmode info) }
-getArgAmode (NonVoid (StgLitArg lit))  = liftM CmmLit $ cgLit lit
+getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var
+getArgAmode (NonVoid (StgLitArg lit)) = CmmLit <$> cgLit lit
 
 getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
--- NB: Filters out void args, 
+-- NB: Filters out void args,
 --     so the result list may be shorter than the argument list
 getNonVoidArgAmodes [] = return []
 getNonVoidArgAmodes (arg:args)
   | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
   | otherwise = do { amode  <- getArgAmode (NonVoid arg)
-                    ; amodes <- getNonVoidArgAmodes args
-                    ; return ( amode : amodes ) }
+                   ; amodes <- getNonVoidArgAmodes args
+                   ; return ( amode : amodes ) }
+
 
 ------------------------------------------------------------------------
 --        Interface functions for binding and re-binding names
@@ -209,15 +188,15 @@ bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
 bindToReg nvid@(NonVoid id) lf_info
   = do dflags <- getDynFlags
        let reg = idToReg dflags nvid
-       addBindC id (mkCgIdInfo dflags id lf_info (CmmReg (CmmLocal reg)))
+       addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
        return reg
 
 rebindToReg :: NonVoid Id -> FCode LocalReg
--- Like bindToReg, but the Id is already in scope, so 
+-- Like bindToReg, but the Id is already in scope, so
 -- get its LF info from the envt
 rebindToReg nvid@(NonVoid id)
   = do  { info <- getCgIdInfo id
-        ; bindToReg nvid (cgIdInfoLF info) }
+        ; bindToReg nvid (cg_lf info) }
 
 bindArgToReg :: NonVoid Id -> FCode LocalReg
 bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
@@ -232,7 +211,7 @@ idToReg :: DynFlags -> NonVoid Id -> LocalReg
 -- We re-use the Unique from the Id to make it easier to see what is going on
 --
 -- By now the Ids should be uniquely named; else one would worry
--- about accidental collision 
+-- about accidental collision
 idToReg dflags (NonVoid id)
              = LocalReg (idUnique id)
                         (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)