From: sewardj Date: Thu, 18 May 2000 13:55:37 +0000 (+0000) Subject: [project @ 2000-05-18 13:55:36 by sewardj] X-Git-Tag: Approximately_9120_patches~4431 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=963cf41182a705b0bb2f6dee66fd17566ae65173;p=ghc-hetmet.git [project @ 2000-05-18 13:55:36 by sewardj] Teach the NCG about the dereferencing and naming conventions to be used when compiling for a DLLised world. Some cleanups on the way too. The scheme is that * All CLabels which are in different DLLs from the current module will, via the renamer, already be such that labelDynamic returns True for them. * Redo the StixPrim/StixMacro stuff so that all references to symbols in the RTS are via CLabels. That means that the usual labelDynamic story can be used. * When a label is printed in PprMach, labelDynamic is consulted, to generate the __imp_ prefix if necessary. * In MachCode.stmt2Instrs, selectively ask derefDLL to walk trees before code generation and insert deferencing code around other-DLL symbols. * When generating Stix for SRTs, add 1 to other-DLL refs. * When generating static closures, insert a zero word before the _closure label. --- diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 705da74..94dfc39 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -1,7 +1,7 @@ % % (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} @@ -36,7 +36,20 @@ module CLabel ( mkModuleInitLabel, mkErrorStdEntryLabel, + + mkStgUpdatePAPLabel, mkUpdInfoLabel, + mkSeqInfoLabel, + mkIndInfoLabel, + mkIndStaticInfoLabel, + mkRtsGCEntryLabel, + mkMainRegTableLabel, + mkCharlikeClosureLabel, + mkIntlikeClosureLabel, + mkTopClosureLabel, + mkErrorIO_innardsLabel, + mkMAP_FROZEN_infoLabel, + mkTopTickyCtrLabel, mkBlackHoleInfoTableLabel, mkCAFBlackHoleInfoTableLabel, @@ -160,7 +173,13 @@ data RtsLabelInfo | 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-} @@ -219,7 +238,20 @@ mkModuleInitLabel = ModuleInitLabel -- 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")) @@ -418,7 +450,13 @@ pprCLbl (CaseLabel u CaseBitmap) 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") diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 36cb457..c15c87e 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -24,7 +24,7 @@ import SMRep ( fixedItblSize, import Constants ( mIN_UPD_SIZE ) import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel, mkClosureLabel, - moduleRegdLabel ) + moduleRegdLabel, labelDynamic ) import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, fastLabelFromCI, closureUpdReqd, staticClosureNeedsLink @@ -45,6 +45,7 @@ import DataCon ( dataConWrapId ) 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 @@ -84,7 +85,14 @@ Here we handle top-level things, like @CCodeBlock@s and 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 -> @@ -132,8 +140,15 @@ Here we handle top-level things, like @CCodeBlock@s and 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 @@ -152,18 +167,20 @@ Here we handle top-level things, like @CCodeBlock@s and 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) ]) diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index a2cddd2..f483095 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -22,7 +22,7 @@ import AsmRegAlloc ( runRegAllocate ) 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, @@ -203,7 +203,7 @@ stixPeep ( t1@(StAssign pka (StReg (StixTemp u pk)) rhs) : 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) diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs index 53f1140..330236e 100644 --- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs +++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs @@ -163,9 +163,9 @@ hairyRegAlloc regs reserve_regs instrs = 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 @@ -182,6 +182,12 @@ hairyRegAlloc regs reserve_regs instrs = (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 diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 621b9f7..f8fc8ac 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -21,19 +21,20 @@ import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL, 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` @@ -68,13 +69,16 @@ stmt2Instrs stmt = case stmt of 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 @@ -89,11 +93,10 @@ stmt2Instrs stmt = case stmt of 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)], @@ -102,6 +105,35 @@ stmt2Instrs stmt = case stmt of 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} %************************************************************************ @@ -134,12 +166,10 @@ mangleIndexTree (StIndex pk base off) \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)) @@ -482,13 +512,11 @@ getRegister (StDouble d) | 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 -> @@ -578,7 +606,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps other -> pprPanic "getRegister(x86,unary primop)" - (pprStixTrees [StPrim primop [x]]) + (pprStixTree (StPrim primop [x])) getRegister (StPrim primop [x, y]) -- dyadic PrimOps = case primop of @@ -662,7 +690,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps [x, y]) other -> pprPanic "getRegister(x86,dyadic primop)" - (pprStixTrees [StPrim primop [x, y]]) + (pprStixTree (StPrim primop [x, y])) where -------------------- @@ -861,7 +889,7 @@ getRegister leaf 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 @@ -2317,7 +2345,7 @@ genCCall fn cconv kind args -- 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 diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs index 171df4e..37dcd39 100644 --- a/ghc/compiler/nativeGen/MachMisc.lhs +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -20,8 +20,6 @@ module MachMisc ( fmtAsmLbl, exactLog2, - stixFor_stdout, stixFor_stderr, stixFor_stdin, - Instr(..), IF_ARCH_i386(Operand(..) COMMA,) Cond(..), Size(..), @@ -80,53 +78,6 @@ fmtAsmLbl s ,{-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} % ---------------------------------------------------------------- diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs index 81ff772..dce9937 100644 --- a/ghc/compiler/nativeGen/MachRegs.lhs +++ b/ghc/compiler/nativeGen/MachRegs.lhs @@ -61,10 +61,10 @@ module MachRegs ( 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 @@ -80,7 +80,8 @@ data Imm = 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 @@ -169,7 +170,9 @@ fits13Bits x = x >= -4096 && x < 4096 ----------------- 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} @@ -204,10 +207,10 @@ stgReg x 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, diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index 51a6838..834a85c 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -17,7 +17,7 @@ module PprMach ( pprInstr, pprSize, pprUserReg ) where 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(..) ) @@ -260,12 +260,15 @@ pprImm :: Imm -> SDoc 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) diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index 04e1e19..dfb2ba6 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -5,7 +5,7 @@ \begin{code} module Stix ( CodeSegment(..), StixReg(..), StixTree(..), StixTreeList, - sStLitLbl, pprStixTrees, ppStixTree, ppStixReg, + pprStixTrees, pprStixTree, ppStixReg, stixCountTempUses, stixSubst, stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, @@ -37,6 +37,7 @@ import Unique ( Unique ) import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize ) import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, UniqSM, thenUs, returnUs, getUniqueUs ) +import CmdLineOpts ( opt_Static ) import Outputable \end{code} @@ -54,9 +55,6 @@ data StixTree | 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 @@ -122,51 +120,47 @@ data StixTree | 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 @@ -276,7 +270,6 @@ stixCountTempUses u t StInt _ -> 0 StDouble _ -> 0 StString _ -> 0 - StLitLbl _ -> 0 StCLbl _ -> 0 StLabel _ -> 0 StFunBegin _ -> 0 @@ -320,7 +313,6 @@ stixMapUniques f t StInt _ -> t StDouble _ -> t StString _ -> t - StLitLbl _ -> t StCLbl _ -> t StLabel _ -> t StFunBegin _ -> t diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs index 8748879..aa24af3 100644 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -23,7 +23,7 @@ import CallConv ( cCallConv ) 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} diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 8eee4e5..eb49df2 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -21,6 +21,9 @@ import PrimRep ( PrimRep(..) ) 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 @@ -202,17 +205,17 @@ Let's make sure that these CAFs are lifted out, shall we? 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} @@ -335,21 +338,23 @@ checkCode macro args assts -- 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} diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 034e641..5bbd329 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -21,6 +21,9 @@ import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) 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 ) @@ -406,17 +409,17 @@ amodeToStix (CLbl lbl _) = StCLbl lbl -- 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)) @@ -457,17 +460,9 @@ amodeToStix (CMacroExpr _ macro [arg]) 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 @@ -476,25 +471,24 @@ in the data segment. (These are in bytes.) \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}