import MachMisc
import AbsCUtils ( getAmodeRep, mixedTypeLocn,
- nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
+ nonemptyAbsC, mkAbsCStmts
)
-import SMRep ( fixedItblSize,
- rET_SMALL, rET_BIG,
- rET_VEC_SMALL, rET_VEC_BIG
- )
-import Constants ( mIN_UPD_SIZE )
-import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel )
-import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
- fastLabelFromCI, closureUpdReqd,
- staticClosureNeedsLink
- )
-import Const ( Literal(..) )
-import Maybes ( maybeToBool )
-import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
-import PrimRep ( isFloatingRep, PrimRep(..) )
-import StixInfo ( genCodeInfoTable, genBitmapInfoTable )
+import PprAbsC ( dumpRealC )
+import SMRep ( retItblSize )
+import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
+ mkClosureTblLabel, mkClosureLabel,
+ labelDynamic, mkSplitMarkerLabel )
+import ClosureInfo
+import Literal ( Literal(..), word2IntLit )
+import StgSyn ( StgOp(..) )
+import MachOp ( MachOp(..), resultRepOfMachOp )
+import PrimRep ( isFloatingRep, is64BitRep,
+ PrimRep(..), getPrimRepSizeInBytes )
import StixMacro ( macroCode, checkCode )
-import StixPrim ( primCode, 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 BitSet ( intBS )
-
-#ifdef REALLY_HASKELL_1_3
-ord = fromEnum :: Char -> Int
-#endif
+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
- = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
- returnUs ([StComment SLIT("Native Code")] : trees)
+ = gentopcode absC
where
a2stix = amodeToStix
a2stix' = amodeToStix'
volsaves = volatileSaves
volrestores = volatileRestores
- p2stix = primCode
macro_code = macroCode
-- real code follows... ---------
\end{code}
-> UniqSM [StixTree]
-}
- gentopcode (CCodeBlock label absC)
+ gentopcode (CCodeBlock lbl absC)
= gencode absC `thenUs` \ code ->
- returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
+ returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl])
- gentopcode stmt@(CStaticClosure label _ _ _)
+ gentopcode stmt@(CStaticClosure lbl closure_info _ _)
= genCodeStaticClosure stmt `thenUs` \ code ->
- returnUs (StSegment DataSegment : StLabel label : code [])
-
- gentopcode stmt@(CRetVector label _ _ _)
- = genCodeVecTbl stmt `thenUs` \ code ->
- returnUs (StSegment TextSegment : code [StLabel label])
+ returnUs (
+ if opt_Static
+ then StSegment DataSegment
+ : StLabel lbl : code []
+ else StSegment DataSegment
+ : StData PtrRep [StInt 0] -- DLLised world, need extra zero word
+ : StLabel lbl : code []
+ )
+
+ 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 = case liveness of
- LvSmall _ -> rET_SMALL
- LvLarge _ -> 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]))
+ 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_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])))
- 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
, StLabel lbl
- , StData DataPtrRep (map StCLbl closures)
- ]
-
- gentopcode stmt@(CBitmap lbl mask)
- = returnUs [ StSegment TextSegment
- , StLabel lbl
- , StData WordRep (StInt (toInteger (length mask)) :
- map (StInt . toInteger . intBS) mask)
+ , StData DataPtrRep (map mk_StCLbl_for_SRT closures)
]
+ where
+ 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 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
+ , StLabel (mkClosureTblLabel tycon)
+ , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId)
+ (tyConDataCons tycon) )
+ ]
+
+ gentopcode stmt@(CModuleInitBlock plain_lbl lbl absC)
+ = gencode absC `thenUs` \ code ->
+ getUniqLabelNCG `thenUs` \ tmp_lbl ->
+ getUniqLabelNCG `thenUs` \ flag_lbl ->
+ returnUs ( StSegment DataSegment
+ : StLabel flag_lbl
+ : StData IntRep [StInt 0]
+ : StSegment TextSegment
+ : StLabel plain_lbl
+ : StJump NoDestInfo (StCLbl lbl)
+ : StLabel lbl
+ : StCondJump tmp_lbl (StMachOp MO_Nat_Ne
+ [StInd IntRep (StCLbl flag_lbl),
+ StInt 0])
+ : StAssignMem IntRep (StCLbl flag_lbl) (StInt 1)
+ : code
+ [ StLabel tmp_lbl
+ , StAssignReg PtrRep stgSp
+ (StIndex PtrRep (StReg stgSp) (StInt (-1)))
+ , StJump NoDestInfo (StInd WordRep (StReg stgSp))
+ ])
gentopcode absC
= gencode absC `thenUs` \ code ->
returnUs (StSegment TextSegment : code [])
-
-\end{code}
-
-\begin{code}
- {-
- genCodeVecTbl
- :: AbstractC
- -> UniqSM StixTreeList
- -}
- genCodeVecTbl (CRetVector label 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 = case liveness of
- LvSmall _ -> rET_VEC_SMALL
- LvLarge _ -> rET_VEC_BIG
-
\end{code}
\begin{code}
:: 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 (\amode -> StData (getAmodeRep amode) [a2stix amode]) amodes ++
- [StData PtrRep (padding_wds ++ static_link)]
-
- -- always at least one padding word: this is the static link field
- -- for the garbage collector.
- padding_wds = if closureUpdReqd cl_info then
- take (max 0 (mIN_UPD_SIZE - length amodes)) zeros
- else
- []
-
- static_link | 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
- -}
-
+ foldr do_one_amode [] amodes
+
+ 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
+ | getPrimRepSizeInBytes pk >= getPrimRepSizeInBytes IntRep = pk
+ | otherwise = IntRep
\end{code}
Now the individual AbstractC statements.
\end{code}
-Split markers are a NOP in this land.
+Split markers just insert a __stg_split_marker, which is caught by the
+split-mangler later on and used to split the assembly into chunks.
\begin{code}
- gencode CSplitMarker = returnUs id
+ gencode CSplitMarker
+ | opt_EnsureSplittableC = returnUs (\xs -> StLabel mkSplitMarkerLabel : xs)
+ | otherwise = returnUs id
\end{code}
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 (CVal reg_rel PtrRep)
+ lhs = a2stix reg_rel
lbl = infoTableLabelFromCI cl_info
in
- returnUs (\xs -> StAssign 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}
\begin{code}
gencode (CJump dest)
- = returnUs (\xs -> StJump (a2stix dest) : xs)
+ = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
gencode (CFallThrough (CLbl lbl _))
= returnUs (\xs -> StFallThrough lbl : xs)
gencode (CReturn dest DirectReturn)
- = returnUs (\xs -> StJump (a2stix dest) : xs)
+ = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
gencode (CReturn table (StaticVectoredReturn n))
- = returnUs (\xs -> StJump dest : xs)
+ = 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 dest : xs)
+ = 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}
Now the PrimOps, some of which may need caller-saves register wrappers.
\begin{code}
-
- gencode (COpStmt results 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))
-
- | otherwise = p2stix (nonVoid results) op (nonVoid args)
- where
- nonVoid = filter ((/= VoidRep) . getAmodeRep)
-
+ gencode (COpStmt results (StgFCallOp fcall _) args vols)
+ = ASSERT( null vols )
+ foreignCallCode (nonVoid results) fcall (nonVoid args)
+
+ gencode (COpStmt results (StgPrimOp op) args vols)
+ = panic "AbsCStixGen.gencode: un-translated PrimOp"
+
+ 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.
Nothing -> gencode alt_code
Just dc -> mkIfThenElse discrim tag alt_code dc
- [(tag1@(MachInt i1 _), alt_code1),
- (tag2@(MachInt i2 _), alt_code2)]
+ [(tag1@(MachInt i1), alt_code1),
+ (tag2@(MachInt i2), alt_code2)]
| deflt_is_empty && i1 == 0 && i2 == 1
-> mkIfThenElse discrim tag1 alt_code1 alt_code2
| deflt_is_empty && i1 == 1 && i2 == 0
gencode (CCallProfCCMacro macro _)
= returnUs (\xs -> StComment macro : xs)
+ gencode CCallTypedef{} = returnUs id
+
+ gencode other
+ = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
+
+ nonVoid = filter ((/= VoidRep) . getAmodeRep)
\end{code}
Here, we generate a jump table if there are more than four (integer)
\begin{code}
intTag :: Literal -> Integer
- intTag (MachChar c) = fromInt (ord c)
- intTag (MachInt i _) = i
- intTag _ = panic "intTag"
+ intTag (MachChar c) = toInteger c
+ intTag (MachInt i) = i
+ intTag (MachWord w) = intTag (word2IntLit (MachWord w))
+ intTag _ = panic "intTag"
fltTag :: Literal -> Rational
- fltTag (MachFloat f) = f
+ fltTag (MachFloat f) = f
fltTag (MachDouble d) = d
- fltTag _ = panic "fltTag"
+ fltTag x = pprPanic "fltTag" (ppr x)
{-
mkSimpleSwitches
highest = if floating then targetMaxDouble else targetMaxInt
in
(
- if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
+ if not floating && choices > 4
+ && highTag - lowTag < toInteger (2 * choices)
+ then
mkJumpTable am' sortedAlts lowTag highTag udlbl
else
mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
)
- `thenUs` \ alt_code ->
+ `thenUs` \ alt_code ->
gencode absC `thenUs` \ dflt_code ->
returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
choices = length alts
(x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
- (x@(MachInt _ _),_) `leAlt` (y,_) = intTag x <= intTag y
+ (x@(MachInt _), _) `leAlt` (y,_) = intTag x <= intTag y
+ (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y
(x,_) `leAlt` (y,_) = fltTag x <= fltTag y
\end{code}
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 (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
+ jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
tlbl = StLabel utlbl
table = StData PtrRep (mkTable branches [lowTag..highTag] [])
in
| 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