litIdInfo, lneIdInfo, regIdInfo,
idInfoToAmode,
+ NonVoid(..), isVoidId, nonVoidIds,
+
addBindC, addBindsC,
bindArgsToRegs, bindToReg, rebindToReg,
#include "HsVersions.h"
+import TyCon
import StgCmmMonad
import StgCmmUtils
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
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
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
--------------------
-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,
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 ) }
-- 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
--
--
-- 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))