Remove platform CPP from nativeGen/PPC/CodeGen.hs

[ghc-hetmet.git] / compiler / codeGen / StgCmmEnv.hs

diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs
index c43bf80..369e199 100644 (file)
--- a/compiler/codeGen/StgCmmEnv.hs
+++ b/compiler/codeGen/StgCmmEnv.hs
@@ -14,6 +14,8 @@ module StgCmmEnv (
        litIdInfo, lneIdInfo, regIdInfo,
        idInfoToAmode,
 
+        NonVoid(..), isVoidId, nonVoidIds,
+
        addBindC, addBindsC,
 
        bindArgsToRegs, bindToReg, rebindToReg,
@@ -25,6 +27,7 @@ module StgCmmEnv (
 
 #include "HsVersions.h"
 
+import TyCon
 import StgCmmMonad
 import StgCmmUtils
 import StgCmmClosure
@@ -32,18 +35,34 @@ import StgCmmClosure
 import CLabel
 
 import BlockId
-import Cmm
+import CmmExpr
 import CmmUtils
+import MkGraph (CmmAGraph, mkAssign, (<*>))
 import FastString
-import PprCmm          ( {- instance Outputable -} )
 import Id
 import VarEnv
-import Maybes
+import Control.Monad
 import Name
 import StgSyn
 import Outputable
 
+-------------------------------------
+--     Non-void types
+-------------------------------------
+-- We frequently need the invariant that an Id or a an argument
+-- is of a non-void type. This type is a witness to the invariant.
+
+newtype NonVoid a = NonVoid a
+  deriving (Eq, Show)
 
+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))]
 
 -------------------------------------
 --     Manipulating CgIdInfo
@@ -65,15 +84,23 @@ lneIdInfo id regs
     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))
+litIdInfo id lf_info lit = --mkCgIdInfo id lf_info (CmmLit lit)
+  mkCgIdInfo id lf_info (addDynTag (CmmLit lit) (lfDynTag lf_info))
+
+-- Because the register may be spilled to the stack in untagged form, we
+-- modify the initialization code 'init' to immediately tag the
+-- register, and store a plain register in the CgIdInfo.  We allocate
+-- a new register in order to keep single-assignment and help out the
+-- inliner. -- EZY
+regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CmmAGraph -> FCode (CgIdInfo, CmmAGraph)
+regIdInfo id lf_info reg init = do
+  reg' <- newTemp (localRegType reg)
+  let init' = init <*> mkAssign (CmmLocal reg') (addDynTag (CmmReg (CmmLocal reg)) (lfDynTag lf_info))
+  return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg')), init')
 
 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
 
@@ -105,10 +132,10 @@ addBindC name stuff_to_bind = do
        binds <- getBinds
        setBinds $ extendVarEnv binds name 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)
+       let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info)
                              binds
                              new_bindings
        setBinds new_binds
@@ -155,10 +182,11 @@ cgLookupPanic id
 
 
 --------------------
-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))  =
+  do { info  <- getCgIdInfo var; return (idInfoToAmode info) }
+getArgAmode (NonVoid (StgLitArg lit))  = liftM CmmLit $ cgLit lit
+getArgAmode (NonVoid (StgTypeArg _))   = panic "getArgAmode: type arg"
 
 getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
 -- NB: Filters out void args, 
@@ -166,7 +194,7 @@ getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
 getNonVoidArgAmodes [] = return []
 getNonVoidArgAmodes (arg:args)
   | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
-  | otherwise = do { amode  <- getArgAmode  arg 
+  | otherwise = do { amode  <- getArgAmode (NonVoid arg)
                   ; amodes <- getNonVoidArgAmodes args
                   ; return ( amode : amodes ) }
 
@@ -175,27 +203,27 @@ getNonVoidArgAmodes (arg:args)
 --     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)
+bindToReg nvid@(NonVoid id) lf_info
+  = do { let reg = idToReg nvid
+       ; addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
        ; return reg }
 
-rebindToReg :: Id -> FCode LocalReg
+rebindToReg :: NonVoid Id -> FCode LocalReg
 -- Like bindToReg, but the Id is already in scope, so 
 -- get its LF info from the envt
-rebindToReg id 
+rebindToReg nvid@(NonVoid id)
   = do { info <- getCgIdInfo id
-       ; bindToReg id (cgIdInfoLF info) }
+       ; bindToReg nvid (cgIdInfoLF 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 :: NonVoid Id -> LocalReg
 -- Make a register from an Id, typically a function argument,
 -- free variable, or case binder
 --
@@ -203,7 +231,8 @@ idToReg :: Id -> LocalReg
 --
 -- By now the Ids should be uniquely named; else one would worry
 -- about accidental collision 
-idToReg id = LocalReg (idUnique id) 
-                     (primRepCmmType (idPrimRep id))
+idToReg (NonVoid id) = LocalReg (idUnique id) 
+                        (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
+                                              _ -> primRepCmmType (idPrimRep id))