summaryrefslogtreecommitdiff
path: root/compiler/nativeGen/RegAlloc/Linear
diff options
context:
space:
mode:
authorRichard Eisenberg <eir@cis.upenn.edu>2015-12-11 18:19:53 -0500
committerRichard Eisenberg <eir@cis.upenn.edu>2015-12-11 18:23:12 -0500
commit6746549772c5cc0ac66c0fce562f297f4d4b80a2 (patch)
tree96869fcfb5757651462511d64d99a3712f09e7fb /compiler/nativeGen/RegAlloc/Linear
parent6e56ac58a6905197412d58e32792a04a63b94d7e (diff)
downloadhaskell-6746549772c5cc0ac66c0fce562f297f4d4b80a2.tar.gz
Add kind equalities to GHC.
This implements the ideas originally put forward in "System FC with Explicit Kind Equality" (ICFP'13). There are several noteworthy changes with this patch: * We now have casts in types. These change the kind of a type. See new constructor `CastTy`. * All types and all constructors can be promoted. This includes GADT constructors. GADT pattern matches take place in type family equations. In Core, types can now be applied to coercions via the `CoercionTy` constructor. * Coercions can now be heterogeneous, relating types of different kinds. A coercion proving `t1 :: k1 ~ t2 :: k2` proves both that `t1` and `t2` are the same and also that `k1` and `k2` are the same. * The `Coercion` type has been significantly enhanced. The documentation in `docs/core-spec/core-spec.pdf` reflects the new reality. * The type of `*` is now `*`. No more `BOX`. * Users can write explicit kind variables in their code, anywhere they can write type variables. For backward compatibility, automatic inference of kind-variable binding is still permitted. * The new extension `TypeInType` turns on the new user-facing features. * Type families and synonyms are now promoted to kinds. This causes trouble with parsing `*`, leading to the somewhat awkward new `HsAppsTy` constructor for `HsType`. This is dispatched with in the renamer, where the kind `*` can be told apart from a type-level multiplication operator. Without `-XTypeInType` the old behavior persists. With `-XTypeInType`, you need to import `Data.Kind` to get `*`, also known as `Type`. * The kind-checking algorithms in TcHsType have been significantly rewritten to allow for enhanced kinds. * The new features are still quite experimental and may be in flux. * TODO: Several open tickets: #11195, #11196, #11197, #11198, #11203. * TODO: Update user manual. Tickets addressed: #9017, #9173, #7961, #10524, #8566, #11142. Updates Haddock submodule.
Diffstat (limited to 'compiler/nativeGen/RegAlloc/Linear')
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/Main.hs6
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs4
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs58
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/StackMap.hs4
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/Stats.hs6
5 files changed, 39 insertions, 39 deletions
diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index bee091b584..2d593c626d 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -657,12 +657,12 @@ saveClobberedTemps clobbered dying
-- (2) no free registers: spill the value
[] -> do
(spill, slot) <- spillR (RegReal reg) temp
-
+
-- record why this reg was spilled for profiling
recordSpill (SpillClobber temp)
-
+
let new_assign = addToUFM assig temp (InBoth reg slot)
-
+
clobber new_assign (spill : instrs) rest
diff --git a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
index b76fe79d7d..a2a6dacb65 100644
--- a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
@@ -37,7 +37,7 @@ releaseReg (RealRegSingle r) (FreeRegs g f)
releaseReg _ _
= panic "RegAlloc.Linear.PPC.releaseReg: bad reg"
-
+
initFreeRegs :: Platform -> FreeRegs
initFreeRegs platform = foldr releaseReg noFreeRegs (allocatableRegs platform)
@@ -52,7 +52,7 @@ getFreeRegs cls (FreeRegs g f)
| otherwise = go x (m `shiftR` 1) $! i-1
allocateReg :: RealReg -> FreeRegs -> FreeRegs
-allocateReg (RealRegSingle r) (FreeRegs g f)
+allocateReg (RealRegSingle r) (FreeRegs g f)
| r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (r - 32)))
| otherwise = FreeRegs (g .&. complement (1 `shiftL` r)) f
diff --git a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs
index 2cb9999ce7..89a9407b71 100644
--- a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs
@@ -28,8 +28,8 @@ import Data.Bits
--
-- Free regs have a bit set in the corresponding bitmap.
--
-data FreeRegs
- = FreeRegs
+data FreeRegs
+ = FreeRegs
!Word32 -- int reg bitmap regs 0..31
!Word32 -- float reg bitmap regs 32..63
!Word32 -- double reg bitmap regs 32..63
@@ -47,23 +47,23 @@ initFreeRegs :: Platform -> FreeRegs
initFreeRegs platform
= foldr (releaseReg platform) noFreeRegs allocatableRegs
-
+
-- | Get all the free registers of this class.
getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily
getFreeRegs cls (FreeRegs g f d)
- | RcInteger <- cls = map RealRegSingle $ go 1 g 1 0
- | RcFloat <- cls = map RealRegSingle $ go 1 f 1 32
- | RcDouble <- cls = map (\i -> RealRegPair i (i+1)) $ go 2 d 1 32
+ | RcInteger <- cls = map RealRegSingle $ go 1 g 1 0
+ | RcFloat <- cls = map RealRegSingle $ go 1 f 1 32
+ | RcDouble <- cls = map (\i -> RealRegPair i (i+1)) $ go 2 d 1 32
| otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls)
where
go _ _ 0 _
= []
- go step bitmap mask ix
- | bitmap .&. mask /= 0
- = ix : (go step bitmap (mask `shiftL` step) $! ix + step)
+ go step bitmap mask ix
+ | bitmap .&. mask /= 0
+ = ix : (go step bitmap (mask `shiftL` step) $! ix + step)
- | otherwise
+ | otherwise
= go step bitmap (mask `shiftL` step) $! ix + step
@@ -76,19 +76,19 @@ allocateReg platform
-- can't allocate free regs
| not $ freeReg platform r
= pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg)
-
+
-- a general purpose reg
| r <= 31
= let mask = complement (bitMask r)
- in FreeRegs
- (g .&. mask)
- f
+ in FreeRegs
+ (g .&. mask)
+ f
d
-- a float reg
| r >= 32, r <= 63
= let mask = complement (bitMask (r - 32))
-
+
-- the mask of the double this FP reg aliases
maskLow = if r `mod` 2 == 0
then complement (bitMask (r - 32))
@@ -100,11 +100,11 @@ allocateReg platform
| otherwise
= pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)
-
+
allocateReg _
reg@(RealRegPair r1 r2)
(FreeRegs g f d)
-
+
| r1 >= 32, r1 <= 63, r1 `mod` 2 == 0
, r2 >= 32, r2 <= 63
= let mask1 = complement (bitMask (r1 - 32))
@@ -114,19 +114,19 @@ allocateReg _
g
((f .&. mask1) .&. mask2)
(d .&. mask1)
-
+
| otherwise
= pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)
-
+
-- | Release a register from allocation.
--- The register liveness information says that most regs die after a C call,
+-- The register liveness information says that most regs die after a C call,
-- but we still don't want to allocate to some of them.
--
releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs
releaseReg platform
- reg@(RealRegSingle r)
+ reg@(RealRegSingle r)
regs@(FreeRegs g f d)
-- don't release pinned reg
@@ -134,28 +134,28 @@ releaseReg platform
= regs
-- a general purpose reg
- | r <= 31
+ | r <= 31
= let mask = bitMask r
in FreeRegs (g .|. mask) f d
-- a float reg
| r >= 32, r <= 63
= let mask = bitMask (r - 32)
-
+
-- the mask of the double this FP reg aliases
maskLow = if r `mod` 2 == 0
then bitMask (r - 32)
else bitMask (r - 32 - 1)
- in FreeRegs
- g
+ in FreeRegs
+ g
(f .|. mask)
(d .|. maskLow)
| otherwise
= pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)
-
+
releaseReg _
- reg@(RealRegPair r1 r2)
+ reg@(RealRegPair r1 r2)
(FreeRegs g f d)
| r1 >= 32, r1 <= 63, r1 `mod` 2 == 0
@@ -167,10 +167,10 @@ releaseReg _
g
((f .|. mask1) .|. mask2)
(d .|. mask1)
-
+
| otherwise
= pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)
-
+
bitMask :: Int -> Word32
diff --git a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
index 85ea6771b8..748fb98c30 100644
--- a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
@@ -28,8 +28,8 @@ import Unique
-- | Identifier for a stack slot.
type StackSlot = Int
-data StackMap
- = StackMap
+data StackMap
+ = StackMap
{ -- | The slots that are still available to be allocated.
stackMapNextFreeSlot :: !Int
diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs
index 83f5fbc950..b7d93f4436 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Stats.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs
@@ -33,7 +33,7 @@ binSpillReasons reasons
-- | Count reg-reg moves remaining in this code.
-countRegRegMovesNat
+countRegRegMovesNat
:: Instruction instr
=> NatCmmDecl statics instr -> Int
@@ -54,8 +54,8 @@ countRegRegMovesNat cmm
-- | Pretty print some RegAllocStats
-pprStats
- :: Instruction instr
+pprStats
+ :: Instruction instr
=> [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc
pprStats code statss