X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStix.lhs;h=9f4a5ea6600be821b49ef597eb1b77cf0e66e4f5;hb=553e90d9a32ee1b1809430f260c401cc4169c6c7;hp=951cfb682cae8e72720cd1b34193b299f2d5ea99;hpb=d11e681f219f6e38c2e5bc87adfb66f82de5ea65;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index 951cfb6..9f4a5ea 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -8,10 +8,10 @@ module Stix ( StixStmt(..), mkStAssign, StixStmtList, pprStixStmts, pprStixStmt, pprStixExpr, pprStixReg, stixStmt_CountTempUses, stixStmt_Subst, - liftStrings, + liftStrings, repOfStixExpr, DestInfo(..), hasDestInfo, - stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, + stgBaseReg, stgNode, stgSp, stgSpLim, stgHp, stgHpLim, stgHpAlloc, stgTagReg, stgR9, stgR10, stgCurrentTSO, stgCurrentNursery, @@ -21,30 +21,37 @@ module Stix ( mapNat, mapAndUnzipNat, mapAccumLNat, getUniqueNat, getDeltaNat, setDeltaNat, NatM_State, mkNatM_State, - uniqOfNatM_State, deltaOfNatM_State, + uniqOfNatM_State, deltaOfNatM_State, importsOfNatM_State, + addImportNat, getUniqLabelNCG, getNatLabelNCG, - ncgPrimopMoan + ncgPrimopMoan, + + -- Information about the target arch + ncg_target_is_32bit ) where #include "HsVersions.h" -import Ratio ( Rational ) -import IOExts ( unsafePerformIO ) -import IO ( hPutStrLn, stderr ) - import AbsCSyn ( node, tagreg, MagicId(..) ) +import AbsCUtils ( magicIdPrimRep ) import ForeignCall ( CCallConv ) import CLabel ( mkAsmTempLabel, CLabel, pprCLabel ) import PrimRep ( PrimRep(..) ) -import MachOp ( MachOp(..), pprMachOp ) +import MachOp ( MachOp(..), pprMachOp, resultRepOfMachOp ) import Unique ( Unique ) import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize ) import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, UniqSM, thenUs, returnUs, getUniqueUs ) -import Maybes ( Maybe012(..), maybe012ToList ) +import Constants ( wORD_SIZE ) import Outputable import FastTypes +import FastString + +import UNSAFE_IO ( unsafePerformIO ) + +import Ratio ( Rational ) +import IO ( hPutStrLn, stderr ) \end{code} Two types, StixStmt and StixValue, define Stix. @@ -58,7 +65,7 @@ data StixStmt StSegment CodeSegment -- Assembly-language comments - | StComment FAST_STRING + | StComment FastString -- Assignments are typed to determine size and register placement. -- Assign a value to a StixReg @@ -68,10 +75,6 @@ data StixStmt -- assigned to, so there is an implicit dereference here. | StAssignMem PrimRep StixExpr StixExpr -- dst, src - -- Do a machine op which generates multiple values, and assign - -- the results to the lvalues stated here. - | StAssignMachOp (Maybe012 StixVReg) MachOp [StixExpr] - -- A simple assembly label that we might jump to. | StLabel CLabel @@ -98,7 +101,7 @@ data StixStmt -- Raw data (as in an info table). | StData PrimRep [StixExpr] -- String which has been lifted to the top level (sigh). - | StDataString FAST_STRING + | StDataString FastString -- A value computed only for its side effects; result is discarded -- (A handy trapdoor to allow CCalls with no results to appear as @@ -124,8 +127,7 @@ mkStAssign rep (StInd rep' addr) rhs isCloseEnoughTo r1 r2 = r1 == r2 || (wordIsh r1 && wordIsh r2) wordIsh rep - = rep `elem` [IntRep, WordRep, PtrRep, AddrRep, CodePtrRep, - RetRep, ArrayRep, PrimPtrRep, StableNameRep, BCORep] + = rep `elem` [IntRep, WordRep, PtrRep, AddrRep, CodePtrRep, RetRep ] -- determined by looking at PrimRep.showPrimRep -- Stix trees which denote a value. @@ -134,7 +136,7 @@ data StixExpr StInt Integer -- ** add Kind at some point | StFloat Rational | StDouble Rational - | StString FAST_STRING + | StString FastString | StCLbl CLabel -- labels that we might index into -- Abstract registers of various kinds @@ -150,7 +152,22 @@ data StixExpr | StMachOp MachOp [StixExpr] -- Calls to C functions - | StCall FAST_STRING CCallConv PrimRep [StixExpr] + | StCall (Either FastString StixExpr) -- Left: static, Right: dynamic + CCallConv PrimRep [StixExpr] + + +-- What's the PrimRep of the value denoted by this StixExpr? +repOfStixExpr :: StixExpr -> PrimRep +repOfStixExpr (StInt _) = IntRep +repOfStixExpr (StFloat _) = FloatRep +repOfStixExpr (StDouble _) = DoubleRep +repOfStixExpr (StString _) = PtrRep +repOfStixExpr (StCLbl _) = PtrRep +repOfStixExpr (StReg reg) = repOfStixReg reg +repOfStixExpr (StIndex _ _ _) = PtrRep +repOfStixExpr (StInd rep _) = rep +repOfStixExpr (StCall target conv retrep args) = retrep +repOfStixExpr (StMachOp mop args) = resultRepOfMachOp mop -- used by insnFuture in RegAllocInfo.lhs @@ -182,23 +199,27 @@ pprStixExpr t StInt i -> (if i < 0 then parens else id) (integer i) StFloat rat -> parens (text "Float" <+> rational rat) StDouble rat -> parens (text "Double" <+> rational rat) - StString str -> parens (text "Str `" <> ptext str <> char '\'') + StString str -> parens (text "Str `" <> ftext str <> char '\'') StIndex k b o -> parens (pprStixExpr b <+> char '+' <> ppr k <+> pprStixExpr o) StInd k t -> ppr k <> char '[' <> pprStixExpr t <> char ']' StReg reg -> pprStixReg reg StMachOp op args -> pprMachOp op <> parens (hsep (punctuate comma (map pprStixExpr args))) - StCall nm cc k args - -> parens (text "Call" <+> ptext nm <+> + StCall fn cc k args + -> parens (text "Call" <+> targ <+> ppr cc <+> ppr k <+> hsep (map pprStixExpr args)) + where + targ = case fn of + Left t_static -> ftext t_static + Right t_dyn -> parens (pprStixExpr t_dyn) pprStixStmt :: StixStmt -> SDoc pprStixStmt t = case t of StSegment cseg -> parens (ppCodeSegment cseg) - StComment str -> parens (text "Comment" <+> ptext str) + StComment str -> parens (text "Comment" <+> ftext str) StAssignReg pr reg rhs -> pprStixReg reg <> text " :=" <> ppr pr <> text " " <> pprStixExpr rhs @@ -206,13 +227,6 @@ pprStixStmt t -> ppr pr <> char '[' <> pprStixExpr addr <> char ']' <> text " :=" <> ppr pr <> text " " <> pprStixExpr rhs - StAssignMachOp lhss mop args - -> parens (hcat (punctuate comma ( - map pprStixVReg (maybe012ToList lhss) - ))) - <> text " := " - <> pprMachOp mop - <> parens (hsep (punctuate comma (map pprStixExpr args))) StLabel ll -> pprCLabel ll <+> char ':' StFunBegin ll -> char ' ' $$ parens (text "FunBegin" <+> pprCLabel ll) StFunEnd ll -> parens (text "FunEnd" <+> pprCLabel ll) @@ -239,10 +253,13 @@ data StixReg pprStixReg (StixMagicId mid) = ppMId mid pprStixReg (StixTemp temp) = pprStixVReg temp +repOfStixReg (StixTemp (StixVReg u pr)) = pr +repOfStixReg (StixMagicId mid) = magicIdPrimRep mid + data StixVReg = StixVReg Unique PrimRep -pprStixVReg (StixVReg u pr) = hcat [text "VReg(", ppr u, ppr pr, char ')'] +pprStixVReg (StixVReg u pr) = hcat [text "VReg(", ppr u, colon, ppr pr, char ')'] @@ -254,7 +271,6 @@ ppMId (DoubleReg n) = hcat [text "DblReg(", int (iBox n), char ')'] ppMId (LongReg kind n) = hcat [ppr kind, text "LongReg(", int (iBox n), char ')'] ppMId Sp = text "Sp" -ppMId Su = text "Su" ppMId SpLim = text "SpLim" ppMId Hp = text "Hp" ppMId HpLim = text "HpLim" @@ -280,14 +296,12 @@ type StixStmtList = [StixStmt] -> [StixStmt] Stix Trees for STG registers: \begin{code} -stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim - :: StixReg +stgBaseReg, stgNode, stgSp, stgSpLim, stgHp, stgHpLim :: StixReg stgBaseReg = StixMagicId BaseReg stgNode = StixMagicId node stgTagReg = StixMagicId tagreg stgSp = StixMagicId Sp -stgSu = StixMagicId Su stgSpLim = StixMagicId SpLim stgHp = StixMagicId Hp stgHpLim = StixMagicId HpLim @@ -328,7 +342,8 @@ stixExpr_CountTempUses u t StIndex pk t1 t2 -> qe t1 + qe t2 StInd pk t1 -> qe t1 StMachOp mop ts -> sum (map qe ts) - StCall nm cconv pk ts -> sum (map qe ts) + StCall (Left nm) cconv pk ts -> sum (map qe ts) + StCall (Right f) cconv pk ts -> sum (map qe ts) + qe f StInt _ -> 0 StFloat _ -> 0 StDouble _ -> 0 @@ -347,8 +362,6 @@ stixStmt_CountTempUses u t StJump dsts t1 -> qe t1 StCondJump lbl t1 -> qe t1 StData pk ts -> sum (map qe ts) - StAssignMachOp lhss mop args - -> sum (map qv (maybe012ToList lhss)) + sum (map qe args) StVoidable expr -> qe expr StSegment _ -> 0 StFunBegin _ -> 0 @@ -392,7 +405,8 @@ stixExpr_MapUniques f t StIndex pk t1 t2 -> StIndex pk (qe t1) (qe t2) StInd pk t1 -> StInd pk (qe t1) StMachOp mop args -> StMachOp mop (map qe args) - StCall nm cconv pk ts -> StCall nm cconv pk (map qe ts) + StCall (Left nm) cconv pk ts -> StCall (Left nm) cconv pk (map qe ts) + StCall (Right f) cconv pk ts -> StCall (Right (qe f)) cconv pk (map qe ts) StInt _ -> t StFloat _ -> t StDouble _ -> t @@ -405,21 +419,6 @@ stixStmt_MapUniques f t qs = stixStmt_MapUniques f qr = stixReg_MapUniques f qv = stixVReg_MapUniques f - - doMopLhss Just0 = Just0 - doMopLhss (Just1 r1) - = case qv r1 of - Nothing -> Just1 r1 - other -> doMopLhss_panic - doMopLhss (Just2 r1 r2) - = case (qv r1, qv r2) of - (Nothing, Nothing) -> Just2 r1 r2 - other -> doMopLhss_panic - -- Because the StixRegs processed by doMopLhss are lvalues, they - -- absolutely shouldn't be mapped to a StixExpr; - -- hence we panic if they do. Same deal for StAssignReg below. - doMopLhss_panic - = panic "stixStmt_MapUniques:doMopLhss" in case t of StAssignReg pk reg rhs @@ -430,9 +429,7 @@ stixStmt_MapUniques f t StJump dsts t1 -> StJump dsts (qe t1) StCondJump lbl t1 -> StCondJump lbl (qe t1) StData pk ts -> StData pk (map qe ts) - StVoidable expr -> StVoidable (qe expr) - StAssignMachOp lhss mop args - -> StAssignMachOp (doMopLhss lhss) mop (map qe args) + StVoidable expr -> StVoidable (qe expr) StSegment _ -> t StLabel _ -> t StFunBegin _ -> t @@ -495,7 +492,7 @@ liftStrings stmts liftStrings_wrk :: [StixStmt] -- originals -> [StixStmt] -- (reverse) originals with strings lifted out - -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels + -> [(CLabel, FastString)] -- lifted strs, and their new labels -> UniqSM [StixStmt] -- First, examine the original trees and lift out strings in top-level StDatas. @@ -531,16 +528,20 @@ liftStrings_wrk [] acc_stix acc_strs The NCG's monad. +The monad keeps a UniqSupply, the current stack delta and +a list of imported entities, which is only used for +Darwin (Mac OS X). + \begin{code} -data NatM_State = NatM_State UniqSupply Int +data NatM_State = NatM_State UniqSupply Int [FastString] type NatM result = NatM_State -> (result, NatM_State) mkNatM_State :: UniqSupply -> Int -> NatM_State -mkNatM_State = NatM_State - -uniqOfNatM_State (NatM_State us delta) = us -deltaOfNatM_State (NatM_State us delta) = delta +mkNatM_State us delta = NatM_State us delta [] +uniqOfNatM_State (NatM_State us delta imports) = us +deltaOfNatM_State (NatM_State us delta imports) = delta +importsOfNatM_State (NatM_State us delta imports) = imports initNat :: NatM_State -> NatM a -> (a, NatM_State) initNat init_st m = case m init_st of { (r,st) -> (r,st) } @@ -580,17 +581,21 @@ mapAccumLNat f b (x:xs) getUniqueNat :: NatM Unique -getUniqueNat (NatM_State us delta) +getUniqueNat (NatM_State us delta imports) = case splitUniqSupply us of - (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta)) + (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports)) getDeltaNat :: NatM Int -getDeltaNat st@(NatM_State us delta) +getDeltaNat st@(NatM_State us delta imports) = (delta, st) setDeltaNat :: Int -> NatM () -setDeltaNat delta (NatM_State us _) - = ((), NatM_State us delta) +setDeltaNat delta (NatM_State us _ imports) + = ((), NatM_State us delta imports) + +addImportNat :: FastString -> NatM () +addImportNat imp (NatM_State us delta imports) + = ((), NatM_State us delta (imp:imports)) \end{code} Giving up in a not-too-inelegant way. @@ -612,3 +617,13 @@ ncgPrimopMoan msg pp_rep `seq` pprPanic msg pp_rep \end{code} + +Information about the target. + +\begin{code} + +ncg_target_is_32bit :: Bool +ncg_target_is_32bit | wORD_SIZE == 4 = True + | wORD_SIZE == 8 = False + +\end{code}