Add support for producing position-independent executables
[ghc.git] / compiler / codeGen / StgCmmEnv.hs
index c43bf80..3061fb3 100644 (file)
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 -----------------------------------------------------------------------------
 --
 -- Stg to C-- code generation: the binding environment
@@ -5,26 +7,24 @@
 -- (c) The University of Glasgow 2004-2006
 --
 -----------------------------------------------------------------------------
-
 module StgCmmEnv (
-       CgIdInfo,
-
-       cgIdInfoId, cgIdInfoLF,
+        CgIdInfo,
 
-       litIdInfo, lneIdInfo, regIdInfo,
-       idInfoToAmode,
+        litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,
+        idInfoToAmode,
 
-       addBindC, addBindsC,
+        addBindC, addBindsC,
 
-       bindArgsToRegs, bindToReg, rebindToReg,
-       bindArgToReg, idToReg,
-       getArgAmode, getNonVoidArgAmodes, 
-       getCgIdInfo, 
-       maybeLetNoEscape, 
+        bindArgsToRegs, bindToReg, rebindToReg,
+        bindArgToReg, idToReg,
+        getArgAmode, getNonVoidArgAmodes,
+        getCgIdInfo,
+        maybeLetNoEscape,
     ) where
 
 #include "HsVersions.h"
 
+import TyCon
 import StgCmmMonad
 import StgCmmUtils
 import StgCmmClosure
@@ -32,178 +32,175 @@ import StgCmmClosure
 import CLabel
 
 import BlockId
-import Cmm
+import CmmExpr
 import CmmUtils
-import FastString
-import PprCmm          ( {- instance Outputable -} )
+import DynFlags
 import Id
-import VarEnv
-import Maybes
+import MkGraph
 import Name
-import StgSyn
 import Outputable
-
-
+import StgSyn
+import Type
+import TysPrim
+import UniqFM
+import Util
+import VarEnv
 
 -------------------------------------
---     Manipulating CgIdInfo
+--        Manipulating CgIdInfo
 -------------------------------------
 
 mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
 mkCgIdInfo id lf expr
-  = CgIdInfo { cg_id = id, cg_loc = CmmLoc expr, 
-              cg_lf = lf, cg_rep = idPrimRep id, 
-              cg_tag = lfDynTag lf }
-
-lneIdInfo :: Id -> [LocalReg] -> CgIdInfo
-lneIdInfo id regs 
-  = CgIdInfo { cg_id = id, cg_loc = LneLoc blk_id regs,
-              cg_lf = lf, cg_rep = idPrimRep id, 
-              cg_tag = lfDynTag lf }
+  = CgIdInfo { cg_id = id, cg_lf = 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) }
+  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) }
   where
     lf     = mkLFLetNoEscape
     blk_id = mkBlockId (idUnique id)
 
-litIdInfo :: Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
-litIdInfo id lf_info lit = mkCgIdInfo id lf_info (CmmLit lit)
 
-regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CgIdInfo
-regIdInfo id lf_info reg = mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))
+rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
+rhsIdInfo id lf_info
+  = do dflags <- getDynFlags
+       reg <- newTemp (gcWord dflags)
+       return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)
+
+mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
+mkRhsInit dflags reg lf_info expr
+  = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))
 
 idInfoToAmode :: CgIdInfo -> CmmExpr
 -- Returns a CmmExpr for the *tagged* pointer
-idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e, cg_tag = tag })
-  = addDynTag e tag
+idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
 idInfoToAmode cg_info
-  = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))     -- LneLoc
+  = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))        -- LneLoc
 
-addDynTag :: CmmExpr -> DynTag -> CmmExpr
+addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr
 -- A tag adds a byte offset to the pointer
-addDynTag expr tag = cmmOffsetB expr tag
-
-cgIdInfoId :: CgIdInfo -> Id
-cgIdInfoId = cg_id 
-
-cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
-cgIdInfoLF = cg_lf
+addDynTag dflags expr tag = cmmOffsetB dflags expr tag
 
 maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
 maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
-maybeLetNoEscape _other                                   = Nothing
+maybeLetNoEscape _other                                      = Nothing
 
 
 
 ---------------------------------------------------------
---     The binding environment
--- 
--- There are three basic routines, for adding (addBindC), 
+--        The binding environment
+--
+-- 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
-       binds <- getBinds
-       setBinds $ extendVarEnv binds name stuff_to_bind
+addBindC :: CgIdInfo -> FCode ()
+addBindC stuff_to_bind = do
+        binds <- getBinds
+        setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind
 
-addBindsC :: [(Id, CgIdInfo)] -> FCode ()
+addBindsC :: [CgIdInfo] -> FCode ()
 addBindsC new_bindings = do
