import Constants ( mIN_UPD_SIZE )
import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
mkClosureTblLabel, mkClosureLabel,
- moduleRegdLabel, labelDynamic,
- mkSplitMarkerLabel )
+ labelDynamic, mkSplitMarkerLabel )
import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
fastLabelFromCI, closureUpdReqd,
staticClosureNeedsLink
)
import Literal ( Literal(..), word2IntLit )
import Maybes ( maybeToBool )
+import StgSyn ( StgOp(..) )
import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
import PrimRep ( isFloatingRep, PrimRep(..) )
-import StixInfo ( genCodeInfoTable, genBitmapInfoTable )
+import StixInfo ( genCodeInfoTable, genBitmapInfoTable,
+ livenessIsSmall, bitmapToIntegers )
import StixMacro ( macroCode, checkCode )
-import StixPrim ( primCode, amodeToStix, amodeToStix' )
+import StixPrim ( primCode, foreignCallCode, amodeToStix, amodeToStix' )
import Outputable ( pprPanic, ppr )
import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
import Util ( naturalMergeSortLe )
import Panic ( panic )
import TyCon ( tyConDataCons )
import DataCon ( dataConWrapId )
-import BitSet ( intBS )
import Name ( NamedThing(..) )
-import Char ( ord )
import CmdLineOpts ( opt_Static, opt_EnsureSplittableC )
+import Outputable ( assertPanic )
\end{code}
For each independent chunk of AbstractC code, we generate a list of
gentopcode stmt@(CRetVector lbl _ _ _)
= genCodeVecTbl stmt `thenUs` \ code ->
- returnUs (StSegment TextSegment : code [StLabel lbl])
+ returnUs (StSegment TextSegment
+ : code [StLabel lbl, vtbl_post_label_word])
+ where
+ -- We put a dummy word after the vtbl label so as to ensure the label
+ -- is in the same (Text) section as the vtbl it labels. This is critical
+ -- for ensuring the GC works correctly, although GC crashes due to
+ -- misclassification are much more likely to show up in the interactive
+ -- system than in compile code. For details see comment near line 1164
+ -- of ghc/driver/mangler/ghc-asm.lprl, which contains an analogous fix for
+ -- the mangled via-C route.
+ vtbl_post_label_word = StData PtrRep [StInt 0]
gentopcode stmt@(CRetDirect uniq absC srt liveness)
= gencode absC `thenUs` \ code ->
where
lbl_info = mkReturnInfoLabel uniq
lbl_ret = mkReturnPtLabel uniq
- closure_type = case liveness of
- LvSmall _ -> rET_SMALL
- LvLarge _ -> rET_BIG
+ closure_type = if livenessIsSmall liveness then rET_SMALL else rET_BIG
gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _)
mk_StCLbl_for_SRT :: CLabel -> StixTree
mk_StCLbl_for_SRT label
| labelDynamic label
- = StIndex CharRep (StCLbl label) (StInt 1)
+ = StIndex Int8Rep (StCLbl label) (StInt 1)
| otherwise
= StCLbl label
gentopcode stmt@(CBitmap lbl mask)
- = returnUs [ StSegment TextSegment
- , StLabel lbl
- , StData WordRep (StInt (toInteger (length mask)) :
- map (StInt . toInteger . intBS) mask)
- ]
+ = returnUs $ case bitmapToIntegers mask of
+ mask'@(_:_:_) ->
+ [ StSegment TextSegment
+ , StLabel lbl
+ , StData WordRep (map StInt (toInteger (length mask') : mask'))
+ ]
+ _ -> []
gentopcode stmt@(CClosureTbl tycon)
= returnUs [ StSegment TextSegment
[ StLabel tmp_lbl
, StAssign PtrRep stgSp
(StIndex PtrRep stgSp (StInt (-1)))
- , StJump (StInd WordRep stgSp)
+ , StJump NoDestInfo (StInd WordRep stgSp)
])
gentopcode absC
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
+ closure_type = if livenessIsSmall liveness then rET_VEC_SMALL else rET_VEC_BIG
\end{code}
= returnUs (\xs -> table ++ xs)
where
table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
- map (\amode -> StData (getAmodeRep amode) [a2stix amode]) amodes ++
+ map do_one_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
- []
+ do_one_amode amode
+ = StData (promote_to_word (getAmodeRep amode)) [a2stix 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
- static_link | staticClosureNeedsLink cl_info = [StInt 0]
- | otherwise = []
+ 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
\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))))
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],
Now the PrimOps, some of which may need caller-saves register wrappers.
\begin{code}
+ gencode (COpStmt results (StgFCallOp fcall _) args vols)
+ = ASSERT( null vols )
+ foreignCallCode (nonVoid results) fcall (nonVoid args)
- gencode (COpStmt results op args vols)
+ gencode (COpStmt results (StgPrimOp op) args vols)
-- ToDo (ADR?): use that liveness mask
| primOpNeedsWrapper op
= let
- saves = volsaves vols
+ saves = volsaves vols
restores = volrestores vols
in
p2stix (nonVoid results) op (nonVoid args)
returnUs (\xs -> saves ++ code (restores ++ xs))
| otherwise = p2stix (nonVoid results) op (nonVoid args)
- where
- nonVoid = filter ((/= VoidRep) . getAmodeRep)
-
\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)
+
+ 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) = toInteger (ord c)
+ intTag (MachChar c) = toInteger c
intTag (MachInt i) = i
intTag (MachWord w) = intTag (word2IntLit (MachWord w))
intTag _ = panic "intTag"
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)))
cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
offset = StPrim IntSubOp [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
projects / ghc-hetmet.git / blobdiff