nonemptyAbsC, mkAbsCStmts
)
import PprAbsC ( dumpRealC )
-import SMRep ( fixedItblSize,
- rET_SMALL, rET_BIG,
- rET_VEC_SMALL, rET_VEC_BIG
- )
-import Constants ( mIN_UPD_SIZE )
+import SMRep ( retItblSize )
import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
mkClosureTblLabel, mkClosureLabel,
labelDynamic, mkSplitMarkerLabel )
-import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
- fastLabelFromCI, closureUpdReqd,
- staticClosureNeedsLink
- )
+import ClosureInfo
import Literal ( Literal(..), word2IntLit )
-import Maybes ( maybeToBool )
import StgSyn ( StgOp(..) )
-import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
-import PrimRep ( isFloatingRep, PrimRep(..) )
-import StixInfo ( genCodeInfoTable, genBitmapInfoTable,
- livenessIsSmall, bitmapToIntegers )
+import MachOp ( MachOp(..), resultRepOfMachOp )
+import PrimRep ( isFloatingRep, is64BitRep,
+ PrimRep(..), getPrimRepSizeInBytes )
import StixMacro ( macroCode, checkCode )
-import StixPrim ( primCode, foreignCallCode, amodeToStix, amodeToStix' )
+import StixPrim ( foreignCallCode, amodeToStix, amodeToStix' )
import Outputable ( pprPanic, ppr )
import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
import Util ( naturalMergeSortLe )
import Panic ( panic )
import TyCon ( tyConDataCons )
+import Constants ( wORD_SIZE, bITMAP_BITS_SHIFT )
import DataCon ( dataConWrapId )
import Name ( NamedThing(..) )
import CmdLineOpts ( opt_Static, opt_EnsureSplittableC )
import Outputable ( assertPanic )
+import BitSet ( BitSet, intBS )
+
+-- DEBUGGING ONLY
+--import TRACE ( trace )
+--import Outputable ( showSDoc )
+--import MachOp ( pprMachOp )
+
+#include "nativeGen/NCG.h"
\end{code}
For each independent chunk of AbstractC code, we generate a list of
performed locally within the chunk.
\begin{code}
-genCodeAbstractC :: AbstractC -> UniqSM [StixTree]
+genCodeAbstractC :: AbstractC -> UniqSM [StixStmt]
genCodeAbstractC absC
= gentopcode absC
a2stix' = amodeToStix'
volsaves = volatileSaves
volrestores = volatileRestores
- p2stix = primCode
macro_code = macroCode
-- real code follows... ---------
\end{code}
= gencode absC `thenUs` \ code ->
returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl])
- gentopcode stmt@(CStaticClosure lbl _ _ _)
+ gentopcode stmt@(CStaticClosure lbl closure_info _ _)
= genCodeStaticClosure stmt `thenUs` \ code ->
returnUs (
if opt_Static
: StLabel lbl : code []
)
- gentopcode stmt@(CRetVector lbl _ _ _)
- = genCodeVecTbl stmt `thenUs` \ code ->
- returnUs (StSegment TextSegment : code [StLabel lbl])
+ gentopcode stmt@(CRetVector lbl amodes srt liveness)
+ = returnUs ( StSegment TextSegment
+ : StData PtrRep table
+ : StLabel lbl
+ : []
+ )
+ where
+ table = map amodeToStix (mkVecInfoTable amodes srt liveness)
gentopcode stmt@(CRetDirect uniq absC srt liveness)
= gencode absC `thenUs` \ code ->
- genBitmapInfoTable liveness srt closure_type False `thenUs` \ itbl ->
- returnUs (StSegment TextSegment :
- itbl (StLabel lbl_info : StLabel lbl_ret : code []))
+ returnUs ( StSegment TextSegment
+ : StData PtrRep table
+ : StLabel info_lbl
+ : StLabel ret_lbl
+ : code [])
where
- lbl_info = mkReturnInfoLabel uniq
- lbl_ret = mkReturnPtLabel uniq
- closure_type = if livenessIsSmall liveness then rET_SMALL else rET_BIG
-
- gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _)
-
- | slow_is_empty
- = genCodeInfoTable stmt `thenUs` \ itbl ->
- returnUs (StSegment TextSegment : itbl [])
-
- | otherwise
- = genCodeInfoTable stmt `thenUs` \ itbl ->
- gencode slow `thenUs` \ slow_code ->
- returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
- slow_code [StFunEnd slow_lbl]))
- where
- slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
- slow_lbl = entryLabelFromCI cl_info
-
- gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _) =
- -- ToDo: what if this is empty? ------------------------^^^^
- genCodeInfoTable stmt `thenUs` \ itbl ->
- gencode slow `thenUs` \ slow_code ->
- gencode fast `thenUs` \ fast_code ->
- returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
- slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
- fast_code [StFunEnd fast_lbl])))
+ info_lbl = mkReturnInfoLabel uniq
+ ret_lbl = mkReturnPtLabel uniq
+ table = map amodeToStix (mkRetInfoTable ret_lbl srt liveness)
+
+ gentopcode stmt@(CClosureInfoAndCode cl_info entry)
+ = gencode entry `thenUs` \ slow_code ->
+ returnUs ( StSegment TextSegment
+ : StData PtrRep table
+ : StLabel info_lbl
+ : StFunBegin entry_lbl
+ : slow_code [StFunEnd entry_lbl])
where
- slow_lbl = entryLabelFromCI cl_info
- fast_lbl = fastLabelFromCI cl_info
+ entry_lbl = entryLabelFromCI cl_info
+ info_lbl = infoTableLabelFromCI cl_info
+ table = map amodeToStix (mkInfoTable cl_info)
gentopcode stmt@(CSRT lbl closures)
= returnUs [ StSegment TextSegment
, StData DataPtrRep (map mk_StCLbl_for_SRT closures)
]
where
- mk_StCLbl_for_SRT :: CLabel -> StixTree
+ mk_StCLbl_for_SRT :: CLabel -> StixExpr
mk_StCLbl_for_SRT label
| labelDynamic label
= StIndex Int8Rep (StCLbl label) (StInt 1)
| otherwise
= StCLbl label
- gentopcode stmt@(CBitmap lbl mask)
- = returnUs $ case bitmapToIntegers mask of
- mask'@(_:_:_) ->
- [ StSegment TextSegment
- , StLabel lbl
- , StData WordRep (map StInt (toInteger (length mask') : mask'))
- ]
- _ -> []
+ gentopcode stmt@(CBitmap l@(Liveness lbl size mask))
+ | isBigLiveness l
+ = returnUs
+ [ StSegment TextSegment
+ , StLabel lbl
+ , StData WordRep (map StInt (toInteger size : bitmapToIntegers mask))
+ ]
+ | otherwise
+ = returnUs []
+ where
+ -- ToDo: translate out bitmaps earlier, like info tables
+ isBigLiveness (Liveness _ size _) = size > mAX_SMALL_BITMAP_SIZE
+ mAX_SMALL_BITMAP_SIZE = (wORD_SIZE * 8) - bITMAP_BITS_SHIFT
gentopcode stmt@(CClosureTbl tycon)
= returnUs [ StSegment TextSegment
(tyConDataCons tycon) )
]
- gentopcode stmt@(CModuleInitBlock lbl absC)
+ gentopcode stmt@(CModuleInitBlock plain_lbl lbl absC)
= gencode absC `thenUs` \ code ->
getUniqLabelNCG `thenUs` \ tmp_lbl ->
getUniqLabelNCG `thenUs` \ flag_lbl ->
: StLabel flag_lbl
: StData IntRep [StInt 0]
: StSegment TextSegment
+ : StLabel plain_lbl
+ : StJump NoDestInfo (StCLbl lbl)
: StLabel lbl
- : StCondJump tmp_lbl (StPrim IntNeOp
+ : StCondJump tmp_lbl (StMachOp MO_Nat_Ne
[StInd IntRep (StCLbl flag_lbl),
StInt 0])
- : StAssign IntRep (StInd IntRep (StCLbl flag_lbl)) (StInt 1)
+ : StAssignMem IntRep (StCLbl flag_lbl) (StInt 1)
: code
[ StLabel tmp_lbl
- , StAssign PtrRep stgSp
- (StIndex PtrRep stgSp (StInt (-1)))
- , StJump NoDestInfo (StInd WordRep stgSp)
+ , StAssignReg PtrRep stgSp
+ (StIndex PtrRep (StReg stgSp) (StInt (-1)))
+ , StJump NoDestInfo (StInd WordRep (StReg stgSp))
])
gentopcode absC
\begin{code}
{-
- genCodeVecTbl
- :: AbstractC
- -> UniqSM StixTreeList
- -}
- genCodeVecTbl (CRetVector lbl amodes srt liveness)
- = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
- returnUs (\xs -> vectbl : itbl xs)
- where
- vectbl = StData PtrRep (reverse (map a2stix amodes))
- closure_type = if livenessIsSmall liveness then rET_VEC_SMALL else rET_VEC_BIG
-
-\end{code}
-
-\begin{code}
- {-
genCodeStaticClosure
:: AbstractC
-> UniqSM StixTreeList
-}
- genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
+ genCodeStaticClosure (CStaticClosure lbl cl_info cost_centre amodes)
= returnUs (\xs -> table ++ xs)
where
table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
- map do_one_amode amodes ++
- [StData PtrRep (padding_wds ++ static_link)]
+ foldr do_one_amode [] amodes
- do_one_amode amode
- = StData (promote_to_word (getAmodeRep amode)) [a2stix amode]
+ do_one_amode amode rest
+ | rep == VoidRep = rest
+ | otherwise = StData (promote_to_word rep) [a2stix amode] : rest
+ where
+ rep = getAmodeRep amode
-- We need to promote any item smaller than a word to a word
promote_to_word pk
- | sizeOf pk >= sizeOf IntRep = pk
- | otherwise = IntRep
-
- upd_reqd = closureUpdReqd cl_info
-
- padding_wds
- | upd_reqd = take (max 0 (mIN_UPD_SIZE - length amodes)) zeros
- | otherwise = []
-
- static_link | upd_reqd || staticClosureNeedsLink cl_info = [StInt 0]
- | otherwise = []
-
- zeros = StInt 0 : zeros
-
- {- needed??? --SDM
- -- Watch out for VoidKinds...cf. PprAbsC
- amodeZeroVoid item
- | getAmodeRep item == VoidRep = StInt 0
- | otherwise = a2stix item
- -}
-
+ | getPrimRepSizeInBytes pk >= getPrimRepSizeInBytes IntRep = pk
+ | otherwise = IntRep
\end{code}
Now the individual AbstractC statements.
gencode c2 `thenUs` \ b2 ->
returnUs (b1 . b2)
+ gencode (CSequential stuff)
+ = foo stuff
+ where
+ foo [] = returnUs id
+ foo (s:ss) = gencode s `thenUs` \ stix ->
+ foo ss `thenUs` \ stixes ->
+ returnUs (stix . stixes)
+
\end{code}
Initialising closure headers in the heap...a fairly complex ordeal if
\begin{code}
- gencode (CInitHdr cl_info reg_rel _)
+ gencode (CInitHdr cl_info reg_rel _ _)
= let
lhs = a2stix reg_rel
lbl = infoTableLabelFromCI cl_info
in
- returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs)
+ returnUs (\xs -> StAssignMem PtrRep lhs (StCLbl lbl) : xs)
\end{code}
\begin{code}
gencode (CAssign lhs rhs)
- | getAmodeRep lhs == VoidRep = returnUs id
+ | lhs_rep == VoidRep
+ = returnUs id
| otherwise
- = let pk = getAmodeRep lhs
- pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
+ = let -- This is a Hack. Should be cleaned up.
+ -- JRS, 10 Dec 01
+ pk' | ncg_target_is_32bit && is64BitRep lhs_rep
+ = lhs_rep
+ | otherwise
+ = if mixedTypeLocn lhs && not (isFloatingRep lhs_rep)
+ then IntRep
+ else lhs_rep
lhs' = a2stix lhs
rhs' = a2stix' rhs
in
- returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
+ returnUs (\xs -> mkStAssign pk' lhs' rhs' : xs)
+ where
+ lhs_rep = getAmodeRep lhs
\end{code}
= returnUs (\xs -> StJump NoDestInfo dest : xs)
where
dest = StInd PtrRep (StIndex PtrRep (a2stix table)
- (StInt (toInteger (-n-fixedItblSize-1))))
+ (StInt (toInteger (-n-retItblSize-1))))
gencode (CReturn table (DynamicVectoredReturn am))
= returnUs (\xs -> StJump NoDestInfo dest : xs)
where
dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
- dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
- StInt (toInteger (fixedItblSize+1))]
+ dyn_off = StMachOp MO_Nat_Sub [StMachOp MO_NatS_Neg [a2stix am],
+ StInt (toInteger (retItblSize+1))]
\end{code}
foreignCallCode (nonVoid results) fcall (nonVoid args)
gencode (COpStmt results (StgPrimOp op) args vols)
- -- ToDo (ADR?): use that liveness mask
- | primOpNeedsWrapper op
- = let
- saves = volsaves vols
- restores = volrestores vols
- in
- p2stix (nonVoid results) op (nonVoid args)
- `thenUs` \ code ->
- returnUs (\xs -> saves ++ code (restores ++ xs))
+ = panic "AbsCStixGen.gencode: un-translated PrimOp"
- | otherwise = p2stix (nonVoid results) op (nonVoid args)
+ gencode (CMachOpStmt res mop args vols)
+ = returnUs (\xs -> mkStAssign (resultRepOfMachOp mop) (a2stix res)
+ (StMachOp mop (map a2stix args))
+ : xs
+ )
\end{code}
Now the dreaded conditional jump.
gencode (CCallProfCCMacro macro _)
= returnUs (\xs -> StComment macro : xs)
+ gencode CCallTypedef{} = returnUs id
+
gencode other
= pprPanic "AbsCStixGen.gencode" (dumpRealC other)
mkJumpTable am alts lowTag highTag dflt
= getUniqLabelNCG `thenUs` \ utlbl ->
mapUs genLabel alts `thenUs` \ branches ->
- let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
- cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
+ let cjmpLo = StCondJump dflt (StMachOp MO_NatS_Lt [am, StInt (toInteger lowTag)])
+ cjmpHi = StCondJump dflt (StMachOp MO_NatS_Gt [am, StInt (toInteger highTag)])
- offset = StPrim IntSubOp [am, StInt lowTag]
+ offset = StMachOp MO_Nat_Sub [am, StInt lowTag]
dsts = DestInfo (dflt : map fst branches)
jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
| rangeOfOne = gencode alt
| otherwise
= let tag' = a2stix (CLit tag)
- cmpOp = if floating then DoubleNeOp else IntNeOp
- test = StPrim cmpOp [am, tag']
+ cmpOp = if floating then MO_Dbl_Ne else MO_Nat_Ne
+ test = StMachOp cmpOp [am, tag']
cjmp = StCondJump udlbl test
in
gencode alt `thenUs` \ alt_code ->
mkBinaryTree am floating alts choices lowTag highTag udlbl
= getUniqLabelNCG `thenUs` \ uhlbl ->
let tag' = a2stix (CLit splitTag)
- cmpOp = if floating then DoubleGeOp else IntGeOp
- test = StPrim cmpOp [am, tag']
+ cmpOp = if floating then MO_Dbl_Ge else MO_NatS_Ge
+ test = StMachOp cmpOp [am, tag']
cjmp = StCondJump uhlbl test
in
mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
getUniqLabelNCG `thenUs` \ utlbl ->
let discrim' = a2stix discrim
tag' = a2stix (CLit tag)
- cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
- test = StPrim cmpOp [discrim', tag']
+ cmpOp = if (isFloatingRep (getAmodeRep discrim)) then MO_Dbl_Ne else MO_Nat_Ne
+ test = StMachOp cmpOp [discrim', tag']
cjmp = StCondJump utlbl test
dest = StLabel utlbl
join = StLabel ujlbl
gencode deflt `thenUs` \ dflt_code ->
returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
-mkJoin :: AbstractC -> CLabel -> AbstractC
+mkJoin :: AbstractC -> CLabel -> AbstractC
mkJoin code lbl
| mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
| otherwise = code
%---------------------------------------------------------------------------
+\begin{code}
+bitmapToIntegers :: [BitSet] -> [Integer]
+bitmapToIntegers = bundle . map (toInteger . intBS)
+ where
+#if BYTES_PER_WORD == 4
+ bundle = id
+#else
+ bundle [] = []
+ bundle is = case splitAt (BYTES_PER_WORD/4) is of
+ (these, those) ->
+ ( foldr1 (\x y -> x + 4294967296 * y)
+ [x `mod` 4294967296 | x <- these]
+ : bundle those
+ )
+#endif
+\end{code}
+
+%---------------------------------------------------------------------------
+
This answers the question: Can the code fall through to the next
line(s) of code? This errs towards saying True if it can't choose,
because it is used for eliminating needless jumps. In other words, if
projects / ghc-hetmet.git / blobdiff