Add fixity information to primops (ticket #6026)

9 files changed, 102 insertions, 7 deletions

diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index f3b4fead5d..887f91b280 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -240,6 +240,7 @@ PRIMOP_BITS_NAMES = primop-data-decl.hs-incl        \
                     primop-code-size.hs-incl        \
                     primop-can-fail.hs-incl         \
                     primop-strictness.hs-incl       \
+                    primop-fixity.hs-incl       \
                     primop-primop-info.hs-incl
 
 PRIMOP_BITS_STAGE1 = $(addprefix compiler/stage1/build/,$(PRIMOP_BITS_NAMES))
@@ -276,6 +277,8 @@ compiler/stage$1/build/primop-can-fail.hs-incl: compiler/stage$1/build/primops.t
 	"$$(GENPRIMOP_INPLACE)" --can-fail           < $$< > $$@
 compiler/stage$1/build/primop-strictness.hs-incl: compiler/stage$1/build/primops.txt $$(GENPRIMOP_INPLACE)
 	"$$(GENPRIMOP_INPLACE)" --strictness         < $$< > $$@
+compiler/stage$1/build/primop-fixity.hs-incl: compiler/stage$1/build/primops.txt $$(GENPRIMOP_INPLACE)
+	"$$(GENPRIMOP_INPLACE)" --fixity             < $$< > $$@
 compiler/stage$1/build/primop-primop-info.hs-incl: compiler/stage$1/build/primops.txt $$(GENPRIMOP_INPLACE)
 	"$$(GENPRIMOP_INPLACE)" --primop-primop-info < $$< > $$@
 
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index f978577b23..6dfac27d5d 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -38,6 +38,7 @@ import TcRnMonad
 import Constants
 import PrelNames
 import PrelInfo
+import PrimOp   ( allThePrimOps, primOpFixity, primOpOcc )
 import MkId     ( seqId )
 import Rules
 import Annotations
@@ -604,8 +605,9 @@ ghcPrimIface
         mi_fix_fn  = mkIfaceFixCache fixities
     }           
   where
-    fixities = [(getOccName seqId, Fixity 0 InfixR)]
-                        -- seq is infixr 0
+    fixities = (getOccName seqId, Fixity 0 InfixR)  -- seq is infixr 0
+             : mapMaybe mkFixity allThePrimOps
+    mkFixity op = (,) (primOpOcc op) <$> primOpFixity op
 \end{code}
 
 %*********************************************************
diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs
index b055376060..1aaca36274 100644
--- a/compiler/prelude/PrimOp.lhs
+++ b/compiler/prelude/PrimOp.lhs
@@ -13,7 +13,7 @@ module PrimOp (
 
         primOpOutOfLine, primOpCodeSize,
         primOpOkForSpeculation, primOpOkForSideEffects,
-        primOpIsCheap,
+        primOpIsCheap, primOpFixity,
 
         getPrimOpResultInfo,  PrimOpResultInfo(..),
 
@@ -31,7 +31,7 @@ import OccName          ( OccName, pprOccName, mkVarOccFS )
 import TyCon            ( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) )
 import Type             ( Type, mkForAllTys, mkFunTy, mkFunTys, tyConAppTyCon,
                           typePrimRep )
-import BasicTypes       ( Arity, TupleSort(..) )
+import BasicTypes       ( Arity, Fixity(..), FixityDirection(..), TupleSort(..) )
 import ForeignCall      ( CLabelString )
 import Unique           ( Unique, mkPrimOpIdUnique )
 import Outputable
@@ -153,6 +153,17 @@ primOpStrictness :: PrimOp -> Arity -> StrictSig
 
 %************************************************************************
 %*                                                                      *
+\subsubsection{Fixity}
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+primOpFixity :: PrimOp -> Maybe Fixity
+#include "primop-fixity.hs-incl"
+\end{code}
+
+%************************************************************************
+%*                                                                      *
 \subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops}
 %*                                                                      *
 %************************************************************************
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 92d33547d1..c6e1b47706 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -46,6 +46,7 @@ defaults
    commutable       = False
    code_size        = { primOpCodeSizeDefault }
    strictness       = { \ arity -> mkStrictSig (mkTopDmdType (replicate arity lazyDmd) TopRes) }
