nonemptyAbsC, mkAbsCStmts
)
import PprAbsC ( dumpRealC )
-import SMRep ( fixedItblSize,
- rET_SMALL, rET_BIG,
- rET_VEC_SMALL, rET_VEC_BIG
- )
-import Constants ( mIN_UPD_SIZE, wORD_SIZE )
+import SMRep ( retItblSize )
import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
mkClosureTblLabel, mkClosureLabel,
labelDynamic, mkSplitMarkerLabel )
-import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
- fastLabelFromCI, closureUpdReqd,
- staticClosureNeedsLink
- )
+import ClosureInfo
import Literal ( Literal(..), word2IntLit )
-import Maybes ( Maybe012(..), maybeToBool )
import StgSyn ( StgOp(..) )
-import MachOp ( MachOp(..), resultRepsOfMachOp )
-import PrimRep ( isFloatingRep, PrimRep(..) )
-import StixInfo ( genCodeInfoTable, genBitmapInfoTable,
- livenessIsSmall, bitmapToIntegers )
+import MachOp ( MachOp(..), resultRepOfMachOp )
+import PrimRep ( isFloatingRep, is64BitRep,
+ PrimRep(..), getPrimRepSizeInBytes )
import StixMacro ( macroCode, checkCode )
import StixPrim ( foreignCallCode, amodeToStix, amodeToStix' )
import Outputable ( pprPanic, ppr )
import Util ( naturalMergeSortLe )
import Panic ( panic )
import TyCon ( tyConDataCons )
-import DataCon ( dataConWrapId )
import Name ( NamedThing(..) )
-import CmdLineOpts ( opt_Static, opt_EnsureSplittableC )
+import CmdLineOpts ( opt_EnsureSplittableC )
import Outputable ( assertPanic )
+import Char ( ord )
+
-- DEBUGGING ONLY
---import IOExts ( trace )
+--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
a2stix' = amodeToStix'
volsaves = volatileSaves
volrestores = volatileRestores
- macro_code = macroCode
-- real code follows... ---------
\end{code}
= gencode absC `thenUs` \ code ->
returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl])
- gentopcode stmt@(CStaticClosure lbl _ _ _)
+ gentopcode stmt@(CStaticClosure lbl closure_info _ _)
= genCodeStaticClosure stmt `thenUs` \ 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 ->
- 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]
+ returnUs ( StSegment DataSegment
+ : 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 = if livenessIsSmall liveness then rET_SMALL else 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
| otherwise
= StCLbl label
- gentopcode stmt@(CBitmap lbl mask)
- = returnUs $ case bitmapToIntegers mask of
- mask'@(_:_:_) ->
- [ StSegment TextSegment
- , StLabel lbl
- , StData WordRep (map StInt (toInteger (length mask') : mask'))
- ]
- _ -> []
+ gentopcode stmt@(CBitmap l@(Liveness lbl size mask))
+ = returnUs
+ [ StSegment TextSegment
+ , StLabel lbl
+ , StData WordRep (map StInt (toInteger size : map toInteger mask))
+ ]
+
+ gentopcode stmt@(CSRTDesc lbl srt_lbl off len bitmap)
+ = returnUs
+ [ StSegment TextSegment
+ , StLabel lbl
+ , StData WordRep (
+ StIndex PtrRep (StCLbl srt_lbl) (StInt (toInteger off)) :
+ map StInt (toInteger len : map toInteger bitmap)
+ )
+ ]
gentopcode stmt@(CClosureTbl tycon)
= returnUs [ StSegment TextSegment
, StLabel (mkClosureTblLabel tycon)
- , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId)
+ , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName)
(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),
\begin{code}
{-
- genCodeVecTbl
- :: AbstractC
- -> UniqSM StixTreeList
- -}
- genCodeVecTbl (CRetVector lbl 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 = if livenessIsSmall liveness then rET_VEC_SMALL else rET_VEC_BIG
-
-\end{code}
-
-\begin{code}
- {-
genCodeStaticClosure
:: 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 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}
= 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 NoDestInfo dest : xs)
where
dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
dyn_off = StMachOp MO_Nat_Sub [StMachOp MO_NatS_Neg [a2stix am],
- StInt (toInteger (fixedItblSize+1))]
+ StInt (toInteger (retItblSize+1))]
\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.
\begin{code}
- gencode (CMacroStmt macro args) = macro_code macro args
+ gencode (CMacroStmt macro args) = macroCode macro (map amodeToStix args)
gencode (CCallProfCtrMacro macro _)
= returnUs (\xs -> StComment macro : xs)
\begin{code}
intTag :: Literal -> Integer
- intTag (MachChar c) = toInteger c
+ intTag (MachChar c) = toInteger (ord c)
intTag (MachInt i) = i
intTag (MachWord w) = intTag (word2IntLit (MachWord w))
intTag _ = panic "intTag"
projects / ghc-hetmet.git / blobdiff