Commit 64efee62 authored by Michal Terepeta's avatar Michal Terepeta Committed by ian@well-typed.com

Add fixity information to primops (ticket #6026)

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