+   fixity           = Nothing
 
 
 -- Currently, documentation is produced using latex, so contents of
@@ -166,13 +167,16 @@ primtype Int#
 primop   IntAddOp    "+#"    Dyadic
    Int# -> Int# -> Int#
    with commutable = True
+        fixity = infixl 6
 
 primop   IntSubOp    "-#"    Dyadic   Int# -> Int# -> Int#
+   with fixity = infixl 6
 
 primop   IntMulOp    "*#" 
    Dyadic   Int# -> Int# -> Int#
    {Low word of signed integer multiply.}
    with commutable = True
+        fixity = infixl 7
 
 primop   IntMulMayOfloOp  "mulIntMayOflo#" 
    Dyadic   Int# -> Int# -> Int#
@@ -225,18 +229,26 @@ primop   IntSubCOp   "subIntC#"    GenPrimOp   Int# -> Int# -> (# Int#, Int# #)
    with code_size = 2
 
 primop   IntGtOp  ">#"   Compare   Int# -> Int# -> Bool
+   with fixity = infix 4
+
 primop   IntGeOp  ">=#"   Compare   Int# -> Int# -> Bool
+   with fixity = infix 4
 
 primop   IntEqOp  "==#"   Compare
    Int# -> Int# -> Bool
    with commutable = True
+        fixity = infix 4
 
 primop   IntNeOp  "/=#"   Compare
    Int# -> Int# -> Bool
    with commutable = True
+        fixity = infix 4
 
 primop   IntLtOp  "<#"   Compare   Int# -> Int# -> Bool
+   with fixity = infix 4
+
 primop   IntLeOp  "<=#"   Compare   Int# -> Int# -> Bool
+   with fixity = infix 4
 
 primop   ChrOp   "chr#"   GenPrimOp   Int# -> Char#
    with code_size = 0
@@ -401,32 +413,44 @@ section "Double#"
 primtype Double#
 
 primop   DoubleGtOp ">##"   Compare   Double# -> Double# -> Bool
+   with fixity = infix 4
+
 primop   DoubleGeOp ">=##"   Compare   Double# -> Double# -> Bool
+   with fixity = infix 4
 
 primop DoubleEqOp "==##"   Compare
    Double# -> Double# -> Bool
    with commutable = True
+        fixity = infix 4
 
 primop DoubleNeOp "/=##"   Compare
    Double# -> Double# -> Bool
    with commutable = True
+        fixity = infix 4
 
 primop   DoubleLtOp "<##"   Compare   Double# -> Double# -> Bool
+   with fixity = infix 4
+
 primop   DoubleLeOp "<=##"   Compare   Double# -> Double# -> Bool
+   with fixity = infix 4
 
 primop   DoubleAddOp   "+##"   Dyadic
    Double# -> Double# -> Double#
    with commutable = True
+        fixity = infixl 6
 
 primop   DoubleSubOp   "-##"   Dyadic   Double# -> Double# -> Double#
+   with fixity = infixl 6
 
 primop   DoubleMulOp   "*##"   Dyadic
    Double# -> Double# -> Double#
    with commutable = True
+        fixity = infixl 7
 
 primop   DoubleDivOp   "/##"   Dyadic
    Double# -> Double# -> Double#
    with can_fail = True
+        fixity = infixl 7
 
 primop   DoubleNegOp   "negateDouble#"  Monadic   Double# -> Double#
 
diff --git a/utils/genprimopcode/Lexer.x b/utils/genprimopcode/Lexer.x
index 24ea7b2ef6..3ee35d4dab 100644
--- a/utils/genprimopcode/Lexer.x
+++ b/utils/genprimopcode/Lexer.x
@@ -51,6 +51,11 @@ words :-
     <0>         "Monadic"           { mkT TMonadic }
     <0>         "Compare"           { mkT TCompare }
     <0>         "GenPrimOp"         { mkT TGenPrimOp }
