import MachMisc
import AbsCUtils ( getAmodeRep, mixedTypeLocn,
- nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
+ nonemptyAbsC, mkAbsCStmts
)
import PprAbsC ( dumpRealC )
import SMRep ( fixedItblSize,
)
import Constants ( mIN_UPD_SIZE )
import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
- mkClosureTblLabel, mkStaticClosureLabel )
+ mkClosureTblLabel, mkClosureLabel,
+ moduleRegdLabel, labelDynamic,
+ mkSplitMarkerLabel )
import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
fastLabelFromCI, closureUpdReqd,
staticClosureNeedsLink
)
-import Const ( Literal(..) )
+import Literal ( Literal(..), word2IntLit )
import Maybes ( maybeToBool )
import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
import PrimRep ( isFloatingRep, PrimRep(..) )
import StixInfo ( genCodeInfoTable, genBitmapInfoTable )
import StixMacro ( macroCode, checkCode )
import StixPrim ( primCode, amodeToStix, amodeToStix' )
-import Outputable ( pprPanic )
+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(..) )
-
-#ifdef REALLY_HASKELL_1_3
-ord = fromEnum :: Char -> Int
-#endif
+import Char ( ord )
+import CmdLineOpts ( opt_Static, opt_EnsureSplittableC )
\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 [StixTree]
genCodeAbstractC absC
- = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
- returnUs ([StComment SLIT("Native Code")] : trees)
+ = gentopcode absC
where
a2stix = amodeToStix
a2stix' = amodeToStix'
gentopcode stmt@(CStaticClosure lbl _ _ _)
= genCodeStaticClosure stmt `thenUs` \ code ->
- returnUs (StSegment DataSegment : StLabel lbl : code [])
+ 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 _ _ _)
= genCodeVecTbl stmt `thenUs` \ code ->
gentopcode stmt@(CSRT lbl closures)
= returnUs [ StSegment TextSegment
, StLabel lbl
- , StData DataPtrRep (map StCLbl closures)
+ , StData DataPtrRep (map mk_StCLbl_for_SRT closures)
]
+ where
+ mk_StCLbl_for_SRT :: CLabel -> StixTree
+ mk_StCLbl_for_SRT label
+ | labelDynamic label
+ = StIndex Int8Rep (StCLbl label) (StInt 1)
+ | otherwise
+ = StCLbl label
gentopcode stmt@(CBitmap lbl mask)
= returnUs [ StSegment TextSegment
gentopcode stmt@(CClosureTbl tycon)
= returnUs [ StSegment TextSegment
, StLabel (mkClosureTblLabel tycon)
- , StData DataPtrRep (map (StCLbl . mkStaticClosureLabel . getName)
+ , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId)
(tyConDataCons tycon) )
]
+ gentopcode stmt@(CModuleInitBlock 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 lbl
+ : StCondJump tmp_lbl (StPrim IntNeOp
+ [StInd IntRep (StCLbl flag_lbl),
+ StInt 0])
+ : StAssign IntRep (StInd IntRep (StCLbl flag_lbl)) (StInt 1)
+ : code
+ [ StLabel tmp_lbl
+ , StAssign PtrRep stgSp
+ (StIndex PtrRep stgSp (StInt (-1)))
+ , StJump NoDestInfo (StInd WordRep stgSp)
+ ])
+
gentopcode absC
= gencode absC `thenUs` \ code ->
returnUs (StSegment TextSegment : code [])
-
\end{code}
\begin{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)]
+ 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 Int8Rep = IntRep
+ promote_to_word CharRep = IntRep
+ promote_to_word other = other
+
-- always at least one padding word: this is the static link field
-- for the garbage collector.
padding_wds = if closureUpdReqd cl_info then
\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}
\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],
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
\begin{code}
intTag :: Literal -> Integer
- intTag (MachChar c) = toInteger (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}
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