[commit: ghc] master: Fix and document Unique generation for sum TyCon and DataCons (8265c78)
git at git.haskell.org
git at git.haskell.org
Thu Jul 21 20:00:17 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/8265c783dc26cb72e74a8fe89101049bb94c6db5/ghc
>---------------------------------------------------------------
commit 8265c783dc26cb72e74a8fe89101049bb94c6db5
Author: Ömer Sinan Ağacan <omeragacan at gmail.com>
Date: Thu Jul 21 19:59:05 2016 +0000
Fix and document Unique generation for sum TyCon and DataCons
Test Plan: validate
Reviewers: bgamari, austin
Reviewed By: bgamari
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D2420
>---------------------------------------------------------------
8265c783dc26cb72e74a8fe89101049bb94c6db5
compiler/basicTypes/Unique.hs | 28 ++++++++++++++++++----
compiler/prelude/TysWiredIn.hs | 19 +++++++++++----
testsuite/tests/unboxedsums/all.T | 5 ++++
.../tests/unboxedsums/unboxedsums_unit_tests.hs | 26 ++++++++++++++++++++
4 files changed, 70 insertions(+), 8 deletions(-)
diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs
index 800198b..545ea9f 100644
--- a/compiler/basicTypes/Unique.hs
+++ b/compiler/basicTypes/Unique.hs
@@ -329,11 +329,9 @@ mkAlphaTyVarUnique :: Int -> Unique
mkPreludeClassUnique :: Int -> Unique
mkPreludeTyConUnique :: Int -> Unique
mkTupleTyConUnique :: Boxity -> Arity -> Unique
-mkSumTyConUnique :: Arity -> Unique
mkCTupleTyConUnique :: Arity -> Unique
mkPreludeDataConUnique :: Arity -> Unique
mkTupleDataConUnique :: Boxity -> Arity -> Unique
-mkSumDataConUnique :: ConTagZ -> Arity -> Unique
mkPrimOpIdUnique :: Int -> Unique
mkPreludeMiscIdUnique :: Int -> Unique
mkPArrDataConUnique :: Int -> Unique
@@ -351,7 +349,6 @@ mkPreludeTyConUnique i = mkUnique '3' (2*i)
mkTupleTyConUnique Boxed a = mkUnique '4' (2*a)
mkTupleTyConUnique Unboxed a = mkUnique '5' (2*a)
mkCTupleTyConUnique a = mkUnique 'k' (2*a)
-mkSumTyConUnique a = mkUnique 'z' (2*a)
tyConRepNameUnique :: Unique -> Unique
tyConRepNameUnique u = incrUnique u
@@ -372,12 +369,35 @@ tyConRepNameUnique u = incrUnique u
mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic
mkTupleDataConUnique Boxed a = mkUnique '7' (3*a) -- ditto (*may* be used in C labels)
mkTupleDataConUnique Unboxed a = mkUnique '8' (3*a)
+
+--------------------------------------------------
+-- Sum arities start from 2. A sum of arity N has N data constructors, so it
+-- occupies N+1 slots: 1 TyCon + N DataCons.
+--
+-- So arity 2 sum takes uniques 0 (tycon), 1, 2 (2 data cons)
+-- arity 3 sum takes uniques 3 (tycon), 4, 5, 6 (3 data cons)
+-- etc.
+
+mkSumTyConUnique :: Arity -> Unique
+mkSumTyConUnique arity = mkUnique 'z' (sumUniqsOccupied arity)
+
+mkSumDataConUnique :: ConTagZ -> Arity -> Unique
mkSumDataConUnique alt arity
| alt >= arity
= panic ("mkSumDataConUnique: " ++ show alt ++ " >= " ++ show arity)
| otherwise
- = mkUnique 'z' (2 * alt * arity)
+ = mkUnique 'z' (sumUniqsOccupied arity + alt + 1 {- skip the tycon -})
+
+-- How many unique slots occupied by sum types (including constructors) up to
+-- the given arity?
+sumUniqsOccupied :: Arity -> Int
+sumUniqsOccupied arity
+ = ASSERT(arity >= 2)
+ -- 3 + 4 + ... + arity
+ ((arity * (arity + 1)) `div` 2) - 3
+{-# INLINE sumUniqsOccupied #-}
+--------------------------------------------------
dataConRepNameUnique, dataConWorkerUnique :: Unique -> Unique
dataConWorkerUnique u = incrUnique u
dataConRepNameUnique u = stepUnique u 2
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index 0775d06..1028478 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -861,8 +861,15 @@ mkSumDataConOcc alt n = mkOccName dataName str
-- | Type constructor for n-ary unboxed sum.
sumTyCon :: Arity -> TyCon
-sumTyCon n | n > mAX_SUM_SIZE = fst (mk_sum n) -- Build one specially
-sumTyCon n = fst (unboxedSumArr ! n)
+sumTyCon arity
+ | arity > mAX_SUM_SIZE
+ = fst (mk_sum arity) -- Build one specially
+
+ | arity < 2
+ = panic ("sumTyCon: Arity starts from 2. (arity: " ++ show arity ++ ")")
+
+ | otherwise
+ = fst (unboxedSumArr ! arity)
-- | Data constructor for i-th alternative of a n-ary unboxed sum.
sumDataCon :: ConTag -- Alternative
@@ -870,13 +877,17 @@ sumDataCon :: ConTag -- Alternative
-> DataCon
sumDataCon alt arity
| alt > arity
- = panic ("sumDataCon: index out of bounds: alt "
+ = panic ("sumDataCon: index out of bounds: alt: "
++ show alt ++ " > arity " ++ show arity)
| alt <= 0
= panic ("sumDataCon: Alts start from 1. (alt: " ++ show alt
++ ", arity: " ++ show arity ++ ")")
+ | arity < 2
+ = panic ("sumDataCon: Arity starts from 2. (alt: " ++ show alt
+ ++ ", arity: " ++ show arity ++ ")")
+
| arity > mAX_SUM_SIZE
= snd (mk_sum arity) ! (alt - 1) -- Build one specially
@@ -887,7 +898,7 @@ sumDataCon alt arity
-- indexed by the arity of the sum and the inner array is indexed by
-- the alternative.
unboxedSumArr :: Array Int (TyCon, Array Int DataCon)
-unboxedSumArr = listArray (0,mAX_SUM_SIZE) [mk_sum i | i <- [0..mAX_SUM_SIZE]]
+unboxedSumArr = listArray (2,mAX_SUM_SIZE) [mk_sum i | i <- [2..mAX_SUM_SIZE]]
-- | Create type constructor and data constructors for n-ary unboxed sum.
mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon)
diff --git a/testsuite/tests/unboxedsums/all.T b/testsuite/tests/unboxedsums/all.T
index 274045f..0b948b1 100644
--- a/testsuite/tests/unboxedsums/all.T
+++ b/testsuite/tests/unboxedsums/all.T
@@ -1,3 +1,8 @@
+test('unboxedsums_unit_tests',
+ only_ways(['normal']),
+ compile_and_run,
+ ['-package ghc'])
+
test('unarise', omit_ways(['ghci']), compile_and_run, [''])
test('unboxedsums1', omit_ways(['ghci']), compile_and_run, [''])
test('unboxedsums2', omit_ways(['ghci']), compile_and_run, [''])
diff --git a/testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs b/testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs
new file mode 100644
index 0000000..d7a8d33
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs
@@ -0,0 +1,26 @@
+module Main where
+
+import TysWiredIn
+import UniqSet
+import Unique
+
+import System.IO
+import Control.Monad
+
+main :: IO ()
+main = sequence_
+ [ uniq_tests ]
+
+
+uniq_tests :: IO ()
+uniq_tests = do
+ let tycons = map sumTyCon [2 .. 20]
+ datacons = [ sumDataCon alt arity | arity <- [ 2 .. 20 ]
+ , alt <- [ 1 .. arity ] ]
+
+ us = mkUniqSet (map getUnique tycons)
+ `unionUniqSets` mkUniqSet (map getUnique datacons)
+
+ when (sizeUniqSet us /= length tycons + length datacons) $ do
+ hPutStrLn stderr "Sum cons/tycons have same uniques."
+ hFlush stderr
More information about the ghc-commits
mailing list