+    <0>         "fixity"            { mkT TFixity }
+    <0>         "infix"             { mkT TInfixN }
+    <0>         "infixl"            { mkT TInfixL }
+    <0>         "infixr"            { mkT TInfixR }
+    <0>         "Nothing"           { mkT TNothing }
     <0>         "thats_all_folks"   { mkT TThatsAllFolks }
     <0>         [a-z][a-zA-Z0-9\#_]* { mkTv TLowerName }
     <0>         [A-Z][a-zA-Z0-9\#_]* { mkTv TUpperName }
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index 4635e84149..debdd27102 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -61,6 +61,11 @@ main = getArgs >>= \args ->
                                        "strictness" 
                                        "primOpStrictness" p_o_specs)
 
+                      "--fixity"
+                         -> putStr (gen_switch_from_attribs
+                                       "fixity"
+                                       "primOpFixity" p_o_specs)
+
                       "--primop-primop-info" 
                          -> putStr (gen_primop_info p_o_specs)
 
@@ -94,6 +99,7 @@ known_args
        "--code-size",
        "--can-fail",
        "--strictness",
+       "--fixity",
        "--primop-primop-info",
        "--primop-tag",
        "--primop-list",
@@ -142,6 +148,7 @@ gen_hs_source (Info defaults entries) =
            opt (OptionTrue n)     = n ++ " = True"
            opt (OptionString n v) = n ++ " = { " ++ v ++ "}"
            opt (OptionInteger n v) = n ++ " = " ++ show v
+           opt (OptionFixity mf) = "fixity" ++ " = " ++ show mf
 
            hdr s@(Section {})                    = sec s
            hdr (PrimOpSpec { name = n })         = wrapOp n ++ ","
@@ -159,7 +166,9 @@ gen_hs_source (Info defaults entries) =
 
            spec o = comm : decls
              where decls = case o of
-                        PrimOpSpec { name = n, ty = t }   ->
+                        PrimOpSpec { name = n, ty = t, opts = options } ->
+                            [ pprFixity fixity n | OptionFixity (Just fixity) <- options ]
+                            ++
                             [ wrapOp n ++ " :: " ++ pprTy t,
                               wrapOp n ++ " = let x = x in x" ]
                         PseudoOpSpec { name = n, ty = t } ->
@@ -191,6 +200,8 @@ gen_hs_source (Info defaults entries) =
            escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
                 where special = "/'`\"@<"
 
+           pprFixity (Fixity i d) n = pprFixityDir d ++ " " ++ show i ++ " " ++ n
+
 pprTy :: Ty -> String
 pprTy = pty
     where
@@ -396,6 +407,7 @@ gen_latex_doc (Info defaults entries)
               ++ mk_commutable o ++ "}{"
               ++ mk_needs_wrapper o ++ "}{"
               ++ mk_can_fail o ++ "}{"
+              ++ mk_fixity o ++ "}{"
               ++ latex_encode (mk_strictness o) ++ "}{"
               ++ "}"
 
@@ -411,14 +423,20 @@ gen_latex_doc (Info defaults entries)
                Just (OptionFalse _) -> if_false
                Just (OptionString _ _) -> error "String value for boolean option"
                Just (OptionInteger _ _) -> error "Integer value for boolean option"
+               Just (OptionFixity _) -> error "Fixity value for boolean option"
                Nothing -> ""
            
            mk_strictness o = 
              case lookup_attrib "strictness" o of
                Just (OptionString _ s) -> s  -- for now
-               Just _ -> error "Boolean value for strictness"
+               Just _ -> error "Wrong value for strictness"
                Nothing -> "" 
 
+           mk_fixity o = case lookup_attrib "fixity" o of
+             Just (OptionFixity (Just (Fixity i d)))
+               -> pprFixityDir d ++ " " ++ show i
+             _ -> ""
+
            zencode xs =
              case maybe_tuple xs of
                 Just n  -> n            -- Tuples go to Z2T etc
@@ -554,6 +572,7 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries)
          getAltRhs (OptionTrue _)     = "True"
          getAltRhs (OptionInteger _ i) = show i
          getAltRhs (OptionString _ s) = s
+         getAltRhs (OptionFixity mf) = show mf
 
          mkAlt po
             = case lookup_attrib attrib_name (opts po) of
