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,
cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
- cmmULtWord, cmmUGtWord,
- cmmULeWord, cmmUGeWord,
cmmOffsetExprW, cmmOffsetExprB,
cmmRegOffW, cmmRegOffB,
cmmLabelOffW, cmmLabelOffB,
addToMem, addToMemE,
mkWordCLit,
- mkStringCLit,
+ mkStringCLit, mkByteStringCLit,
packHalfWordsCLit,
- blankWord
+ blankWord,
+
+ getSRTInfo
) where
#include "HsVersions.h"
import CmmUtils
import MachOp
import ForeignCall
+import ClosureInfo
+import StgSyn (SRT(..))
import Literal
import Digraph
import ListSetOps
import PackageConfig
import Outputable
+import MachRegs (callerSaveVolatileRegs)
+ -- HACK: this is part of the NCG so we shouldn't use this, but we need
+ -- it for now to eliminate the need for saved regs to be in CmmCall.
+ -- The long term solution is to factor callerSaveVolatileRegs
+ -- from nativeGen into codeGen
+
import Data.Char
import Data.Bits
import Data.Word
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]
; 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)
+ stmtsC caller_load
where
+ (caller_save, caller_load) = callerSaveVolatileRegs vols
target = CmmForeignCall fun_expr CCallConv
fun_expr = mkLblExpr (mkRtsCodeLabel fun)
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
-assignTemp e
+assignNonPtrTemp e
| isTrivialCmmExpr e = return e
- | otherwise = do { reg <- newTemp (cmmExprRep e)
- ; stmtC (CmmAssign reg e)
- ; return (CmmReg reg) }
+ | 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
+assignPtrTemp e
+ | isTrivialCmmExpr e = return e
+ | 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