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,
- closureLabelFromCI, fastLabelFromCI
- )
+import ClosureInfo
import Literal ( Literal(..), word2IntLit )
-import Maybes ( maybeToBool )
import StgSyn ( StgOp(..) )
import MachOp ( MachOp(..), resultRepOfMachOp )
import PrimRep ( isFloatingRep, is64BitRep,
- PrimRep(..), getPrimRepArrayElemSize )
-import StixInfo ( genCodeInfoTable, genBitmapInfoTable,
- livenessIsSmall, bitmapToIntegers )
+ 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 closure_info _ _)
+ 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 []
- )
- where
- lbl = closureLabelFromCI closure_info
+ returnUs ( StSegment DataSegment
+ : 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]
+ 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]))
- 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
| 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) )
]
\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)] :
-- We need to promote any item smaller than a word to a word
promote_to_word pk
- | getPrimRepArrayElemSize pk >= getPrimRepArrayElemSize IntRep = pk
- | otherwise = IntRep
+ | getPrimRepSizeInBytes pk >= getPrimRepSizeInBytes IntRep = pk
+ | otherwise = IntRep
\end{code}
Now the individual AbstractC statements.
= 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}
\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