@@ -675,6 +694,11 @@ ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"
 ppType other
    = error ("ppType: can't handle: " ++ show other ++ "\n")
 
+pprFixityDir :: FixityDirection -> String
+pprFixityDir InfixN = "infix"
+pprFixityDir InfixL = "infixl"
+pprFixityDir InfixR = "infixr"
+
 listify :: [String] -> String
 listify ss = "[" ++ concat (intersperse ", " ss) ++ "]"
 
@@ -696,4 +720,3 @@ tyconsIn (TyUTup tys)   = foldr union [] $ map tyconsIn tys
 
 arity :: Ty -> Int
 arity = length . fst . flatTys
-
diff --git a/utils/genprimopcode/Parser.y b/utils/genprimopcode/Parser.y
index b55ff1ed1c..c5c6080548 100644
--- a/utils/genprimopcode/Parser.y
+++ b/utils/genprimopcode/Parser.y
@@ -43,6 +43,11 @@ import Syntax
     monadic         { TMonadic }
     compare         { TCompare }
     genprimop       { TGenPrimOp }
+    fixity          { TFixity }
+    infix           { TInfixN }
+    infixl          { TInfixL }
+    infixr          { TInfixR }
+    nothing         { TNothing }
     thats_all_folks { TThatsAllFolks }
     lowerName       { TLowerName $$ }
     upperName       { TUpperName $$ }
@@ -67,6 +72,14 @@ pOption : lowerName '=' false               { OptionFalse  $1 }
         | lowerName '=' true                { OptionTrue   $1 }
         | lowerName '=' pStuffBetweenBraces { OptionString $1 $3 }
         | lowerName '=' integer             { OptionInteger $1 $3 }
+        | fixity    '=' pInfix              { OptionFixity $3 }
+
+pInfix :: { Maybe Fixity }
+pInfix : infix  integer { Just $ Fixity $2 InfixN }
+       | infixl integer { Just $ Fixity $2 InfixL }
+       | infixr integer { Just $ Fixity $2 InfixR }
+       | nothing        { Nothing }
+
 
 pEntries :: { [Entry] }
 pEntries : pEntry pEntries { $1 : $2 }
diff --git a/utils/genprimopcode/ParserM.hs b/utils/genprimopcode/ParserM.hs
index faedab9165..5109814022 100644
--- a/utils/genprimopcode/ParserM.hs
+++ b/utils/genprimopcode/ParserM.hs
@@ -84,6 +84,11 @@ data Token = TEOF
            | TString String
            | TNoBraces String
            | TInteger Int
+           | TFixity
+           | TInfixN
+           | TInfixL
+           | TInfixR
+           | TNothing
     deriving Show
 
 -- Actions
diff --git a/utils/genprimopcode/Syntax.hs b/utils/genprimopcode/Syntax.hs
index 10dda25c2e..b2e983d48c 100644
--- a/utils/genprimopcode/Syntax.hs
+++ b/utils/genprimopcode/Syntax.hs
@@ -40,6 +40,7 @@ data Option
    | OptionTrue   String          -- name = True
    | OptionString String String   -- name = { ... unparsed stuff ... }
    | OptionInteger String Int     -- name = <int>
+   | OptionFixity (Maybe Fixity)  -- fixity = infix{,l,r} <int> | Nothing
      deriving Show
 
 -- categorises primops
@@ -59,6 +60,13 @@ data Ty
 type TyVar = String
 type TyCon = String
 
+-- Follow definitions of Fixity and FixityDirection in GHC
+
+data Fixity = Fixity Int FixityDirection
+  deriving (Eq, Show)
+
+data FixityDirection = InfixN | InfixL | InfixR
+  deriving (Eq, Show)
 
 ------------------------------------------------------------------
 -- Sanity checking -----------------------------------------------
@@ -121,6 +129,7 @@ get_attrib_name (OptionFalse nm) = nm
 get_attrib_name (OptionTrue nm)  = nm
 get_attrib_name (OptionString nm _) = nm
 get_attrib_name (OptionInteger nm _) = nm
+get_attrib_name (OptionFixity _) = "fixity"
 
 lookup_attrib :: String -> [Option] -> Maybe Option
 lookup_attrib _ [] = Nothing