--
-----------------------------------------------------------------------------
+{-# 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 CgUtils (
addIdReps,
cgLit,
- emitDataLits, emitRODataLits, emitIf, emitIfThenElse,
+ emitDataLits, mkDataLits,
+ emitRODataLits, mkRODataLits,
+ emitIf, emitIfThenElse,
emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
- assignTemp, newTemp,
+ assignNonPtrTemp, newNonPtrTemp,
+ assignPtrTemp, newPtrTemp,
emitSimultaneously,
emitSwitch, emitLitSwitch,
tagToClosure,
+ callerSaveVolatileRegs, get_GlobalReg_addr,
+
cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
- cmmULtWord, cmmUGtWord,
- cmmULeWord, cmmUGeWord,
+ cmmUGtWord,
cmmOffsetExprW, cmmOffsetExprB,
cmmRegOffW, cmmRegOffB,
cmmLabelOffW, cmmLabelOffB,
cmmOffsetW, cmmOffsetB,
cmmOffsetLitW, cmmOffsetLitB,
cmmLoadIndexW,
+ cmmConstrTag, cmmConstrTag1,
+
+ tagForCon, tagCons, isSmallFamily,
+ cmmUntag, cmmIsTagged, cmmGetTag,
addToMem, addToMemE,
mkWordCLit,
- mkStringCLit,
+ mkStringCLit, mkByteStringCLit,
packHalfWordsCLit,
- blankWord
+ blankWord,
+
+ getSRTInfo
) where
#include "HsVersions.h"
+#include "MachRegs.h"
import CgMonad
import TyCon
+import DataCon
import Id
import Constants
import SMRep
import CmmUtils
import MachOp
import ForeignCall
+import ClosureInfo
+import StgSyn (SRT(..))
import Literal
import Digraph
import ListSetOps
import DynFlags
import FastString
import PackageConfig
+#ifdef DEBUG
import Outputable
+#endif
import Data.Char
import Data.Bits
cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
cmmNeWord e1 e2 = CmmMachOp mo_wordNe [e1, e2]
cmmEqWord e1 e2 = CmmMachOp mo_wordEq [e1, e2]
-cmmULeWord e1 e2 = CmmMachOp mo_wordULe [e1, e2]
cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
+--cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
+--cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
+cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
cmmNegate :: CmmExpr -> CmmExpr
cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
blankWord :: CmmStatic
blankWord = CmmUninitialised wORD_SIZE
+-- Tagging --
+-- Tag bits mask
+--cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
+cmmTagMask = CmmLit (mkIntCLit tAG_MASK)
+cmmPointerMask = CmmLit (mkIntCLit (complement tAG_MASK))
+
+-- Used to untag a possibly tagged pointer
+-- A static label need not be untagged
+cmmUntag e@(CmmLit (CmmLabel _)) = e
+-- Default case
+cmmUntag e = (e `cmmAndWord` cmmPointerMask)
+
+cmmGetTag e = (e `cmmAndWord` cmmTagMask)
+
+-- Test if a closure pointer is untagged
+cmmIsTagged e = (e `cmmAndWord` cmmTagMask)
+ `cmmNeWord` CmmLit zeroCLit
+
+cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` (CmmLit (mkIntCLit 1))
+-- Get constructor tag, but one based.
+cmmConstrTag1 e = e `cmmAndWord` cmmTagMask
+
+{-
+ The family size of a data type (the number of constructors)
+ can be either:
+ * small, if the family size < 2**tag_bits
+ * big, otherwise.
+
+ Small families can have the constructor tag in the tag
+ bits.
+ Big families only use the tag value 1 to represent
+ evaluatedness.
+-}
+isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
+
+tagForCon con = tag
+ where
+ con_tag = dataConTagZ con
+ fam_size = tyConFamilySize (dataConTyCon con)
+ tag | isSmallFamily fam_size = con_tag + 1
+ | otherwise = 1
+
+--Tag an expression, to do: refactor, this appears in some other module.
+tagCons con expr = cmmOffsetB expr (tagForCon con)
+
+-- Copied from CgInfoTbls.hs
+-- We keep the *zero-indexed* tag in the srt_len field of the info
+-- table of a data constructor.
+dataConTagZ :: DataCon -> ConTagZ
+dataConTagZ con = dataConTag con - fIRST_TAG
+
-----------------------
-- Making literals
--
-------------------------------------------------------------------------
-tagToClosure :: PackageId -> TyCon -> CmmExpr -> CmmExpr
-tagToClosure this_pkg tycon tag
+tagToClosure :: TyCon -> CmmExpr -> CmmExpr
+tagToClosure tycon tag
= CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep
where closure_tbl = CmmLit (CmmLabel lbl)
- lbl = mkClosureTableLabel this_pkg (tyConName tycon)
+ lbl = mkClosureTableLabel (tyConName tycon)
-------------------------------------------------------------------------
--
; labelC join_id
}
-emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Code
-emitRtsCall fun args = emitRtsCall' [] fun args Nothing
+emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Bool -> Code
+emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
-- The 'Nothing' says "save all global registers"
-emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Code
-emitRtsCallWithVols fun args vols
- = emitRtsCall' [] fun args (Just vols)
+emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Bool -> Code
+emitRtsCallWithVols fun args vols safe
+ = emitRtsCall' [] fun args (Just vols) safe
-emitRtsCallWithResult :: CmmReg -> MachHint -> LitString
- -> [(CmmExpr,MachHint)] -> Code
-emitRtsCallWithResult res hint fun args
- = emitRtsCall' [(res,hint)] fun args Nothing
+emitRtsCallWithResult :: LocalReg -> MachHint -> LitString
+ -> [(CmmExpr,MachHint)] -> Bool -> Code
+emitRtsCallWithResult res hint fun args safe
+ = emitRtsCall' [(res,hint)] fun args Nothing safe
-- Make a call to an RTS C procedure
emitRtsCall'
- :: [(CmmReg,MachHint)]
+ :: CmmHintFormals
-> LitString
-> [(CmmExpr,MachHint)]
-> Maybe [GlobalReg]
+ -> Bool -- True <=> CmmSafe call
-> Code
-emitRtsCall' res fun args vols = stmtC (CmmCall target res args vols)
+emitRtsCall' res fun args vols safe = do
+ safety <- if safe
+ then getSRTInfo >>= (return . CmmSafe)
+ else return CmmUnsafe
+ stmtsC caller_save
+ stmtC (CmmCall target res args safety CmmMayReturn)
+ stmtsC caller_load
where
- target = CmmForeignCall fun_expr CCallConv
+ (caller_save, caller_load) = callerSaveVolatileRegs vols
+ target = CmmCallee fun_expr CCallConv
fun_expr = mkLblExpr (mkRtsCodeLabel fun)
+-----------------------------------------------------------------------------
+--
+-- Caller-Save Registers
+--
+-----------------------------------------------------------------------------
+
+-- Here we generate the sequence of saves/restores required around a
+-- foreign call instruction.
+
+-- TODO: reconcile with includes/Regs.h
+-- * Regs.h claims that BaseReg should be saved last and loaded first
+-- * This might not have been tickled before since BaseReg is callee save
+-- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
+callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt])
+callerSaveVolatileRegs vols = (caller_save, caller_load)
+ where
+ caller_save = foldr ($!) [] (map callerSaveGlobalReg regs_to_save)
+ caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save)
+
+ system_regs = [Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery,
+ {-SparkHd,SparkTl,SparkBase,SparkLim,-}BaseReg ]
+
+ regs_to_save = system_regs ++ vol_list
+
+ vol_list = case vols of Nothing -> all_of_em; Just regs -> regs
+
+ all_of_em = [ VanillaReg n | n <- [0..mAX_Vanilla_REG] ]
+ ++ [ FloatReg n | n <- [0..mAX_Float_REG] ]
+ ++ [ DoubleReg n | n <- [0..mAX_Double_REG] ]
+ ++ [ LongReg n | n <- [0..mAX_Long_REG] ]
+
+ callerSaveGlobalReg reg next
+ | callerSaves reg =
+ CmmStore (get_GlobalReg_addr reg)
+ (CmmReg (CmmGlobal reg)) : next
+ | otherwise = next
+
+ callerRestoreGlobalReg reg next
+ | callerSaves reg =
+ CmmAssign (CmmGlobal reg)
+ (CmmLoad (get_GlobalReg_addr reg) (globalRegRep reg))
+ : next
+ | otherwise = next
+
+-- -----------------------------------------------------------------------------
+-- Global registers
+
+-- We map STG registers onto appropriate CmmExprs. Either they map
+-- to real machine registers or stored as offsets from BaseReg. Given
+-- a GlobalReg, get_GlobalReg_addr always produces the
+-- register table address for it.
+-- (See also get_GlobalReg_reg_or_addr in MachRegs)
+
+get_GlobalReg_addr :: GlobalReg -> CmmExpr
+get_GlobalReg_addr BaseReg = regTableOffset 0
+get_GlobalReg_addr mid = get_Regtable_addr_from_offset
+ (globalRegRep mid) (baseRegOffset mid)
+
+-- Calculate a literal representing an offset into the register table.
+-- Used when we don't have an actual BaseReg to offset from.
+regTableOffset n =
+ CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
+
+get_Regtable_addr_from_offset :: MachRep -> Int -> CmmExpr
+get_Regtable_addr_from_offset rep offset =
+#ifdef REG_Base
+ CmmRegOff (CmmGlobal BaseReg) offset
+#else
+ regTableOffset offset
+#endif
+
+
+-- | Returns 'True' if this global register is stored in a caller-saves
+-- machine register.
+
+callerSaves :: GlobalReg -> Bool
+
+#ifdef CALLER_SAVES_Base
+callerSaves BaseReg = True
+#endif
+#ifdef CALLER_SAVES_R1
+callerSaves (VanillaReg 1) = True
+#endif
+#ifdef CALLER_SAVES_R2
+callerSaves (VanillaReg 2) = True
+#endif
+#ifdef CALLER_SAVES_R3
+callerSaves (VanillaReg 3) = True
+#endif
+#ifdef CALLER_SAVES_R4
+callerSaves (VanillaReg 4) = True
+#endif
+#ifdef CALLER_SAVES_R5
+callerSaves (VanillaReg 5) = True
+#endif
+#ifdef CALLER_SAVES_R6
+callerSaves (VanillaReg 6) = True
+#endif
+#ifdef CALLER_SAVES_R7
+callerSaves (VanillaReg 7) = True
+#endif
+#ifdef CALLER_SAVES_R8
+callerSaves (VanillaReg 8) = True
+#endif
+#ifdef CALLER_SAVES_F1
+callerSaves (FloatReg 1) = True
+#endif
+#ifdef CALLER_SAVES_F2
+callerSaves (FloatReg 2) = True
+#endif
+#ifdef CALLER_SAVES_F3
+callerSaves (FloatReg 3) = True
+#endif
+#ifdef CALLER_SAVES_F4
+callerSaves (FloatReg 4) = True
+#endif
+#ifdef CALLER_SAVES_D1
+callerSaves (DoubleReg 1) = True
+#endif
+#ifdef CALLER_SAVES_D2
+callerSaves (DoubleReg 2) = True
+#endif
+#ifdef CALLER_SAVES_L1
+callerSaves (LongReg 1) = True
+#endif
+#ifdef CALLER_SAVES_Sp
+callerSaves Sp = True
+#endif
+#ifdef CALLER_SAVES_SpLim
+callerSaves SpLim = True
+#endif
+#ifdef CALLER_SAVES_Hp
+callerSaves Hp = True
+#endif
+#ifdef CALLER_SAVES_HpLim
+callerSaves HpLim = True
+#endif
+#ifdef CALLER_SAVES_CurrentTSO
+callerSaves CurrentTSO = True
+#endif
+#ifdef CALLER_SAVES_CurrentNursery
+callerSaves CurrentNursery = True
+#endif
+callerSaves _ = False
+
+
+-- -----------------------------------------------------------------------------
+-- Information about global registers
+
+baseRegOffset :: GlobalReg -> Int
+
+baseRegOffset (VanillaReg 1) = oFFSET_StgRegTable_rR1
+baseRegOffset (VanillaReg 2) = oFFSET_StgRegTable_rR2
+baseRegOffset (VanillaReg 3) = oFFSET_StgRegTable_rR3
+baseRegOffset (VanillaReg 4) = oFFSET_StgRegTable_rR4
+baseRegOffset (VanillaReg 5) = oFFSET_StgRegTable_rR5
+baseRegOffset (VanillaReg 6) = oFFSET_StgRegTable_rR6
+baseRegOffset (VanillaReg 7) = oFFSET_StgRegTable_rR7
+baseRegOffset (VanillaReg 8) = oFFSET_StgRegTable_rR8
+baseRegOffset (VanillaReg 9) = oFFSET_StgRegTable_rR9
+baseRegOffset (VanillaReg 10) = oFFSET_StgRegTable_rR10
+baseRegOffset (FloatReg 1) = oFFSET_StgRegTable_rF1
+baseRegOffset (FloatReg 2) = oFFSET_StgRegTable_rF2
+baseRegOffset (FloatReg 3) = oFFSET_StgRegTable_rF3
+baseRegOffset (FloatReg 4) = oFFSET_StgRegTable_rF4
+baseRegOffset (DoubleReg 1) = oFFSET_StgRegTable_rD1
+baseRegOffset (DoubleReg 2) = oFFSET_StgRegTable_rD2
+baseRegOffset Sp = oFFSET_StgRegTable_rSp
+baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim
+baseRegOffset (LongReg 1) = oFFSET_StgRegTable_rL1
+baseRegOffset Hp = oFFSET_StgRegTable_rHp
+baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim
+baseRegOffset CurrentTSO = oFFSET_StgRegTable_rCurrentTSO
+baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery
+baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc
+baseRegOffset GCEnter1 = oFFSET_stgGCEnter1
+baseRegOffset GCFun = oFFSET_stgGCFun
+#ifdef DEBUG
+baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
+baseRegOffset _ = panic "baseRegOffset:other"
+#endif
+
-------------------------------------------------------------------------
--
--- Strings gnerate a top-level data block
+-- Strings generate a top-level data block
--
-------------------------------------------------------------------------
emitDataLits lbl lits
= emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
+mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
+-- Emit a data-segment data block
+mkDataLits lbl lits
+ = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
+
emitRODataLits :: CLabel -> [CmmLit] -> Code
-- Emit a read-only data block
emitRODataLits lbl lits
needsRelocation (CmmLabelOff _ _) = True
needsRelocation _ = False
+mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
+mkRODataLits lbl lits
+ = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
+ where section | any needsRelocation lits = RelocatableReadOnlyData
+ | otherwise = ReadOnlyData
+ needsRelocation (CmmLabel _) = True
+ needsRelocation (CmmLabelOff _ _) = True
+ needsRelocation _ = False
+
mkStringCLit :: String -> FCode CmmLit
-- Make a global definition for the string,
-- and return its label
--
-------------------------------------------------------------------------
-assignTemp :: CmmExpr -> FCode CmmExpr
+assignNonPtrTemp :: CmmExpr -> FCode CmmExpr
+-- For a non-trivial expression, e, create a local
+-- variable and assign the expression to it
+assignNonPtrTemp e
+ | isTrivialCmmExpr e = return e
+ | otherwise = do { reg <- newNonPtrTemp (cmmExprRep e)
+ ; stmtC (CmmAssign (CmmLocal reg) e)
+ ; return (CmmReg (CmmLocal reg)) }
+
+assignPtrTemp :: CmmExpr -> FCode CmmExpr
-- For a non-trivial expression, e, create a local
-- variable and assign the expression to it
-assignTemp e
+assignPtrTemp e
| isTrivialCmmExpr e = return e
- | otherwise = do { reg <- newTemp (cmmExprRep e)
- ; stmtC (CmmAssign reg e)
- ; return (CmmReg reg) }
+ | otherwise = do { reg <- newPtrTemp (cmmExprRep e)
+ ; stmtC (CmmAssign (CmmLocal reg) e)
+ ; return (CmmReg (CmmLocal reg)) }
+newNonPtrTemp :: MachRep -> FCode LocalReg
+newNonPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindNonPtr) }
-newTemp :: MachRep -> FCode CmmReg
-newTemp rep = do { uniq <- newUnique; return (CmmLocal (LocalReg uniq rep)) }
+newPtrTemp :: MachRep -> FCode LocalReg
+newPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindPtr) }
-------------------------------------------------------------------------
-- if we can knock off a bunch of default cases with one if, then do so
| Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
- = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
+ = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
branch = CmmCondBranch cond deflt
; stmts <- mk_switch tag_expr' branches mb_deflt
}
| Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
- = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
+ = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
branch = CmmCondBranch cond deflt
; stmts <- mk_switch tag_expr' branches mb_deflt
}
| otherwise -- Use an if-tree
- = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
+ = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
-- To avoid duplication
; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
lo_tag (mid_tag-1) via_C
is_lo (t,_) = t < mid_tag
-assignTemp' e
+assignNonPtrTemp' e
| isTrivialCmmExpr e = return (CmmNop, e)
- | otherwise = do { reg <- newTemp (cmmExprRep e)
- ; return (CmmAssign reg e, CmmReg reg) }
-
+ | otherwise = do { reg <- newNonPtrTemp (cmmExprRep e)
+ ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
emitLitSwitch :: CmmExpr -- Tag to switch on
-> [(Literal, CgStmts)] -- Tagged branches
emitLitSwitch scrut [] deflt
= emitCgStmts deflt
emitLitSwitch scrut branches deflt_blk
- = do { scrut' <- assignTemp scrut
+ = do { scrut' <- assignNonPtrTemp scrut
; deflt_blk_id <- forkCgStmts deflt_blk
; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
; emitCgStmts blk }
; stmtC from_temp }
go_via_temp (CmmAssign dest src)
- = do { tmp <- newTemp (cmmRegRep dest)
- ; stmtC (CmmAssign tmp src)
- ; return (CmmAssign dest (CmmReg tmp)) }
+ = do { tmp <- newNonPtrTemp (cmmRegRep dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
+ ; stmtC (CmmAssign (CmmLocal tmp) src)
+ ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) }
go_via_temp (CmmStore dest src)
- = do { tmp <- newTemp (cmmExprRep src)
- ; stmtC (CmmAssign tmp src)
- ; return (CmmStore dest (CmmReg tmp)) }
+ = do { tmp <- newNonPtrTemp (cmmExprRep src) -- TODO FIXME NOW if the pair of assignemnts move across a call this will be wrong
+ ; stmtC (CmmAssign (CmmLocal tmp) src)
+ ; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
in
mapCs do_component components
possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
possiblySameLoc l1 rep1 l2 rep2 = True -- Conservative
+
+-------------------------------------------------------------------------
+--
+-- Static Reference Tables
+--
+-------------------------------------------------------------------------
+
+-- There is just one SRT for each top level binding; all the nested
+-- bindings use sub-sections of this SRT. The label is passed down to
+-- the nested bindings via the monad.
+
+getSRTInfo :: FCode C_SRT
+getSRTInfo = do
+ srt_lbl <- getSRTLabel
+ srt <- getSRT
+ case srt of
+ -- TODO: Should we panic in this case?
+ -- Someone obviously thinks there should be an SRT
+ NoSRT -> return NoC_SRT
+ SRT off len bmp
+ | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
+ -> do id <- newUnique
+ let srt_desc_lbl = mkLargeSRTLabel id
+ emitRODataLits srt_desc_lbl
+ ( cmmLabelOffW srt_lbl off
+ : mkWordCLit (fromIntegral len)
+ : map mkWordCLit bmp)
+ return (C_SRT srt_desc_lbl 0 srt_escape)
+
+ SRT off len bmp
+ | otherwise
+ -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
+ -- The fromIntegral converts to StgHalfWord
+
+srt_escape = (-1) :: StgHalfWord
projects / ghc-hetmet.git / blobdiff