mkClosureTblLabel, mkClosureLabel,
labelDynamic, mkSplitMarkerLabel )
import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
- fastLabelFromCI, closureUpdReqd,
- staticClosureNeedsLink
+ closureLabelFromCI, fastLabelFromCI
)
import Literal ( Literal(..), word2IntLit )
-import Maybes ( Maybe012(..), maybeToBool )
+import Maybes ( maybeToBool )
import StgSyn ( StgOp(..) )
-import MachOp ( MachOp(..), resultRepsOfMachOp )
-import PrimRep ( isFloatingRep, PrimRep(..) )
+import MachOp ( MachOp(..), resultRepOfMachOp )
+import PrimRep ( isFloatingRep, is64BitRep,
+ PrimRep(..), getPrimRepSizeInBytes )
import StixInfo ( genCodeInfoTable, genBitmapInfoTable,
livenessIsSmall, bitmapToIntegers )
import StixMacro ( macroCode, checkCode )
import Outputable ( assertPanic )
-- DEBUGGING ONLY
---import IOExts ( trace )
+--import TRACE ( trace )
--import Outputable ( showSDoc )
--import MachOp ( pprMachOp )
= gencode absC `thenUs` \ code ->
returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl])
- gentopcode stmt@(CStaticClosure lbl _ _ _)
+ gentopcode stmt@(CStaticClosure closure_info _ _)
= genCodeStaticClosure stmt `thenUs` \ code ->
returnUs (
if opt_Static
: StData PtrRep [StInt 0] -- DLLised world, need extra zero word
: StLabel lbl : code []
)
+ where
+ lbl = closureLabelFromCI closure_info
gentopcode stmt@(CRetVector lbl _ _ _)
= genCodeVecTbl stmt `thenUs` \ code ->
-- 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.
+ -- 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)
(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 (StMachOp MO_Nat_Ne
[StInd IntRep (StCLbl flag_lbl),
:: AbstractC
-> UniqSM StixTreeList
-}
- genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
+ genCodeStaticClosure (CStaticClosure 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.
\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 -> mkStAssign pk' lhs' rhs' : xs)
+ where
+ lhs_rep = getAmodeRep lhs
\end{code}
gencode (COpStmt results (StgPrimOp op) args vols)
= panic "AbsCStixGen.gencode: un-translated PrimOp"
- -- Translate out array indexing primops right here, so that
- -- individual targets don't have to deal with them
-
- gencode (CMachOpStmt (Just1 r1) (MO_ReadOSBI off_w rep) [base,index] vols)
- = returnUs (\xs ->
- mkStAssign
- rep
- (a2stix r1)
- (StInd rep (StMachOp MO_Nat_Add
- [StIndex rep (a2stix base) (a2stix index),
- StInt (toInteger (off_w * wORD_SIZE))]))
- : xs
- )
-
- gencode (CMachOpStmt Just0 (MO_WriteOSBI off_w rep) [base,index,val] vols)
- = returnUs (\xs ->
- StAssignMem
- rep
- (StMachOp MO_Nat_Add
- [StIndex rep (a2stix base) (a2stix index),
- StInt (toInteger (off_w * wORD_SIZE))])
- (a2stix val)
- : xs
- )
-
- -- Gruesome cases for multiple-result primops
- gencode (CMachOpStmt (Just2 r1 r2) mop [arg1, arg2] vols)
- | mop `elem` [MO_NatS_AddC, MO_NatS_SubC, MO_NatS_MulC]
- = getUniqueUs `thenUs` \ u1 ->
- getUniqueUs `thenUs` \ u2 ->
- let vr1 = StixVReg u1 IntRep
- vr2 = StixVReg u2 IntRep
- r1s = a2stix r1
- r2s = a2stix r2
- in
- returnUs (\xs ->
- StAssignMachOp (Just2 vr1 vr2) mop [a2stix arg1, a2stix arg2]
- : mkStAssign IntRep r1s (StReg (StixTemp vr1))
- : mkStAssign IntRep r2s (StReg (StixTemp vr2))
- : xs
- )
-
- -- Ordinary MachOps are passed through unchanged.
-
- gencode (CMachOpStmt (Just1 r1) mop args vols)
- = let (Just1 rep) = resultRepsOfMachOp mop
- in
- returnUs (\xs ->
- mkStAssign rep (a2stix r1)
- (StMachOp mop (map a2stix args))
- : xs
- )
+ 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.
projects / ghc-hetmet.git / blobdiff