import MachMisc
import AbsCUtils ( getAmodeRep, mixedTypeLocn,
- nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
+ nonemptyAbsC, mkAbsCStmts
)
-import SMRep ( fixedItblSize,
- rET_SMALL, rET_BIG,
- rET_VEC_SMALL, rET_VEC_BIG
- )
-import Constants ( mIN_UPD_SIZE )
-import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel )
-import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
- fastLabelFromCI, closureUpdReqd,
- staticClosureNeedsLink
- )
-import Const ( Literal(..) )
-import Maybes ( maybeToBool )
-import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
-import PrimRep ( isFloatingRep, PrimRep(..) )
-import StixInfo ( genCodeInfoTable, genBitmapInfoTable )
+import PprAbsC ( dumpRealC )
+import SMRep ( retItblSize )
+import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
+ mkClosureTblLabel, mkClosureLabel,
+ labelDynamic, mkSplitMarkerLabel )
+import ClosureInfo
+import Literal ( Literal(..), word2IntLit )
+import StgSyn ( StgOp(..) )
+import MachOp ( MachOp(..), resultRepOfMachOp )
+import PrimRep ( isFloatingRep, is64BitRep,
+ PrimRep(..), getPrimRepSizeInBytes )
import StixMacro ( macroCode, checkCode )
-import StixPrim ( primCode, amodeToStix, amodeToStix' )
+import StixPrim ( foreignCallCode, amodeToStix, amodeToStix' )
+import Outputable ( pprPanic, ppr )
import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
import Util ( naturalMergeSortLe )
import Panic ( panic )
-import BitSet ( intBS )
+import TyCon ( tyConDataCons )
+import Name ( NamedThing(..) )
+import CmdLineOpts ( opt_EnsureSplittableC )
+import Outputable ( assertPanic )
+
+import Char ( ord )
-#ifdef REALLY_HASKELL_1_3
-ord = fromEnum :: Char -> Int
-#endif
+-- DEBUGGING ONLY
+--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
performed locally within the chunk.
\begin{code}
-genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]]
+genCodeAbstractC :: AbstractC -> UniqSM [StixStmt]
genCodeAbstractC absC
- = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
- returnUs ([StComment SLIT("Native Code")] : trees)
+ = gentopcode absC
where
a2stix = amodeToStix
a2stix' = amodeToStix'
volsaves = volatileSaves
volrestores = volatileRestores
- p2stix = primCode
- 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 (StSegment DataSegment : StLabel lbl : code [])
-
- gentopcode stmt@(CRetVector lbl _ _ _)
- = genCodeVecTbl stmt `thenUs` \ code ->
- returnUs (StSegment TextSegment : code [StLabel lbl])
+ 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 = case liveness of
- LvSmall _ -> rET_SMALL
- LvLarge _ -> 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]))
- 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])))
+ 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_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
, StLabel lbl
- , StData DataPtrRep (map StCLbl closures)
- ]
-
- gentopcode stmt@(CBitmap lbl mask)
- = returnUs [ StSegment TextSegment
- , StLabel lbl
- , StData WordRep (StInt (toInteger (length mask)) :
- map (StInt . toInteger . intBS) mask)
+ , StData DataPtrRep (map mk_StCLbl_for_SRT closures)
]
+ where
+ mk_StCLbl_for_SRT :: CLabel -> StixExpr
+ mk_StCLbl_for_SRT label
+ | labelDynamic label
+ = StIndex Int8Rep (StCLbl label) (StInt 1)
+ | otherwise
+ = StCLbl label
+
+ 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)
+ (tyConDataCons tycon) )
+ ]
+
+ gentopcode stmt@(CModuleInitBlock plain_lbl 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 plain_lbl
+ : StJump NoDestInfo (StCLbl lbl)
+ : StLabel lbl
+ : StCondJump tmp_lbl (StMachOp MO_Nat_Ne
+ [StInd IntRep (StCLbl flag_lbl),
+ StInt 0])
+ : StAssignMem IntRep (StCLbl flag_lbl) (StInt 1)
+ : code
+ [ StLabel tmp_lbl
+ , StAssignReg PtrRep stgSp
+ (StIndex PtrRep (StReg stgSp) (StInt (-1)))
+ , StJump NoDestInfo (StInd WordRep (StReg stgSp))
+ ])
gentopcode absC
= gencode absC `thenUs` \ code ->
returnUs (StSegment TextSegment : code [])
-
-\end{code}
-
-\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 = case liveness of
- LvSmall _ -> rET_VEC_SMALL
- LvLarge _ -> rET_VEC_BIG
-
\end{code}
\begin{code}
:: 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 (\amode -> StData (getAmodeRep amode) [a2stix 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
- []
-
- static_link | 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
- -}
-
+ foldr do_one_amode [] amodes
+
+ 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
+ | getPrimRepSizeInBytes pk >= getPrimRepSizeInBytes IntRep = pk
+ | otherwise = IntRep
\end{code}
Now the individual AbstractC statements.
\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}
gencode c2 `thenUs` \ b2 ->
returnUs (b1 . b2)
+ gencode (CSequential stuff)
+ = foo stuff
+ where
+ foo [] = returnUs id
+ foo (s:ss) = gencode s `thenUs` \ stix ->
+ foo ss `thenUs` \ stixes ->
+ returnUs (stix . stixes)
+
\end{code}
Initialising closure headers in the heap...a fairly complex ordeal if
\begin{code}
- gencode (CInitHdr cl_info reg_rel _)
+ gencode (CInitHdr cl_info reg_rel _ _)
= let
lhs = a2stix reg_rel
lbl = infoTableLabelFromCI cl_info
in
- returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs)
+ returnUs (\xs -> StAssignMem PtrRep lhs (StCLbl lbl) : xs)
\end{code}
\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 -> StAssign pk' lhs' rhs' : xs)
+ returnUs (\xs -> mkStAssign pk' lhs' rhs' : xs)
+ where
+ lhs_rep = getAmodeRep lhs
\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))))
+ (StInt (toInteger (-n-retItblSize-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],
- StInt (toInteger (fixedItblSize+1))]
+ dyn_off = StMachOp MO_Nat_Sub [StMachOp MO_NatS_Neg [a2stix am],
+ StInt (toInteger (retItblSize+1))]
\end{code}
Now the PrimOps, some of which may need caller-saves register wrappers.
\begin{code}
-
- gencode (COpStmt results op args vols)
- -- ToDo (ADR?): use that liveness mask
- | primOpNeedsWrapper op
- = let
- saves = volsaves vols
- restores = volrestores vols
- in
- p2stix (nonVoid results) op (nonVoid args)
- `thenUs` \ code ->
- returnUs (\xs -> saves ++ code (restores ++ xs))
-
- | otherwise = p2stix (nonVoid results) op (nonVoid args)
- where
- nonVoid = filter ((/= VoidRep) . getAmodeRep)
-
+ gencode (COpStmt results (StgFCallOp fcall _) args vols)
+ = ASSERT( null vols )
+ foreignCallCode (nonVoid results) fcall (nonVoid args)
+
+ gencode (COpStmt results (StgPrimOp op) args vols)
+ = panic "AbsCStixGen.gencode: un-translated PrimOp"
+
+ 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.
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}
- 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)
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) = 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
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}
mkJumpTable am alts lowTag highTag dflt
= getUniqLabelNCG `thenUs` \ utlbl ->
mapUs genLabel alts `thenUs` \ branches ->
- let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
- cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
+ let cjmpLo = StCondJump dflt (StMachOp MO_NatS_Lt [am, StInt (toInteger lowTag)])
+ cjmpHi = StCondJump dflt (StMachOp MO_NatS_Gt [am, StInt (toInteger highTag)])
- offset = StPrim IntSubOp [am, StInt lowTag]
+ offset = StMachOp MO_Nat_Sub [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
| rangeOfOne = gencode alt
| otherwise
= let tag' = a2stix (CLit tag)
- cmpOp = if floating then DoubleNeOp else IntNeOp
- test = StPrim cmpOp [am, tag']
+ cmpOp = if floating then MO_Dbl_Ne else MO_Nat_Ne
+ test = StMachOp cmpOp [am, tag']
cjmp = StCondJump udlbl test
in
gencode alt `thenUs` \ alt_code ->
mkBinaryTree am floating alts choices lowTag highTag udlbl
= getUniqLabelNCG `thenUs` \ uhlbl ->
let tag' = a2stix (CLit splitTag)
- cmpOp = if floating then DoubleGeOp else IntGeOp
- test = StPrim cmpOp [am, tag']
+ cmpOp = if floating then MO_Dbl_Ge else MO_NatS_Ge
+ test = StMachOp cmpOp [am, tag']
cjmp = StCondJump uhlbl test
in
mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
getUniqLabelNCG `thenUs` \ utlbl ->
let discrim' = a2stix discrim
tag' = a2stix (CLit tag)
- cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
- test = StPrim cmpOp [discrim', tag']
+ cmpOp = if (isFloatingRep (getAmodeRep discrim)) then MO_Dbl_Ne else MO_Nat_Ne
+ test = StMachOp cmpOp [discrim', tag']
cjmp = StCondJump utlbl test
dest = StLabel utlbl
join = StLabel ujlbl
gencode deflt `thenUs` \ dflt_code ->
returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
-mkJoin :: AbstractC -> CLabel -> AbstractC
+mkJoin :: AbstractC -> CLabel -> AbstractC
mkJoin code lbl
| mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
| otherwise = code
projects / ghc-hetmet.git / blobdiff