%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CLabel.lhs,v 1.34 2000/05/15 15:03:36 simonmar Exp $
+% $Id: CLabel.lhs,v 1.35 2000/05/18 13:55:36 sewardj Exp $
%
\section[CLabel]{@CLabel@: Information to make C Labels}
mkModuleInitLabel,
mkErrorStdEntryLabel,
+
+ mkStgUpdatePAPLabel,
mkUpdInfoLabel,
+ mkSeqInfoLabel,
+ mkIndInfoLabel,
+ mkIndStaticInfoLabel,
+ mkRtsGCEntryLabel,
+ mkMainRegTableLabel,
+ mkCharlikeClosureLabel,
+ mkIntlikeClosureLabel,
+ mkTopClosureLabel,
+ mkErrorIO_innardsLabel,
+ mkMAP_FROZEN_infoLabel,
+
mkTopTickyCtrLabel,
mkBlackHoleInfoTableLabel,
mkCAFBlackHoleInfoTableLabel,
| RtsBlackHoleInfoTbl FAST_STRING -- black hole with info table name
- | RtsUpdInfo
+ | RtsUpdInfo -- upd_frame_info
+ | RtsSeqInfo -- seq_frame_info
+ | RtsGCEntryLabel String -- a heap check fail handler, eg stg_chk_2
+ | RtsMainRegTable -- MainRegTable (??? Capabilities wurble ???)
+ | Rts_Closure String -- misc rts closures, eg CHARLIKE_closure
+ | Rts_Info String -- misc rts itbls, eg MUT_ARR_PTRS_FROZEN_info
+ | Rts_Code String -- misc rts code, eg ErrorIO_innards
| RtsSelectorInfoTbl Bool{-updatable-} Int{-offset-} -- Selector thunks
| RtsSelectorEntry Bool{-updatable-} Int{-offset-}
-- Some fixed runtime system labels
mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
+
+mkStgUpdatePAPLabel = RtsLabel (Rts_Code "stg_update_PAP")
mkUpdInfoLabel = RtsLabel RtsUpdInfo
+mkSeqInfoLabel = RtsLabel RtsSeqInfo
+mkIndInfoLabel = RtsLabel (Rts_Info "IND_info")
+mkIndStaticInfoLabel = RtsLabel (Rts_Info "IND_STATIC_info")
+mkRtsGCEntryLabel str = RtsLabel (RtsGCEntryLabel str)
+mkMainRegTableLabel = RtsLabel RtsMainRegTable
+mkCharlikeClosureLabel = RtsLabel (Rts_Closure "CHARLIKE_closure")
+mkIntlikeClosureLabel = RtsLabel (Rts_Closure "INTLIKE_closure")
+mkTopClosureLabel = RtsLabel (Rts_Closure "TopClosure")
+mkErrorIO_innardsLabel = RtsLabel (Rts_Code "ErrorIO_innards")
+mkMAP_FROZEN_infoLabel = RtsLabel (Rts_Info "MUT_ARR_PTRS_FROZEN_info")
+
mkTopTickyCtrLabel = RtsLabel RtsTopTickyCtr
mkBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("BLACKHOLE_info"))
mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("CAF_BLACKHOLE_info"))
pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("stg_error_entry")
-pprCLbl (RtsLabel RtsUpdInfo) = ptext SLIT("upd_frame_info")
+pprCLbl (RtsLabel RtsUpdInfo) = ptext SLIT("upd_frame_info")
+pprCLbl (RtsLabel RtsSeqInfo) = ptext SLIT("seq_frame_info")
+pprCLbl (RtsLabel RtsMainRegTable) = ptext SLIT("MainRegTable")
+pprCLbl (RtsLabel (RtsGCEntryLabel str)) = text str
+pprCLbl (RtsLabel (Rts_Closure str)) = text str
+pprCLbl (RtsLabel (Rts_Info str)) = text str
+pprCLbl (RtsLabel (Rts_Code str)) = text str
pprCLbl (RtsLabel RtsTopTickyCtr) = ptext SLIT("top_ct")
import Constants ( mIN_UPD_SIZE )
import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
mkClosureTblLabel, mkClosureLabel,
- moduleRegdLabel )
+ moduleRegdLabel, labelDynamic )
import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
fastLabelFromCI, closureUpdReqd,
staticClosureNeedsLink
import BitSet ( intBS )
import Name ( NamedThing(..) )
import Char ( ord )
+import CmdLineOpts ( opt_Static )
\end{code}
For each independent chunk of AbstractC code, we generate a list of
gentopcode stmt@(CStaticClosure lbl _ _ _)
= genCodeStaticClosure stmt `thenUs` \ code ->
- returnUs (StSegment DataSegment : StLabel lbl : 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 ->
gentopcode stmt@(CSRT lbl closures)
= returnUs [ StSegment TextSegment
, StLabel lbl
- , StData DataPtrRep (map StCLbl closures)
+ , StData DataPtrRep (map mk_StCLbl_for_SRT closures)
]
+ where
+ mk_StCLbl_for_SRT :: CLabel -> StixTree
+ mk_StCLbl_for_SRT label
+ | labelDynamic label
+ = StIndex CharRep (StCLbl label) (StInt 1)
+ | otherwise
+ = StCLbl label
gentopcode stmt@(CBitmap lbl mask)
= returnUs [ StSegment TextSegment
gentopcode stmt@(CModuleInitBlock lbl absC)
= gencode absC `thenUs` \ code ->
getUniqLabelNCG `thenUs` \ tmp_lbl ->
+ getUniqLabelNCG `thenUs` \ flag_lbl ->
returnUs ( StSegment DataSegment
- : StLabel moduleRegdLabel
+ : StLabel flag_lbl
: StData IntRep [StInt 0]
: StSegment TextSegment
: StLabel lbl
: StCondJump tmp_lbl (StPrim IntNeOp
- [StInd IntRep (StCLbl moduleRegdLabel),
+ [StInd IntRep (StCLbl flag_lbl),
StInt 0])
- : StAssign IntRep (StInd IntRep (StCLbl moduleRegdLabel)) (StInt 1)
+ : StAssign IntRep (StInd IntRep (StCLbl flag_lbl)) (StInt 1)
: code
[ StLabel tmp_lbl
- , StAssign PtrRep stgSp (StPrim IntSubOp [stgSp, StInt 4])
+ , StAssign PtrRep stgSp
+ (StIndex PtrRep stgSp (StInt (-1)))
, StJump (StInd WordRep stgSp)
])
import PrimOp ( commutableOp, PrimOp(..) )
import RegAllocInfo ( mkMRegsState, MRegsState, findReservedRegs )
import Stix ( StixTree(..), StixReg(..),
- pprStixTrees, ppStixTree, CodeSegment(..),
+ pprStixTrees, pprStixTree, CodeSegment(..),
stixCountTempUses, stixSubst,
NatM, initNat, mapNat,
NatM_State, mkNatM_State,
: ts )
| stixCountTempUses u t2 == 1
&& sum (map (stixCountTempUses u) ts) == 0
- = trace ("nativeGen: stixInline: " ++ showSDoc (ppStixTree rhs))
+ = trace ("nativeGen: stixInline: " ++ showSDoc (pprStixTree rhs))
(stixPeep (stixSubst u rhs t2 : ts))
stixPeep (t1:t2:ts) = t1 : stixPeep (t2:ts)
noFuture instrs_patched of
((RH _ mloc2 _),_,instrs'')
-- successfully allocated the patched code
- | mloc2 == mloc1 -> trace (spillMsg True) (Just instrs'')
+ | mloc2 == mloc1 -> maybetrace (spillMsg True) (Just instrs'')
-- no; we have to give up
- | otherwise -> trace (spillMsg False) Nothing
+ | otherwise -> maybetrace (spillMsg False) Nothing
-- instrs''
where
regs' = regs `useMRegs` reserve_regs
(reverse reserve_regs)))
where
toMappedReg (I# i) = MappedReg i
+#ifdef DEBUG
+ maybetrace msg x = trace msg x
+#else
+ maybetrace msg x = x
+#endif
+
\end{code}
Here we patch instructions that reference ``registers'' which are
import AbsCSyn ( MagicId )
import AbsCUtils ( magicIdPrimRep )
import CallConv ( CallConv )
-import CLabel ( isAsmTemp, CLabel, pprCLabel_asm )
+import CLabel ( isAsmTemp, CLabel, pprCLabel_asm, labelDynamic )
import Maybes ( maybeToBool, expectJust )
import PrimRep ( isFloatingRep, PrimRep(..) )
import PrimOp ( PrimOp(..) )
import CallConv ( cCallConv )
import Stix ( getNatLabelNCG, StixTree(..),
StixReg(..), CodeSegment(..),
- pprStixTrees, ppStixReg,
+ pprStixTree, ppStixReg,
NatM, thenNat, returnNat, mapNat,
mapAndUnzipNat, mapAccumLNat,
getDeltaNat, setDeltaNat
)
import Outputable
+import CmdLineOpts ( opt_Static )
infixr 3 `bind`
StLabel lab -> returnNat (unitOL (LABEL lab))
- StJump arg -> genJump arg
- StCondJump lab arg -> genCondJump lab arg
- StCall fn cconv VoidRep args -> genCCall fn cconv VoidRep args
+ StJump arg -> genJump (derefDLL arg)
+ StCondJump lab arg -> genCondJump lab (derefDLL arg)
+
+ -- A call returning void, ie one done for its side-effects
+ StCall fn cconv VoidRep args -> genCCall fn
+ cconv VoidRep (map derefDLL args)
StAssign pk dst src
- | isFloatingRep pk -> assignFltCode pk dst src
- | otherwise -> assignIntCode pk dst src
+ | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
+ | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
StFallThrough lbl
-- When falling through on the Alpha, we still have to load pv
where
getData :: StixTree -> NatM (InstrBlock, Imm)
- getData (StInt i) = returnNat (nilOL, ImmInteger i)
- getData (StDouble d) = returnNat (nilOL, ImmDouble d)
- getData (StLitLbl s) = returnNat (nilOL, ImmLab s)
- getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
- getData (StString s) =
+ getData (StInt i) = returnNat (nilOL, ImmInteger i)
+ getData (StDouble d) = returnNat (nilOL, ImmDouble d)
+ getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
+ getData (StString s) =
getNatLabelNCG `thenNat` \ lbl ->
returnNat (toOL [LABEL lbl,
ASCII True (_UNPK_ s)],
getData (StIndex rep (StCLbl lbl) (StInt off)) =
returnNat (nilOL,
ImmIndex lbl (fromInteger (off * sizeOf rep)))
+
+-- Walk a Stix tree, and insert dereferences to CLabels which are marked
+-- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
+-- not all such CLabel occurrences need this dereferencing -- SRTs don't
+-- for one.
+derefDLL :: StixTree -> StixTree
+derefDLL tree
+ | opt_Static -- short out the entire deal if not doing DLLs
+ = tree
+ | otherwise
+ = qq tree
+ where
+ qq t
+ = case t of
+ StCLbl lbl -> if labelDynamic lbl
+ then StInd PtrRep (StCLbl lbl)
+ else t
+ -- all the rest are boring
+ StIndex pk base offset -> StIndex pk (qq base) (qq offset)
+ StPrim pk args -> StPrim pk (map qq args)
+ StInd pk addr -> StInd pk (qq addr)
+ StCall who cc pk args -> StCall who cc pk (map qq args)
+ StInt _ -> t
+ StDouble _ -> t
+ StString _ -> t
+ StReg _ -> t
+ StScratchWord _ -> t
+ _ -> pprPanic "derefDLL: unhandled case"
+ (pprStixTree t)
\end{code}
%************************************************************************
\begin{code}
maybeImm :: StixTree -> Maybe Imm
-maybeImm (StLitLbl s) = Just (ImmLab s)
-maybeImm (StCLbl l) = Just (ImmCLbl l)
-
-maybeImm (StIndex rep (StCLbl l) (StInt off)) =
- Just (ImmIndex l (fromInteger (off * sizeOf rep)))
-
+maybeImm (StCLbl l)
+ = Just (ImmCLbl l)
+maybeImm (StIndex rep (StCLbl l) (StInt off))
+ = Just (ImmIndex l (fromInteger (off * sizeOf rep)))
maybeImm (StInt i)
| i >= toInteger minInt && i <= toInteger maxInt
= Just (ImmInt (fromInteger i))
| d == 0.0
= let code dst = unitOL (GLDZ dst)
- in trace "nativeGen: GLDZ"
- (returnNat (Any DoubleRep code))
+ in returnNat (Any DoubleRep code)
| d == 1.0
= let code dst = unitOL (GLD1 dst)
- in trace "nativeGen: GLD1"
- returnNat (Any DoubleRep code)
+ in returnNat (Any DoubleRep code)
| otherwise
= getNatLabelNCG `thenNat` \ lbl ->
other
-> pprPanic "getRegister(x86,unary primop)"
- (pprStixTrees [StPrim primop [x]])
+ (pprStixTree (StPrim primop [x]))
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
[x, y])
other
-> pprPanic "getRegister(x86,dyadic primop)"
- (pprStixTrees [StPrim primop [x, y]])
+ (pprStixTree (StPrim primop [x, y]))
where
--------------------
in
returnNat (Any PtrRep code)
| otherwise
- = pprPanic "getRegister(x86)" (pprStixTrees [leaf])
+ = pprPanic "getRegister(x86)" (pprStixTree leaf)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
-- ToDo:needed (WDP 96/03) ???
fn__2 = case (_HEAD_ fn) of
'.' -> ImmLit (ptext fn)
- _ -> ImmLab (ptext fn)
+ _ -> ImmLab False (ptext fn)
arg_size DF = 8
arg_size F = 8
fmtAsmLbl,
exactLog2,
- stixFor_stdout, stixFor_stderr, stixFor_stdin,
-
Instr(..), IF_ARCH_i386(Operand(..) COMMA,)
Cond(..),
Size(..),
,{-otherwise-}
'.':'L':s
)
-
----------------------------
-stixFor_stdout, stixFor_stderr, stixFor_stdin :: StixTree
-#if i386_TARGET_ARCH
--- Linux glibc 2 / libc6
-stixFor_stdout = StInd PtrRep (StLitLbl (text "stdout"))
-stixFor_stderr = StInd PtrRep (StLitLbl (text "stderr"))
-stixFor_stdin = StInd PtrRep (StLitLbl (text "stdin"))
-#endif
-
-#if alpha_TARGET_ARCH
-stixFor_stdout = error "stixFor_stdout: not implemented for Alpha"
-stixFor_stderr = error "stixFor_stderr: not implemented for Alpha"
-stixFor_stdin = error "stixFor_stdin: not implemented for Alpha"
-#endif
-
-#if sparc_TARGET_ARCH
-stixFor_stdout = error "stixFor_stdout: not implemented for Sparc"
-stixFor_stderr = error "stixFor_stderr: not implemented for Sparc"
-stixFor_stdin = error "stixFor_stdin: not implemented for Sparc"
-#endif
-
-#if 0
-Here's some old stuff from which it shouldn't be too hard to
-implement the above for Alpha/Sparc.
-
-cvtLitLit :: String -> String
-
---
--- Rather than relying on guessing, use FILE_SIZE to compute the
--- _iob offsets.
---
-cvtLitLit "stdin" = IF_ARCH_alpha("_iob+0" {-probably OK...-}
- ,IF_ARCH_i386("stdin"
- ,IF_ARCH_sparc("__iob+0x0"{-probably OK...-}
- ,)))
-
-cvtLitLit "stdout" = IF_ARCH_alpha("_iob+"++show (``FILE_SIZE''::Int)
- ,IF_ARCH_i386("stdout"
- ,IF_ARCH_sparc("__iob+"++show (``FILE_SIZE''::Int)
- ,)))
-cvtLitLit "stderr" = IF_ARCH_alpha("_iob+"++show (2*(``FILE_SIZE''::Int))
- ,IF_ARCH_i386("stderr"
- ,IF_ARCH_sparc("__iob+"++show (2*(``FILE_SIZE''::Int))
- ,)))
-#endif
-
\end{code}
% ----------------------------------------------------------------
import AbsCSyn ( MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
-import CLabel ( CLabel )
+import CLabel ( CLabel, mkMainRegTableLabel )
import PrimOp ( PrimOp(..) )
import PrimRep ( PrimRep(..) )
-import Stix ( sStLitLbl, StixTree(..), StixReg(..),
+import Stix ( StixTree(..), StixReg(..),
getUniqueNat, returnNat, thenNat, NatM )
import Unique ( mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
Uniquable(..), Unique
= ImmInt Int
| ImmInteger Integer -- Sigh.
| ImmCLbl CLabel -- AbstractC Label (with baggage)
- | ImmLab SDoc -- Simple string label (underscore-able)
+ | ImmLab Bool SDoc -- Simple string label (underscore-able)
+ -- Bool==True ==> in a different DLL
| ImmLit SDoc -- Simple string
| ImmIndex CLabel Int
| ImmDouble Rational
-----------------
largeOffsetError i
- = error ("ERROR: SPARC native-code generator cannot handle large offset ("++show i++");\nprobably because of large constant data structures;\nworkaround: use -fvia-C on this module.\n")
+ = error ("ERROR: SPARC native-code generator cannot handle large offset ("
+ ++show i++");\nprobably because of large constant data structures;" ++
+ "\nworkaround: use -fvia-C on this module.\n")
#endif {-sparc-}
\end{code}
baseLoc = case (magicIdRegMaybe BaseReg) of
Just _ -> StReg (StixMagicId BaseReg)
- Nothing -> sStLitLbl SLIT("MainRegTable")
+ Nothing -> StCLbl mkMainRegTableLabel
nonReg = case x of
- BaseReg -> sStLitLbl SLIT("MainRegTable")
+ BaseReg -> StCLbl mkMainRegTableLabel
_ -> StInd (magicIdPrimRep x)
(StPrim IntAddOp [baseLoc,
import MachRegs -- may differ per-platform
import MachMisc
-import CLabel ( pprCLabel_asm, externallyVisibleCLabel )
+import CLabel ( pprCLabel_asm, externallyVisibleCLabel, labelDynamic )
import CStrings ( charToC )
import Maybes ( maybeToBool )
import Stix ( CodeSegment(..), StixTree(..) )
pprImm (ImmInt i) = int i
pprImm (ImmInteger i) = integer i
-pprImm (ImmCLbl l) = pprCLabel_asm l
-pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
+pprImm (ImmCLbl l) = (if labelDynamic l then text "__imp_" else empty)
+ <> pprCLabel_asm l
+pprImm (ImmIndex l i) = (if labelDynamic l then text "__imp_" else empty)
+ <> pprCLabel_asm l <> char '+' <> int i
pprImm (ImmLit s) = s
-pprImm (ImmLab s) | underscorePrefix = (<>) (char '_') s
- | otherwise = s
+pprImm (ImmLab dll s) = (if underscorePrefix then char '_' else empty)
+ <> (if dll then text "_imp__" else empty)
+ <> s
#if sparc_TARGET_ARCH
pprImm (LO i)
\begin{code}
module Stix (
CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
- sStLitLbl, pprStixTrees, ppStixTree, ppStixReg,
+ pprStixTrees, pprStixTree, ppStixReg,
stixCountTempUses, stixSubst,
stgBaseReg, stgNode, stgSp, stgSu, stgSpLim,
import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply,
UniqSM, thenUs, returnUs, getUniqueUs )
+import CmdLineOpts ( opt_Static )
import Outputable
\end{code}
| StInt Integer -- ** add Kind at some point
| StDouble Rational
| StString FAST_STRING
- | StLitLbl SDoc -- literal labels
- -- (will be _-prefixed on some machines)
-
| StCLbl CLabel -- labels that we might index into
-- Abstract registers of various kinds
| StComment FAST_STRING
-sStLitLbl :: FAST_STRING -> StixTree
-sStLitLbl s = StLitLbl (ptext s)
-
pprStixTrees :: [StixTree] -> SDoc
pprStixTrees ts
= vcat [
- vcat (map ppStixTree ts),
+ vcat (map pprStixTree ts),
char ' ',
char ' '
]
paren t = char '(' <> t <> char ')'
-ppStixTree :: StixTree -> SDoc
-ppStixTree t
+pprStixTree :: StixTree -> SDoc
+pprStixTree t
= case t of
StSegment cseg -> paren (ppCodeSegment cseg)
StInt i -> paren (integer i)
StDouble rat -> paren (text "Double" <+> rational rat)
StString str -> paren (text "Str" <+> ptext str)
StComment str -> paren (text "Comment" <+> ptext str)
- StLitLbl sd -> sd
StCLbl lbl -> pprCLabel lbl
StReg reg -> ppStixReg reg
- StIndex k b o -> paren (ppStixTree b <+> char '+' <>
- pprPrimRep k <+> ppStixTree o)
- StInd k t -> pprPrimRep k <> char '[' <> ppStixTree t <> char ']'
- StAssign k d s -> ppStixTree d <> text " :=" <> pprPrimRep k
- <> text " " <> ppStixTree s
+ StIndex k b o -> paren (pprStixTree b <+> char '+' <>
+ pprPrimRep k <+> pprStixTree o)
+ StInd k t -> pprPrimRep k <> char '[' <> pprStixTree t <> char ']'
+ StAssign k d s -> pprStixTree d <> text " :=" <> pprPrimRep k
+ <> text " " <> pprStixTree s
StLabel ll -> pprCLabel ll <+> char ':'
StFunBegin ll -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll)
StFunEnd ll -> paren (text "FunEnd" <+> pprCLabel ll)
- StJump t -> paren (text "Jump" <+> ppStixTree t)
+ StJump t -> paren (text "Jump" <+> pprStixTree t)
StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll)
StCondJump l t -> paren (text "JumpC" <+> pprCLabel l
- <+> ppStixTree t)
+ <+> pprStixTree t)
StData k ds -> paren (text "Data" <+> pprPrimRep k <+>
- hsep (map ppStixTree ds))
+ hsep (map pprStixTree ds))
StPrim op ts -> paren (text "Prim" <+> pprPrimOp op <+>
- hsep (map ppStixTree ts))
+ hsep (map pprStixTree ts))
StCall nm cc k args
-> paren (text "Call" <+> ptext nm <+>
pprCallConv cc <+> pprPrimRep k <+>
- hsep (map ppStixTree args))
+ hsep (map pprStixTree args))
StScratchWord i -> text "ScratchWord" <> paren (int i)
pprPrimRep = text . showPrimRep
StInt _ -> 0
StDouble _ -> 0
StString _ -> 0
- StLitLbl _ -> 0
StCLbl _ -> 0
StLabel _ -> 0
StFunBegin _ -> 0
StInt _ -> t
StDouble _ -> t
StString _ -> t
- StLitLbl _ -> t
StCLbl _ -> t
StLabel _ -> t
StFunBegin _ -> t
import PrimOp ( PrimOp(..) )
import PrimRep ( PrimRep(..) )
import SMRep ( arrWordsHdrSize )
-import Stix ( sStLitLbl, StixTree(..), StixTreeList, arrWordsHS )
+import Stix ( StixTree(..), StixTreeList, arrWordsHS )
import UniqSupply ( returnUs, thenUs, UniqSM )
\end{code}
import Stix
import UniqSupply ( returnUs, thenUs, UniqSM )
import Outputable
+import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
+ mkIndInfoLabel, mkUpdInfoLabel, mkSeqInfoLabel,
+ mkRtsGCEntryLabel, mkStgUpdatePAPLabel )
\end{code}
The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
bh_info, ind_static_info, ind_info :: StixTree
-bh_info = sStLitLbl SLIT("BLACKHOLE_info")
-ind_static_info = sStLitLbl SLIT("IND_STATIC_info")
-ind_info = sStLitLbl SLIT("IND_info")
-upd_frame_info = sStLitLbl SLIT("upd_frame_info")
-seq_frame_info = sStLitLbl SLIT("seq_frame_info")
-
+bh_info = StCLbl mkBlackHoleInfoTableLabel
+ind_static_info = StCLbl mkIndStaticInfoLabel
+ind_info = StCLbl mkIndInfoLabel
+upd_frame_info = StCLbl mkUpdInfoLabel
+seq_frame_info = StCLbl mkSeqInfoLabel
+stg_update_PAP = StCLbl mkStgUpdatePAPLabel
-- Some common call trees
updatePAP, stackOverflow :: StixTree
-updatePAP = StJump (sStLitLbl SLIT("stg_update_PAP"))
+updatePAP = StJump stg_update_PAP
stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
\end{code}
-- Various canned heap-check routines
-gc_chk (StInt n) = StJump (StLitLbl (ptext SLIT("stg_chk_")
- <> int (fromInteger n)))
-gc_enter (StInt n) = StJump (StLitLbl (ptext SLIT("stg_gc_enter_")
- <> int (fromInteger n)))
-gc_seq (StInt n) = StJump (StLitLbl (ptext SLIT("stg_gc_seq_")
- <> int (fromInteger n)))
-gc_noregs = StJump (StLitLbl (ptext SLIT("stg_gc_noregs")))
-gc_unpt_r1 = StJump (StLitLbl (ptext SLIT("stg_gc_unpt_r1")))
-gc_unbx_r1 = StJump (StLitLbl (ptext SLIT("stg_gc_unbx_r1")))
-gc_f1 = StJump (StLitLbl (ptext SLIT("stg_gc_f1")))
-gc_d1 = StJump (StLitLbl (ptext SLIT("stg_gc_d1")))
-gc_gen = StJump (StLitLbl (ptext SLIT("stg_gen_chk")))
-
+mkStJump_to_GCentry :: String -> StixTree
+mkStJump_to_GCentry gcname
+-- | opt_Static
+ = StJump (StCLbl (mkRtsGCEntryLabel gcname))
+-- | otherwise -- it's in a different DLL
+-- = StJump (StInd PtrRep (StLitLbl True sdoc))
+
+gc_chk (StInt n) = mkStJump_to_GCentry ("stg_chk_" ++ show n)
+gc_enter (StInt n) = mkStJump_to_GCentry ("stg_gc_enter_" ++ show n)
+gc_seq (StInt n) = mkStJump_to_GCentry ("stg_gc_seq_" ++ show n)
+gc_noregs = mkStJump_to_GCentry "stg_gc_noregs"
+gc_unpt_r1 = mkStJump_to_GCentry "stg_gc_unpt_r1"
+gc_unbx_r1 = mkStJump_to_GCentry "stg_gc_unbx_r1"
+gc_f1 = mkStJump_to_GCentry "stg_gc_f1"
+gc_d1 = mkStJump_to_GCentry "stg_gc_d1"
+gc_gen = mkStJump_to_GCentry "stg_gen_chk"
gc_ut (StInt p) (StInt np)
- = StJump (StLitLbl (ptext SLIT("stg_gc_ut_")
- <> int (fromInteger p)
- <> char '_' <> int (fromInteger np)))
+ = mkStJump_to_GCentry ("stg_gc_ut_" ++ show p
+ ++ "_" ++ show np)
\end{code}
import PrimRep ( PrimRep(..), isFloatingRep )
import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM )
import Constants ( mIN_INTLIKE, uF_UPDATEE, bLOCK_SIZE )
+import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
+ mkTopClosureLabel, mkErrorIO_innardsLabel,
+ mkMAP_FROZEN_infoLabel )
import Outputable
import Char ( ord, isAlphaNum )
-- For CharLike and IntLike, we attempt some trivial constant-folding here.
amodeToStix (CCharLike (CLit (MachChar c)))
- = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
+ = StIndex CharRep cHARLIKE_closure (StInt (toInteger off))
where
off = charLikeSize * ord c
amodeToStix (CCharLike x)
- = StIndex CharRep charLike off
+ = StIndex CharRep cHARLIKE_closure off
where
off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
amodeToStix (CIntLike (CLit (MachInt i)))
- = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
+ = StIndex CharRep{-yes,really-} iNTLIKE_closure (StInt (toInteger off))
where
off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
UPD_FRAME_UPDATEE
-> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
(StInt (toInteger uF_UPDATEE)))
--- XXX!!!
--- GET_TAG(info_ptr) is supposed to be get_itbl(info_ptr)->srt_len,
--- which we've had to hand-code here.
-
-litLitToStix :: String -> StixTree
litLitToStix nm
- | all is_id nm = StLitLbl (text nm)
- | otherwise = error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n"
- ++ "suggested workaround: use flag -fvia-C\n")
-
- where is_id c = isAlphaNum c || c == '_'
+ = error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n"
+ ++ "suggested workaround: use flag -fvia-C\n")
\end{code}
Sizes of the CharLike and IntLike closures that are arranged as arrays
\begin{code}
-- The INTLIKE base pointer
-intLikePtr :: StixTree
-
-intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure"))
+iNTLIKE_closure :: StixTree
+iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
-- The CHARLIKE base
-charLike :: StixTree
-
-charLike = sStLitLbl SLIT("CHARLIKE_closure")
+cHARLIKE_closure :: StixTree
+cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
-- Trees for the ErrorIOPrimOp
topClosure, errorIO :: StixTree
-topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
-errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
+topClosure = StInd PtrRep (StCLbl mkTopClosureLabel)
+errorIO = StJump (StInd PtrRep (StCLbl mkErrorIO_innardsLabel))
-mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info")
+mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
+-- these are the sizes of charLike and intLike closures, in _bytes_.
charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
intLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
\end{code}
projects / ghc-hetmet.git / commitdiff