cgLit,
emitDataLits, emitRODataLits, 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
) where
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]
emitRtsCallWithVols fun args vols
= emitRtsCall' [] fun args (Just vols)
-emitRtsCallWithResult :: CmmReg -> MachHint -> LitString
+emitRtsCallWithResult :: LocalReg -> MachHint -> LitString
-> [(CmmExpr,MachHint)] -> Code
emitRtsCallWithResult res hint fun args
= emitRtsCall' [(res,hint)] fun args Nothing
-- Make a call to an RTS C procedure
emitRtsCall'
- :: [(CmmReg,MachHint)]
+ :: CmmHintFormals
-> LitString
-> [(CmmExpr,MachHint)]
-> Maybe [GlobalReg]
-> Code
-emitRtsCall' res fun args vols = stmtC (CmmCall target res args vols)
+emitRtsCall' res fun args vols = do
+ stmtsC caller_save
+ stmtC (CmmCall target res args)
+ stmtsC caller_load
where
+ (caller_save, caller_load) = callerSaveVolatileRegs vols
target = CmmForeignCall fun_expr CCallConv
fun_expr = mkLblExpr (mkRtsCodeLabel fun)
--
-------------------------------------------------------------------------
-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
projects / ghc-hetmet.git / blobdiff