%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\begin{code}
-#include "HsVersions.h"
+module AbsCStixGen ( genCodeAbstractC ) where
-module AbsCStixGen (
- genCodeAbstractC,
+#include "HsVersions.h"
- -- and, of course, that's not enough...
- AbstractC, Target, StixTree, SplitUniqSupply, SUniqSM(..)
- ) where
+import Ratio ( Rational )
import AbsCSyn
-import AbsPrel ( PrimOp(..), primOpNeedsWrapper, isCompareOp
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import CgCompInfo ( mIN_UPD_SIZE )
-import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, fastLabelFromCI,
- closureUpdReqd
+import Stix
+import MachMisc
+
+import AbsCUtils ( getAmodeRep, mixedTypeLocn,
+ nonemptyAbsC, mkAbsCStmts
)
-import MachDesc
-import Maybes ( Maybe(..), maybeToBool )
-import Outputable
-import PrimKind ( isFloatingKind )
-import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
-import Stix
-import StixInfo ( genCodeInfoTable )
-import SplitUniq
-import Unique
-import Util
+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 ( foreignCallCode, amodeToStix, amodeToStix' )
+import Outputable ( pprPanic, ppr )
+import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
+import Util ( naturalMergeSortLe )
+import Panic ( panic )
+import TyCon ( tyConDataCons )
+import Constants ( wORD_SIZE, bITMAP_BITS_SHIFT )
+import DataCon ( dataConWrapId )
+import Name ( NamedThing(..) )
+import CmdLineOpts ( opt_Static, opt_EnsureSplittableC )
+import Outputable ( assertPanic )
+import BitSet ( BitSet, intBS )
+
+-- 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 @StixTree@s,
-where each tree corresponds to a single Stix instruction. We leave the chunks
-separated so that register allocation can be performed locally within the chunk.
+For each independent chunk of AbstractC code, we generate a list of
+@StixTree@s, where each tree corresponds to a single Stix instruction.
+We leave the chunks separated so that register allocation can be
+performed locally within the chunk.
\begin{code}
+genCodeAbstractC :: AbstractC -> UniqSM [StixStmt]
-genCodeAbstractC
- :: Target
- -> AbstractC
- -> SUniqSM [[StixTree]]
-
-genCodeAbstractC target absC =
- mapSUs (genCodeTopAbsC target) (mkAbsCStmtList absC) `thenSUs` \ trees ->
- returnSUs ([StComment SLIT("Native Code")] : trees)
-
+genCodeAbstractC absC
+ = gentopcode absC
+ where
+ a2stix = amodeToStix
+ a2stix' = amodeToStix'
+ volsaves = volatileSaves
+ volrestores = volatileRestores
+ macro_code = macroCode
+ -- real code follows... ---------
\end{code}
Here we handle top-level things, like @CCodeBlock@s and
@CClosureInfoTable@s.
\begin{code}
-
-genCodeTopAbsC
- :: Target
- -> AbstractC
- -> SUniqSM [StixTree]
-
-genCodeTopAbsC target (CCodeBlock label absC) =
- genCodeAbsC target absC `thenSUs` \ code ->
- returnSUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
-
-genCodeTopAbsC target stmt@(CStaticClosure label _ _ _) =
- genCodeStaticClosure target stmt `thenSUs` \ code ->
- returnSUs (StSegment DataSegment : StLabel label : code [])
-
-genCodeTopAbsC target stmt@(CRetUnVector _ _) = returnSUs []
-
-genCodeTopAbsC target stmt@(CFlatRetVector label _) =
- genCodeVecTbl target stmt `thenSUs` \ code ->
- returnSUs (StSegment TextSegment : code [StLabel label])
-
-genCodeTopAbsC target stmt@(CClosureInfoAndCode cl_info slow Nothing _ _)
-
- | slow_is_empty
- = genCodeInfoTable target stmt `thenSUs` \ itbl ->
- returnSUs (StSegment TextSegment : itbl [])
-
- | otherwise
- = genCodeInfoTable target stmt `thenSUs` \ itbl ->
- genCodeAbsC target slow `thenSUs` \ slow_code ->
- returnSUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
- slow_code [StFunEnd slow_lbl]))
+ {-
+ genCodeTopAbsC
+ :: AbstractC
+ -> UniqSM [StixTree]
+ -}
+
+ gentopcode (CCodeBlock lbl absC)
+ = gencode absC `thenUs` \ code ->
+ returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd 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 amodes srt liveness)
+ = returnUs ( StSegment TextSegment
+ : StData PtrRep table
+ : StLabel lbl
+ : []
+ )
where
- slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
- slow_lbl = entryLabelFromCI cl_info
-
-genCodeTopAbsC target stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _) =
--- ToDo: what if this is empty? ------------------------^^^^
- genCodeInfoTable target stmt `thenSUs` \ itbl ->
- genCodeAbsC target slow `thenSUs` \ slow_code ->
- genCodeAbsC target fast `thenSUs` \ fast_code ->
- returnSUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
- slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
- fast_code [StFunEnd fast_lbl])))
+ table = map amodeToStix (mkVecInfoTable amodes srt liveness)
+
+ gentopcode stmt@(CRetDirect uniq absC srt liveness)
+ = gencode absC `thenUs` \ code ->
+ returnUs ( StSegment TextSegment
+ : StData PtrRep table
+ : StLabel info_lbl
+ : StLabel ret_lbl
+ : code [])
+ where
+ 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
-
-genCodeTopAbsC target absC =
- genCodeAbsC target absC `thenSUs` \ code ->
- returnSUs (StSegment TextSegment : code [])
+ 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 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))
+ | isBigLiveness l
+ = returnUs
+ [ StSegment TextSegment
+ , StLabel lbl
+ , StData WordRep (map StInt (toInteger size : bitmapToIntegers mask))
+ ]
+ | otherwise
+ = returnUs []
+ where
+ -- ToDo: translate out bitmaps earlier, like info tables
+ isBigLiveness (Liveness _ size _) = size > mAX_SMALL_BITMAP_SIZE
+ mAX_SMALL_BITMAP_SIZE = (wORD_SIZE * 8) - bITMAP_BITS_SHIFT
+
+ gentopcode stmt@(CClosureTbl tycon)
+ = returnUs [ StSegment TextSegment
+ , StLabel (mkClosureTblLabel tycon)
+ , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId)
+ (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}
-Now the individual AbstractC statements.
-
\begin{code}
-
-genCodeAbsC
- :: Target
- -> AbstractC
- -> SUniqSM StixTreeList
-
+ {-
+ genCodeStaticClosure
+ :: AbstractC
+ -> UniqSM StixTreeList
+ -}
+ genCodeStaticClosure (CStaticClosure lbl cl_info cost_centre amodes)
+ = returnUs (\xs -> table ++ xs)
+ where
+ table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
+ 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}
-@AbsCNop@s just disappear.
+Now the individual AbstractC statements.
\begin{code}
-
-genCodeAbsC target AbsCNop = returnSUs id
-
+ {-
+ gencode
+ :: AbstractC
+ -> UniqSM StixTreeList
+ -}
\end{code}
-OLD:@CComment@s are passed through as the corresponding @StComment@s.
+@AbsCNop@s just disappear.
\begin{code}
---UNUSED:genCodeAbsC target (CComment s) = returnSUs (\xs -> StComment s : xs)
+ gencode AbsCNop = returnUs id
\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}
-genCodeAbsC target CSplitMarker = returnSUs id
+ gencode CSplitMarker
+ | opt_EnsureSplittableC = returnUs (\xs -> StLabel mkSplitMarkerLabel : xs)
+ | otherwise = returnUs id
\end{code}
\begin{code}
-genCodeAbsC target (AbsCStmts c1 c2) =
- genCodeAbsC target c1 `thenSUs` \ b1 ->
- genCodeAbsC target c2 `thenSUs` \ b2 ->
- returnSUs (b1 . b2)
+ gencode (AbsCStmts c1 c2)
+ = gencode c1 `thenUs` \ b1 ->
+ 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}
\begin{code}
-genCodeAbsC target (CInitHdr cl_info reg_rel _ _) =
- let
- lhs = amodeToStix target (CVal reg_rel PtrKind)
+ gencode (CInitHdr cl_info reg_rel _ _)
+ = let
+ lhs = a2stix reg_rel
lbl = infoTableLabelFromCI cl_info
in
- returnSUs (\xs -> StAssign PtrKind lhs (StCLbl lbl) : xs)
+ returnUs (\xs -> StAssignMem PtrRep lhs (StCLbl lbl) : xs)
+
+\end{code}
+
+Heap/Stack Checks.
+
+\begin{code}
+
+ gencode (CCheck macro args assts)
+ = gencode assts `thenUs` \assts_stix ->
+ checkCode macro args assts_stix
\end{code}
produce. In most cases, the type of the assignment is determined
by the type of the destination. However, when the destination can
have mixed types, the type of the assignment is ``StgWord'' (we use
-PtrKind for lack of anything better). Think: do we also want a cast
+PtrRep for lack of anything better). Think: do we also want a cast
of the source? Be careful about floats/doubles.
\begin{code}
-genCodeAbsC target (CAssign lhs rhs)
- | getAmodeKind lhs == VoidKind = returnSUs id
- | otherwise =
- let pk = getAmodeKind lhs
- pk' = if mixedTypeLocn lhs && not (isFloatingKind pk) then IntKind else pk
- lhs' = amodeToStix target lhs
- rhs' = amodeToStix' target rhs
+ gencode (CAssign lhs rhs)
+ | lhs_rep == VoidRep
+ = returnUs id
+ | otherwise
+ = 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
- returnSUs (\xs -> StAssign pk' lhs' rhs' : xs)
+ returnUs (\xs -> mkStAssign pk' lhs' rhs' : xs)
+ where
+ lhs_rep = getAmodeRep lhs
\end{code}
Note that the new entry convention requires that we load the InfoPtr (R2)
with the address of the info table before jumping to the entry code for Node.
+For a vectored return, we must subtract the size of the info table to
+get at the return vector. This depends on the size of the info table,
+which varies depending on whether we're profiling etc.
+
\begin{code}
-genCodeAbsC target (CJump dest) =
- returnSUs (\xs -> StJump (amodeToStix target dest) : xs)
+ gencode (CJump dest)
+ = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
-genCodeAbsC target (CFallThrough (CLbl lbl _)) =
- returnSUs (\xs -> StFallThrough lbl : xs)
+ gencode (CFallThrough (CLbl lbl _))
+ = returnUs (\xs -> StFallThrough lbl : xs)
-genCodeAbsC target (CReturn dest DirectReturn) =
- returnSUs (\xs -> StJump (amodeToStix target dest) : xs)
+ gencode (CReturn dest DirectReturn)
+ = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
-genCodeAbsC target (CReturn table (StaticVectoredReturn n)) =
- returnSUs (\xs -> StJump dest : xs)
- where
- dest = StInd PtrKind (StIndex PtrKind (amodeToStix target table)
- (StInt (toInteger (-n-1))))
+ gencode (CReturn table (StaticVectoredReturn n))
+ = returnUs (\xs -> StJump NoDestInfo dest : xs)
+ where
+ dest = StInd PtrRep (StIndex PtrRep (a2stix table)
+ (StInt (toInteger (-n-retItblSize-1))))
-genCodeAbsC target (CReturn table (DynamicVectoredReturn am)) =
- returnSUs (\xs -> StJump dest : xs)
- where
- dest = StInd PtrKind (StIndex PtrKind (amodeToStix target table) dyn_off)
- dyn_off = StPrim IntSubOp [StPrim IntNegOp [amodeToStix target am], StInt 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 (retItblSize+1))]
\end{code}
Now the PrimOps, some of which may need caller-saves register wrappers.
\begin{code}
-
-genCodeAbsC target (COpStmt results op args liveness_mask vols)
- -- ToDo (ADR?): use that liveness mask
- | primOpNeedsWrapper op =
- let
- saves = volatileSaves target vols
- restores = volatileRestores target vols
- in
- primToStix target (nonVoid results) op (nonVoid args)
- `thenSUs` \ code ->
- returnSUs (\xs -> saves ++ code (restores ++ xs))
-
- | otherwise = primToStix target (nonVoid results) op (nonVoid args)
- where
- nonVoid = filter ((/= VoidKind) . getAmodeKind)
-
+ 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.
Now the if statement. Almost *all* flow of control are of this form.
@
if (am==lit) { absC } else { absCdef }
-@
+@
=>
@
IF am = lit GOTO l1:
- absC
+ absC
jump l2:
l1:
absCdef
\begin{code}
-genCodeAbsC target (CSwitch discrim alts deflt)
+ gencode (CSwitch discrim alts deflt)
= case alts of
- [] -> genCodeAbsC target deflt
+ [] -> gencode deflt
[(tag,alt_code)] -> case maybe_empty_deflt of
- Nothing -> genCodeAbsC target alt_code
- Just dc -> mkIfThenElse target discrim tag alt_code dc
+ 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 target discrim tag1 alt_code1 alt_code2
+ -> mkIfThenElse discrim tag1 alt_code1 alt_code2
| deflt_is_empty && i1 == 1 && i2 == 0
- -> mkIfThenElse target discrim tag2 alt_code2 alt_code1
-
+ -> mkIfThenElse discrim tag2 alt_code2 alt_code1
+
-- If the @discrim@ is simple, then this unfolding is safe.
- other | simple_discrim -> mkSimpleSwitches target discrim alts deflt
+ other | simple_discrim -> mkSimpleSwitches discrim alts deflt
-- Otherwise, we need to do a bit of work.
- other -> getSUnique `thenSUs` \ u ->
- genCodeAbsC target (AbsCStmts
- (CAssign (CTemp u pk) discrim)
- (CSwitch (CTemp u pk) alts deflt))
+ other -> getUniqueUs `thenUs` \ u ->
+ gencode (AbsCStmts
+ (CAssign (CTemp u pk) discrim)
+ (CSwitch (CTemp u pk) alts deflt))
where
maybe_empty_deflt = nonemptyAbsC deflt
Nothing -> True
Just _ -> False
- pk = getAmodeKind discrim
+ pk = getAmodeRep discrim
simple_discrim = case discrim of
CReg _ -> True
\begin{code}
-genCodeAbsC target (CMacroStmt macro args) = macroCode target macro args
+ gencode (CMacroStmt macro args) = macro_code macro args
-genCodeAbsC target (CCallProfCtrMacro macro _) =
- returnSUs (\xs -> StComment macro : xs)
+ gencode (CCallProfCtrMacro macro _)
+ = returnUs (\xs -> StComment macro : xs)
-genCodeAbsC target (CCallProfCCMacro macro _) =
- returnSUs (\xs -> StComment macro : xs)
+ gencode (CCallProfCCMacro macro _)
+ = returnUs (\xs -> StComment macro : xs)
-\end{code}
+ gencode CCallTypedef{} = returnUs id
-Here, we generate a jump table if there are more than four (integer) alternatives and
-the jump table occupancy is greater than 50%. Otherwise, we generate a binary
-comparison tree. (Perhaps this could be tuned.)
+ gencode other
+ = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
-\begin{code}
-
-intTag :: BasicLit -> Integer
-intTag (MachChar c) = toInteger (ord c)
-intTag (MachInt i _) = i
-intTag _ = panic "intTag"
-
-fltTag :: BasicLit -> Rational
+ nonVoid = filter ((/= VoidRep) . getAmodeRep)
+\end{code}
-fltTag (MachFloat f) = f
-fltTag (MachDouble d) = d
-fltTag _ = panic "fltTag"
+Here, we generate a jump table if there are more than four (integer)
+alternatives and the jump table occupancy is greater than 50%.
+Otherwise, we generate a binary comparison tree. (Perhaps this could
+be tuned.)
-mkSimpleSwitches
- :: Target
- -> CAddrMode -> [(BasicLit,AbstractC)] -> AbstractC
- -> SUniqSM StixTreeList
+\begin{code}
-mkSimpleSwitches target am alts absC =
- getUniqLabelNCG `thenSUs` \ udlbl ->
- getUniqLabelNCG `thenSUs` \ ujlbl ->
- let am' = amodeToStix target am
+ intTag :: Literal -> Integer
+ intTag (MachChar c) = toInteger c
+ intTag (MachInt i) = i
+ intTag (MachWord w) = intTag (word2IntLit (MachWord w))
+ intTag _ = panic "intTag"
+
+ fltTag :: Literal -> Rational
+
+ fltTag (MachFloat f) = f
+ fltTag (MachDouble d) = d
+ fltTag x = pprPanic "fltTag" (ppr x)
+
+ {-
+ mkSimpleSwitches
+ :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
+ -> UniqSM StixTreeList
+ -}
+ mkSimpleSwitches am alts absC
+ = getUniqLabelNCG `thenUs` \ udlbl ->
+ getUniqLabelNCG `thenUs` \ ujlbl ->
+ let am' = a2stix am
joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
sortedAlts = naturalMergeSortLe leAlt joinedAlts
-- naturalMergeSortLe, because we often get sorted alts to begin with
-- lowest and highest possible values the discriminant could take
lowest = if floating then targetMinDouble else targetMinInt
highest = if floating then targetMaxDouble else targetMaxInt
-
- -- These should come from somewhere else, depending on the target arch
- -- (Note that the floating point values aren't terribly important.)
- -- ToDo: Fix!(JSM)
- targetMinDouble = MachDouble (-1.7976931348623157e+308)
- targetMaxDouble = MachDouble (1.7976931348623157e+308)
- targetMinInt = mkMachInt (-2147483647)
- targetMaxInt = mkMachInt 2147483647
in
(
- if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
- mkJumpTable target am' sortedAlts lowTag highTag udlbl
+ if not floating && choices > 4
+ && highTag - lowTag < toInteger (2 * choices)
+ then
+ mkJumpTable am' sortedAlts lowTag highTag udlbl
else
- mkBinaryTree target am' floating sortedAlts choices lowest highest udlbl
+ mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
)
- `thenSUs` \ alt_code ->
- genCodeAbsC target absC `thenSUs` \ dflt_code ->
+ `thenUs` \ alt_code ->
+ gencode absC `thenUs` \ dflt_code ->
- returnSUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
+ returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
where
- floating = isFloatingKind (getAmodeKind am)
+ floating = isFloatingRep (getAmodeRep am)
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}
-We use jump tables when doing an integer switch on a relatively dense list of
-alternatives. We expect to be given a list of alternatives, sorted by tag,
-and a range of values for which we are to generate a table. Of course, the tags of
-the alternatives should lie within the indicated range. The alternatives need
-not cover the range; a default target is provided for the missing alternatives.
+We use jump tables when doing an integer switch on a relatively dense
+list of alternatives. We expect to be given a list of alternatives,
+sorted by tag, and a range of values for which we are to generate a
+table. Of course, the tags of the alternatives should lie within the
+indicated range. The alternatives need not cover the range; a default
+target is provided for the missing alternatives.
-If a join is necessary after the switch, the alternatives should already finish
-with a jump to the join point.
+If a join is necessary after the switch, the alternatives should
+already finish with a jump to the join point.
\begin{code}
-
-mkJumpTable
- :: Target
- -> StixTree -- discriminant
- -> [(BasicLit, AbstractC)] -- alternatives
+ {-
+ mkJumpTable
+ :: StixTree -- discriminant
+ -> [(Literal, AbstractC)] -- alternatives
-> Integer -- low tag
-> Integer -- high tag
-> CLabel -- default label
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
+ -}
-mkJumpTable target am alts lowTag highTag dflt =
- getUniqLabelNCG `thenSUs` \ utlbl ->
- mapSUs genLabel alts `thenSUs` \ branches ->
- let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt lowTag])
- cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt highTag])
+ mkJumpTable am alts lowTag highTag dflt
+ = getUniqLabelNCG `thenUs` \ utlbl ->
+ mapUs genLabel alts `thenUs` \ branches ->
+ 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]
- jump = StJump (StInd PtrKind (StIndex PtrKind (StCLbl utlbl) offset))
+ offset = StMachOp MO_Nat_Sub [am, StInt lowTag]
+ dsts = DestInfo (dflt : map fst branches)
+ jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
tlbl = StLabel utlbl
- table = StData PtrKind (mkTable branches [lowTag..highTag] [])
- in
- mapSUs mkBranch branches `thenSUs` \ alts ->
+ table = StData PtrRep (mkTable branches [lowTag..highTag] [])
+ in
+ mapUs mkBranch branches `thenUs` \ alts ->
- returnSUs (\xs -> cjmpLo : cjmpHi : jump :
- StSegment DataSegment : tlbl : table :
- StSegment TextSegment : foldr1 (.) alts xs)
+ returnUs (\xs -> cjmpLo : cjmpHi : jump :
+ StSegment DataSegment : tlbl : table :
+ StSegment TextSegment : foldr1 (.) alts xs)
where
- genLabel x = getUniqLabelNCG `thenSUs` \ lbl -> returnSUs (lbl, x)
+ genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
mkBranch (lbl,(_,alt)) =
- genCodeAbsC target alt `thenSUs` \ alt_code ->
- returnSUs (\xs -> StLabel lbl : alt_code xs)
+ gencode alt `thenUs` \ alt_code ->
+ returnUs (\xs -> StLabel lbl : alt_code xs)
mkTable _ [] tbl = reverse tbl
mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
so long as they are not mixed. (We assume that the type of the discriminant
determines the type of the alternatives.)
-As with the jump table approach, if a join is necessary after the switch, the
+As with the jump table approach, if a join is necessary after the switch, the
alternatives should already finish with a jump to the join point.
\begin{code}
-
-mkBinaryTree
- :: Target
- -> StixTree -- discriminant
+ {-
+ mkBinaryTree
+ :: StixTree -- discriminant
-> Bool -- floating point?
- -> [(BasicLit, AbstractC)] -- alternatives
+ -> [(Literal, AbstractC)] -- alternatives
-> Int -- number of choices
- -> BasicLit -- low tag
- -> BasicLit -- high tag
+ -> Literal -- low tag
+ -> Literal -- high tag
-> CLabel -- default code label
- -> SUniqSM StixTreeList
-
-mkBinaryTree target am floating [(tag,alt)] _ lowTag highTag udlbl
- | rangeOfOne = genCodeAbsC target alt
- | otherwise =
- let tag' = amodeToStix target (CLit tag)
- cmpOp = if floating then DoubleNeOp else IntNeOp
- test = StPrim cmpOp [am, tag']
+ -> UniqSM StixTreeList
+ -}
+
+ mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
+ | rangeOfOne = gencode alt
+ | otherwise
+ = let tag' = a2stix (CLit tag)
+ cmpOp = if floating then MO_Dbl_Ne else MO_Nat_Ne
+ test = StMachOp cmpOp [am, tag']
cjmp = StCondJump udlbl test
in
- genCodeAbsC target alt `thenSUs` \ alt_code ->
- returnSUs (\xs -> cjmp : alt_code xs)
+ gencode alt `thenUs` \ alt_code ->
+ returnUs (\xs -> cjmp : alt_code xs)
- where
+ where
rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
-- When there is only one possible tag left in range, we skip the comparison
-mkBinaryTree target am floating alts choices lowTag highTag udlbl =
- getUniqLabelNCG `thenSUs` \ uhlbl ->
- let tag' = amodeToStix target (CLit splitTag)
- cmpOp = if floating then DoubleGeOp else IntGeOp
- test = StPrim cmpOp [am, tag']
+ mkBinaryTree am floating alts choices lowTag highTag udlbl
+ = getUniqLabelNCG `thenUs` \ uhlbl ->
+ let tag' = a2stix (CLit splitTag)
+ cmpOp = if floating then MO_Dbl_Ge else MO_NatS_Ge
+ test = StMachOp cmpOp [am, tag']
cjmp = StCondJump uhlbl test
in
- mkBinaryTree target am floating alts_lo half lowTag splitTag udlbl
- `thenSUs` \ lo_code ->
- mkBinaryTree target am floating alts_hi (choices - half) splitTag highTag udlbl
- `thenSUs` \ hi_code ->
+ mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
+ `thenUs` \ lo_code ->
+ mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
+ `thenUs` \ hi_code ->
- returnSUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
+ returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
where
half = choices `div` 2
\end{code}
\begin{code}
-
-mkIfThenElse
- :: Target
- -> CAddrMode -- discriminant
- -> BasicLit -- tag
+ {-
+ mkIfThenElse
+ :: CAddrMode -- discriminant
+ -> Literal -- tag
-> AbstractC -- if-part
-> AbstractC -- else-part
- -> SUniqSM StixTreeList
-
-mkIfThenElse target discrim tag alt deflt =
- getUniqLabelNCG `thenSUs` \ ujlbl ->
- getUniqLabelNCG `thenSUs` \ utlbl ->
- let discrim' = amodeToStix target discrim
- tag' = amodeToStix target (CLit tag)
- cmpOp = if (isFloatingKind (getAmodeKind discrim)) then DoubleNeOp else IntNeOp
- test = StPrim cmpOp [discrim', tag']
+ -> UniqSM StixTreeList
+ -}
+
+ mkIfThenElse discrim tag alt deflt
+ = getUniqLabelNCG `thenUs` \ ujlbl ->
+ getUniqLabelNCG `thenUs` \ utlbl ->
+ let discrim' = a2stix discrim
+ tag' = a2stix (CLit 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
in
- genCodeAbsC target (mkJoin alt ujlbl) `thenSUs` \ alt_code ->
- genCodeAbsC target deflt `thenSUs` \ dflt_code ->
- returnSUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
+ gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
+ gencode deflt `thenUs` \ dflt_code ->
+ returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
-mkJoin :: AbstractC -> CLabel -> AbstractC
-mkJoin code lbl
- | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrKind))
+mkJoin :: AbstractC -> CLabel -> AbstractC
+mkJoin code lbl
+ | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
| otherwise = code
+\end{code}
+
+%---------------------------------------------------------------------------
+\begin{code}
+bitmapToIntegers :: [BitSet] -> [Integer]
+bitmapToIntegers = bundle . map (toInteger . intBS)
+ where
+#if BYTES_PER_WORD == 4
+ bundle = id
+#else
+ bundle [] = []
+ bundle is = case splitAt (BYTES_PER_WORD/4) is of
+ (these, those) ->
+ ( foldr1 (\x y -> x + 4294967296 * y)
+ [x `mod` 4294967296 | x <- these]
+ : bundle those
+ )
+#endif
\end{code}
%---------------------------------------------------------------------------
ft (CJump _) if_empty = False
ft (CReturn _ _) if_empty = False
- ft (CSwitch _ alts deflt) if_empty
+ ft (CSwitch _ alts deflt) if_empty
= ft deflt if_empty ||
or [ft alt if_empty | (_,alt) <- alts]
ft _ if_empty = if_empty
{- Old algorithm, which called nonemptyAbsC for every subexpression! =========
-fallThroughAbsC (AbsCStmts c1 c2) =
- case nonemptyAbsC c2 of
+fallThroughAbsC (AbsCStmts c1 c2)
+ = case nonemptyAbsC c2 of
Nothing -> fallThroughAbsC c1
Just x -> fallThroughAbsC x
fallThroughAbsC (CJump _) = False
isEmptyAbsC = not . maybeToBool . nonemptyAbsC
================= End of old, quadratic, algorithm -}
\end{code}
-
-Vector tables are trivial!
-
-\begin{code}
-
-genCodeVecTbl
- :: Target
- -> AbstractC
- -> SUniqSM StixTreeList
-
-genCodeVecTbl target (CFlatRetVector label amodes) =
- returnSUs (\xs -> vectbl : xs)
- where
- vectbl = StData PtrKind (reverse (map (amodeToStix target) amodes))
-
-\end{code}
-
-Static closures are not so hard either.
-
-\begin{code}
-
-genCodeStaticClosure
- :: Target
- -> AbstractC
- -> SUniqSM StixTreeList
-
-genCodeStaticClosure target (CStaticClosure _ cl_info cost_centre amodes) =
- returnSUs (\xs -> table : xs)
- where
- table = StData PtrKind (StCLbl info_lbl : body)
- info_lbl = infoTableLabelFromCI cl_info
-
- body = if closureUpdReqd cl_info then
- take (max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
- else
- amodes'
-
- zeros = StInt 0 : zeros
-
- amodes' = map amodeZeroVoid amodes
-
- -- Watch out for VoidKinds...cf. PprAbsC
- amodeZeroVoid item
- | getAmodeKind item == VoidKind = StInt 0
- | otherwise = amodeToStix target item
-
-\end{code}
-
projects / ghc-hetmet.git / blobdiff