-       binds <- getBinds
-       let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
-                             binds
-                             new_bindings
-       setBinds new_binds
+        binds <- getBinds
+        let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info)
+                              binds
+                              new_bindings
+        setBinds new_binds
 
 getCgIdInfo :: Id -> FCode CgIdInfo
 getCgIdInfo id
-  = do {       -- Try local bindings first
-       ; local_binds  <- getBinds
-       ; 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   ->
-
-               -- 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)
-           return (litIdInfo id (mkLFImported id) ext_lbl)
-       else
-       -- Bug  
-       cgLookupPanic id
-       }}}}
-    
+  = do  { dflags <- getDynFlags
+        ; local_binds <- getBinds -- Try local bindings first
+        ; case lookupVarEnv local_binds id of {
+            Just info -> return info ;
+            Nothing   -> do {
+
+                -- Should be imported; make up a CgIdInfo for it
+          let name = idName id
+        ; if isExternalName name then
+              let ext_lbl
+                      | isUnliftedType (idType id) =
+                          -- An unlifted external Id must refer to a top-level
+                          -- string literal. See Note [Bytes label] in CLabel.
+                          ASSERT( idType id `eqType` addrPrimTy )
+                          mkBytesLabel name
+                      | otherwise = mkClosureLabel name $ idCafInfo id
+              in return $
+                  litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl)
+          else
+              cgLookupPanic id -- Bug
+        }}}
+
 cgLookupPanic :: Id -> FCode a
 cgLookupPanic id
-  = do static_binds <- getStaticBinds
-       local_binds <- getBinds
-       srt <- getSRTLabel
-       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 ],
-               ptext (sLit "SRT label") <+> pprCLabel srt
-             ])
+  = do  local_binds <- getBinds
+        pprPanic "StgCmmEnv: variable not found"
+                (vcat [ppr id,
+                text "local binds for:",
+                pprUFM local_binds $ \infos ->
+                  vcat [ ppr (cg_id info) | info <- infos ]
+              ])
 
 
 --------------------
-getArgAmode :: StgArg -> FCode CmmExpr
-getArgAmode (StgVarArg var)  = do { info  <- getCgIdInfo var; return (idInfoToAmode info) }
-getArgAmode (StgLitArg lit)  = return (CmmLit (mkSimpleLit lit))
-getArgAmode (StgTypeArg _)   = panic "getArgAmode: type arg"
+getArgAmode :: NonVoid StgArg -> FCode CmmExpr
+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  arg 
-                  ; amodes <- getNonVoidArgAmodes args
-                  ; return ( amode : amodes ) }
+  | otherwise = do { amode  <- getArgAmode (NonVoid arg)
+                   ; amodes <- getNonVoidArgAmodes args
+                   ; return ( amode : amodes ) }
 
 
 ------------------------------------------------------------------------
---     Interface functions for binding and re-binding names
+--        Interface functions for binding and re-binding names
 ------------------------------------------------------------------------
 
-bindToReg :: Id -> LambdaFormInfo -> FCode LocalReg
+bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
 -- Bind an Id to a fresh LocalReg
-bindToReg id lf_info
-  = do { let reg = idToReg id
-       ; addBindC id (regIdInfo id lf_info reg)
-       ; return reg }
-
-rebindToReg :: Id -> FCode LocalReg
--- Like bindToReg, but the Id is already in scope, so 
+bindToReg nvid@(NonVoid id) lf_info
+  = do dflags <- getDynFlags
+       let reg = idToReg dflags nvid
+       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
 -- get its LF info from the envt
-rebindToReg id 
-  = do { info <- getCgIdInfo id
-       ; bindToReg id (cgIdInfoLF info) }
+rebindToReg nvid@(NonVoid id)
+  = do  { info <- getCgIdInfo id
+        ; bindToReg nvid (cg_lf info) }
 
-bindArgToReg :: Id -> FCode LocalReg
-bindArgToReg id = bindToReg id (mkLFArgument id)
+bindArgToReg :: NonVoid Id -> FCode LocalReg
+bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
 
-bindArgsToRegs :: [Id] -> FCode [LocalReg]
+bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
 bindArgsToRegs args = mapM bindArgToReg args
 
-idToReg :: Id -> LocalReg
+idToReg :: DynFlags -> NonVoid Id -> LocalReg
 -- Make a register from an Id, typically a function argument,
 -- free variable, or case binder
 --
 -- 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 
-idToReg id = LocalReg (idUnique id) 
-                     (primRepCmmType (idPrimRep id))
-
-
+-- about accidental collision
+idToReg dflags (NonVoid id)
+             = LocalReg (idUnique id)
+                        (primRepCmmType dflags (idPrimRep id))