X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStix.lhs;h=2b5b41ee98e52ca9e404fe7517dde3cca3ad6dc1;hb=4070b105490709e2fbc40ef926853fc93595b7a6;hp=3b297a80ef03b2f6229f35a71319c21d1c7809df;hpb=e0e07f52be0e7518bbd5eea1e3b374b3e09c910c;p=ghc-hetmet.git

diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs
index 3b297a8..2b5b41e 100644
--- a/ghc/compiler/nativeGen/Stix.lhs
+++ b/ghc/compiler/nativeGen/Stix.lhs
@@ -5,13 +5,21 @@
 \begin{code}
 module Stix (
 	CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
-	sStLitLbl, pprStixTrees, ppStixReg,
+	sStLitLbl, pprStixTrees, ppStixTree, ppStixReg,
+        stixCountTempUses, stixSubst,
 
 	stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, 
         stgHp, stgHpLim, stgTagReg, stgR9, stgR10,
-	getUniqLabelNCG,
 
-	fixedHS, arrWordsHS, arrPtrsHS
+	fixedHS, arrWordsHS, arrPtrsHS,
+
+        NatM, initNat, thenNat, returnNat, 
+        mapNat, mapAndUnzipNat,
+        getUniqueNat, getDeltaNat, setDeltaNat,
+        NatM_State, mkNatM_State,
+        uniqOfNatM_State, deltaOfNatM_State,
+
+	getUniqLabelNCG, getNatLabelNCG,
     ) where
 
 #include "HsVersions.h"
@@ -26,7 +34,8 @@ import PrimRep          ( PrimRep(..), showPrimRep )
 import PrimOp           ( PrimOp, pprPrimOp )
 import Unique           ( Unique )
 import SMRep		( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
-import UniqSupply	( returnUs, thenUs, getUniqueUs, UniqSM )
+import UniqSupply	( UniqSupply, splitUniqSupply, uniqFromSupply,
+                          UniqSM, thenUs, returnUs, getUniqueUs )
 import Outputable
 \end{code}
 
@@ -129,32 +138,35 @@ paren t = char '(' <> t <> char ')'
 ppStixTree :: StixTree -> SDoc
 ppStixTree 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 
+       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
-       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)
+       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)
        StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll)
-       StCondJump l t -> paren (text "JumpC" <+> pprCLabel l <+> ppStixTree t)
-       StData k ds -> paren (text "Data" <+> pprPrimRep k <+>
-                      hsep (map ppStixTree ds))
-       StPrim op ts -> paren (text "Prim" <+> pprPrimOp op <+> hsep (map ppStixTree ts))
+       StCondJump l t   -> paren (text "JumpC" <+> pprCLabel l 
+                                               <+> ppStixTree t)
+       StData k ds      -> paren (text "Data" <+> pprPrimRep k <+>
+                                  hsep (map ppStixTree ds))
+       StPrim op ts     -> paren (text "Prim" <+> pprPrimOp op <+> 
+                                  hsep (map ppStixTree ts))
        StCall nm cc k args
-          -> paren (text "Call" <+> ptext nm <+>
-               pprCallConv cc <+> pprPrimRep k <+> hsep (map ppStixTree args))
-       StScratchWord i -> text "ScratchWord" <> paren (int i)
+                        -> paren (text "Call" <+> ptext nm <+>
+                                  pprCallConv cc <+> pprPrimRep k <+> 
+                                  hsep (map ppStixTree args))
+       StScratchWord i  -> text "ScratchWord" <> paren (int i)
 
 pprPrimRep = text . showPrimRep
 \end{code}
@@ -176,10 +188,12 @@ ppStixReg (StixTemp u pr)
 
 
 ppMId BaseReg              = text "BaseReg"
