import AbsCUtils ( getAmodeRep, mixedTypeLocn,
nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
)
+import PprAbsC ( dumpRealC )
import SMRep ( fixedItblSize,
rET_SMALL, rET_BIG,
rET_VEC_SMALL, rET_VEC_BIG
)
import Constants ( mIN_UPD_SIZE )
-import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel )
+import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
+ mkClosureTblLabel, mkClosureLabel,
+ moduleRegdLabel )
import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
- fastLabelFromCI, closureUpdReqd
+ 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, ppr )
import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
import Util ( naturalMergeSortLe )
import Panic ( panic )
+import TyCon ( tyConDataCons )
+import DataCon ( dataConWrapId )
import BitSet ( intBS )
-
-#ifdef REALLY_HASKELL_1_3
-ord = fromEnum :: Char -> Int
-#endif
+import Name ( NamedThing(..) )
+import Char ( ord )
\end{code}
For each independent chunk of AbstractC code, we generate a list of
-> 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 _ _ _)
= genCodeStaticClosure stmt `thenUs` \ code ->
- returnUs (StSegment DataSegment : StLabel label : code [])
+ returnUs (StSegment DataSegment : StLabel lbl : code [])
- gentopcode stmt@(CRetVector label _ _ _)
+ gentopcode stmt@(CRetVector lbl _ _ _)
= genCodeVecTbl stmt `thenUs` \ code ->
- returnUs (StSegment TextSegment : code [StLabel label])
+ returnUs (StSegment TextSegment : code [StLabel lbl])
gentopcode stmt@(CRetDirect uniq absC srt liveness)
= gencode absC `thenUs` \ code ->
LvSmall _ -> rET_SMALL
LvLarge _ -> rET_BIG
- gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _)
+ gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _)
| slow_is_empty
= genCodeInfoTable stmt `thenUs` \ itbl ->
slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
slow_lbl = entryLabelFromCI cl_info
- gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _) =
+ gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _) =
-- ToDo: what if this is empty? ------------------------^^^^
genCodeInfoTable stmt `thenUs` \ itbl ->
gencode slow `thenUs` \ slow_code ->
map (StInt . toInteger . intBS) mask)
]
+ gentopcode stmt@(CClosureTbl tycon)
+ = returnUs [ StSegment TextSegment
+ , StLabel (mkClosureTblLabel tycon)
+ , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId)
+ (tyConDataCons tycon) )
+ ]
+
+ gentopcode stmt@(CModuleInitBlock lbl absC)
+ = gencode absC `thenUs` \ code ->
+ getUniqLabelNCG `thenUs` \ tmp_lbl ->
+ returnUs ( StSegment DataSegment
+ : StLabel moduleRegdLabel
+ : StData IntRep [StInt 0]
+ : StSegment TextSegment
+ : StLabel lbl
+ : StCondJump tmp_lbl (StPrim IntNeOp
+ [StInd IntRep (StCLbl moduleRegdLabel),
+ StInt 0])
+ : StAssign IntRep (StInd IntRep (StCLbl moduleRegdLabel)) (StInt 1)
+ : code
+ [ StLabel tmp_lbl
+ , StAssign PtrRep stgSp (StPrim IntSubOp [stgSp, StInt 4])
+ , StJump (StInd WordRep stgSp)
+ ])
+
gentopcode absC
= gencode absC `thenUs` \ code ->
returnUs (StSegment TextSegment : code [])
-
\end{code}
\begin{code}
:: AbstractC
-> UniqSM StixTreeList
-}
- genCodeVecTbl (CRetVector label amodes srt liveness)
+ genCodeVecTbl (CRetVector lbl amodes srt liveness)
= genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
returnUs (\xs -> vectbl : itbl xs)
where
where
table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
map (\amode -> StData (getAmodeRep amode) [a2stix amode]) amodes ++
- [StData PtrRep padding_wds]
+ [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 (1 + max 0 (mIN_UPD_SIZE - length amodes)) zeros
+ take (max 0 (mIN_UPD_SIZE - length amodes)) zeros
else
- [StInt 0]
+ []
+
+ static_link | staticClosureNeedsLink cl_info = [StInt 0]
+ | otherwise = []
zeros = StInt 0 : zeros
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 -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs)
\end{code}
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 other
+ = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
\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 (ord 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
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}
projects / ghc-hetmet.git / blobdiff