tagToClosure, mkTaggedObjectLoad,
- callerSaveVolatileRegs, get_GlobalReg_addr,
+ callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
cmmUGtWord,
) where
#include "HsVersions.h"
-#include "MachRegs.h"
+#include "../includes/stg/MachRegs.h"
import StgCmmMonad
import StgCmmClosure
import BlockId
-import Cmm
-import CmmExpr
-import MkZipCfgCmm
-import ZipCfg hiding (last, unzip, zip)
+import CmmDecl
+import CmmExpr hiding (regUsedIn)
+import MkGraph
import CLabel
import CmmUtils
-import PprCmm ( {- instances -} )
import ForeignCall
import IdInfo
import Constants
import SMRep
import StgSyn ( SRT(..) )
+import Module
import Literal
import Digraph
import ListSetOps
mkSimpleLit (MachWord64 i) = CmmInt i W64
mkSimpleLit (MachFloat r) = CmmFloat r W32
mkSimpleLit (MachDouble r) = CmmFloat r W64
-mkSimpleLit (MachLabel fs ms) = CmmLabel (mkForeignLabel fs ms is_dyn)
- where
- is_dyn = False -- ToDo: fix me
+mkSimpleLit (MachLabel fs ms fod)
+ = CmmLabel (mkForeignLabel fs ms labelSrc fod)
+ where
+ -- TODO: Literal labels might not actually be in the current package...
+ labelSrc = ForeignLabelInThisPackage
mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other)
mkLtOp :: Literal -> MachOp
--
-------------------------------------------------------------------------
-emitRtsCall :: LitString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
-emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
+emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
+emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe
-- The 'Nothing' says "save all global registers"
-emitRtsCallWithVols :: LitString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode ()
-emitRtsCallWithVols fun args vols safe
- = emitRtsCall' [] fun args (Just vols) safe
+emitRtsCallWithVols :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode ()
+emitRtsCallWithVols pkg fun args vols safe
+ = emitRtsCall' [] pkg fun args (Just vols) safe
-emitRtsCallWithResult :: LocalReg -> ForeignHint -> LitString
+emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString
-> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
-emitRtsCallWithResult res hint fun args safe
- = emitRtsCall' [(res,hint)] fun args Nothing safe
+emitRtsCallWithResult res hint pkg fun args safe
+ = emitRtsCall' [(res,hint)] pkg fun args Nothing safe
-- Make a call to an RTS C procedure
emitRtsCall'
:: [(LocalReg,ForeignHint)]
- -> LitString
+ -> PackageId
+ -> FastString
-> [(CmmExpr,ForeignHint)]
-> Maybe [GlobalReg]
-> Bool -- True <=> CmmSafe call
-> FCode ()
-emitRtsCall' res fun args _vols safe
+emitRtsCall' res pkg fun args _vols safe
= --error "emitRtsCall'"
do { updfr_off <- getUpdFrameOff
; emit caller_save
where
call updfr_off =
if safe then
- mkCall fun_expr Native res' args' updfr_off
+ mkCmmCall fun_expr res' args' updfr_off
else
mkUnsafeCall (ForeignTarget fun_expr
(ForeignConvention CCallConv arg_hints res_hints)) res' args'
(args', arg_hints) = unzip args
(res', res_hints) = unzip res
(caller_save, caller_load) = callerSaveVolatileRegs
- fun_expr = mkLblExpr (mkRtsCodeLabel fun)
+ fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
-----------------------------------------------------------------------------
newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
-- Choose suitable local regs to use for the components
-- of an unboxed tuple that we are about to return to
--- the Sequel. If the Sequel is a joint point, using the
+-- the Sequel. If the Sequel is a join point, using the
-- regs it wants will save later assignments.
newUnboxedTupleRegs res_ty
= ASSERT( isUnboxedTupleType res_ty )
reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
_reg `regUsedIn` _other = False -- The CmmGlobal cases
-
-------------------------------------------------------------------------
-- mkSwitch
-------------------------------------------------------------------------
mk_switch tag_expr' (sortLe le branches) mb_deflt
lo_tag hi_tag via_C
-- Sort the branches before calling mk_switch
- <*> mkLabel join_lbl emptyStackInfo
+ <*> mkLabel join_lbl
where
(t1,_) `le` (t2,_) = t1 <= t2
label_code join_lbl deflt $ \ deflt ->
label_branches join_lbl branches $ \ branches ->
mk_lit_switch scrut' deflt (sortLe le branches)
- <*> mkLabel join_lbl emptyStackInfo
+ <*> mkLabel join_lbl
where
le (t1,_) (t2,_) = t1 <= t2
-- [L: code; goto J] fun L
label_code join_lbl code thing_inside
= withFreshLabel "switch" $ \lbl ->
- outOfLine (mkLabel lbl emptyStackInfo <*> code <*> mkBranch join_lbl)
+ outOfLine (mkLabel lbl <*> code <*> mkBranch join_lbl)
<*> thing_inside lbl