-ppMId (VanillaReg kind n)  = hcat [pprPrimRep kind, text "IntReg(", int (I# n), char ')']
+ppMId (VanillaReg kind n)  = hcat [pprPrimRep kind, text "IntReg(", 
+                                   int (I# n), char ')']
 ppMId (FloatReg n)         = hcat [text "FltReg(", int (I# n), char ')']
 ppMId (DoubleReg n)        = hcat [text "DblReg(", int (I# n), char ')']
-ppMId (LongReg kind n)     = hcat [pprPrimRep kind, text "LongReg(", int (I# n), char ')']
+ppMId (LongReg kind n)     = hcat [pprPrimRep kind, text "LongReg(", 
+                                   int (I# n), char ')']
 ppMId Sp                   = text "Sp"
 ppMId Su                   = text "Su"
 ppMId SpLim                = text "SpLim"
@@ -216,12 +230,149 @@ stgHpLim	    = StReg (StixMagicId HpLim)
 stgR9               = StReg (StixMagicId (VanillaReg WordRep ILIT(9)))
 stgR10              = StReg (StixMagicId (VanillaReg WordRep ILIT(10)))
 
+getNatLabelNCG :: NatM CLabel
+getNatLabelNCG
+  = getUniqueNat `thenNat` \ u ->
+    returnNat (mkAsmTempLabel u)
+
 getUniqLabelNCG :: UniqSM CLabel
 getUniqLabelNCG
-  = getUniqueUs	      `thenUs` \ u ->
+  = getUniqueUs `thenUs` \ u ->
     returnUs (mkAsmTempLabel u)
 
 fixedHS     = StInt (toInteger fixedHdrSize)
 arrWordsHS  = StInt (toInteger arrWordsHdrSize)
 arrPtrsHS   = StInt (toInteger arrPtrsHdrSize)
 \end{code}
+
+Stix optimisation passes may wish to find out how many times a
+given temporary appears in a tree, so as to be able to decide
+whether or not to inline the assignment's RHS at usage site(s).
+
+\begin{code}
+stixCountTempUses :: Unique -> StixTree -> Int
+stixCountTempUses u t 
+   = let qq = stixCountTempUses u
+     in
+     case t of
+        StReg reg
+           -> case reg of 
+                 StixTemp uu pr  -> if u == uu then 1 else 0
+                 StixMagicId mid -> 0
+
+        StIndex    pk t1 t2       -> qq t1 + qq t2
+        StInd      pk t1          -> qq t1
+        StAssign   pk t1 t2       -> qq t1 + qq t2
+        StJump     t1             -> qq t1
+        StCondJump lbl t1         -> qq t1
+        StData     pk ts          -> sum (map qq ts)
+        StPrim     op ts          -> sum (map qq ts)
+        StCall     nm cconv pk ts -> sum (map qq ts)
+
+        StSegment _      -> 0
+        StInt _          -> 0
+        StDouble _       -> 0
+        StString _       -> 0
+        StLitLbl _       -> 0
+        StCLbl _         -> 0
+        StLabel _        -> 0
+        StFunBegin _     -> 0
+        StFunEnd _       -> 0
+        StFallThrough _  -> 0
+        StScratchWord _  -> 0
+        StComment _      -> 0
+
+
+stixSubst :: Unique -> StixTree -> StixTree -> StixTree
+stixSubst u new_u in_this_tree
+   = stixMapUniques f in_this_tree
+     where
+        f :: Unique -> Maybe StixTree
+        f uu = if uu == u then Just new_u else Nothing
+
+
+stixMapUniques :: (Unique -> Maybe StixTree) -> StixTree -> StixTree
+stixMapUniques f t
+   = let qq = stixMapUniques f
+     in
+     case t of
+        StReg reg
+           -> case reg of 
+                 StixMagicId mid -> t
+                 StixTemp uu pr  
+                    -> case f uu of
+                          Just xx -> xx
+                          Nothing -> t
+
+        StIndex    pk t1 t2       -> StIndex    pk (qq t1) (qq t2)
+        StInd      pk t1          -> StInd      pk (qq t1)
+        StAssign   pk t1 t2       -> StAssign   pk (qq t1) (qq t2)
+        StJump     t1             -> StJump     (qq t1)
+        StCondJump lbl t1         -> StCondJump lbl (qq t1)
+        StData     pk ts          -> StData     pk (map qq ts)
+        StPrim     op ts          -> StPrim     op (map qq ts)
+        StCall     nm cconv pk ts -> StCall     nm cconv pk (map qq ts)
+
+        StSegment _      -> t
+        StInt _          -> t
+        StDouble _       -> t
+        StString _       -> t
+        StLitLbl _       -> t
+        StCLbl _         -> t
+        StLabel _        -> t
+        StFunBegin _     -> t
+        StFunEnd _       -> t
+        StFallThrough _  -> t
+        StScratchWord _  -> t
+        StComment _      -> t
+\end{code}
+
+\begin{code}
+data NatM_State = NatM_State UniqSupply Int
+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
+
+
+initNat :: NatM_State -> NatM a -> (a, NatM_State)
+initNat init_st m = case m init_st of { (r,st) -> (r,st) }
+
+thenNat :: NatM a -> (a -> NatM b) -> NatM b
+thenNat expr cont st
+  = case expr st of { (result, st') -> cont result st' }
+
+returnNat :: a -> NatM a
+returnNat result st = (result, st)
+
+mapNat :: (a -> NatM b) -> [a] -> NatM [b]
+mapNat f []     = returnNat []
+mapNat f (x:xs)
+  = f x          `thenNat` \ r  ->
+    mapNat f xs  `thenNat` \ rs ->
+    returnNat (r:rs)
+
+mapAndUnzipNat :: (a -> NatM (b,c))   -> [a] -> NatM ([b],[c])
+mapAndUnzipNat f [] = returnNat ([],[])
+mapAndUnzipNat f (x:xs)
+  = f x		    	`thenNat` \ (r1,  r2)  ->
+    mapAndUnzipNat f xs	`thenNat` \ (rs1, rs2) ->
+    returnNat (r1:rs1, r2:rs2)
+
+
+getUniqueNat :: NatM Unique
+getUniqueNat (NatM_State us delta)
+    = case splitUniqSupply us of
+         (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
+
+getDeltaNat :: NatM Int
+getDeltaNat st@(NatM_State us delta)
+   = (delta, st)
+
+setDeltaNat :: Int -> NatM ()
+setDeltaNat delta (NatM_State us _)
+   = ((), NatM_State us delta)
+\end{code}