From 6821c8a47c0fc61a2d989d368f926cc0ded776e9 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Wed, 23 Apr 2008 16:11:15 +0000 Subject: [PATCH] Add 123## literals for Word# --- compiler/deSugar/DsMeta.hs | 12 ++++++++---- compiler/deSugar/MatchLit.lhs | 5 ++++- compiler/hsSyn/Convert.lhs | 1 + compiler/hsSyn/HsLit.lhs | 3 +++ compiler/parser/Lexer.x | 8 +++++++- compiler/parser/Parser.y.pp | 3 +++ compiler/prelude/TysWiredIn.lhs | 12 ++++++++++++ compiler/typecheck/Inst.lhs | 9 ++++++--- compiler/typecheck/TcHsSyn.lhs | 1 + compiler/typecheck/TcType.lhs | 3 ++- 10 files changed, 47 insertions(+), 10 deletions(-) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index ecef1f1..bbdf08b 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1260,6 +1260,7 @@ repLiteral :: HsLit -> DsM (Core TH.Lit) repLiteral lit = do lit' <- case lit of HsIntPrim i -> mk_integer i + HsWordPrim w -> mk_integer w HsInt i -> mk_integer i HsFloatPrim r -> mk_rational r HsDoublePrim r -> mk_rational r @@ -1273,6 +1274,7 @@ repLiteral lit HsInteger _ _ -> Just integerLName HsInt _ -> Just integerLName HsIntPrim _ -> Just intPrimLName + HsWordPrim _ -> Just wordPrimLName HsFloatPrim _ -> Just floatPrimLName HsDoublePrim _ -> Just doublePrimLName HsChar _ -> Just charLName @@ -1368,7 +1370,7 @@ templateHaskellNames = [ mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, -- Lit - charLName, stringLName, integerLName, intPrimLName, + charLName, stringLName, integerLName, intPrimLName, wordPrimLName, floatPrimLName, doublePrimLName, rationalLName, -- Pat litPName, varPName, tupPName, conPName, tildePName, infixPName, @@ -1473,6 +1475,7 @@ charLName = libFun (fsLit "charL") charLIdKey stringLName = libFun (fsLit "stringL") stringLIdKey integerLName = libFun (fsLit "integerL") integerLIdKey intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey +wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey rationalLName = libFun (fsLit "rationalL") rationalLIdKey @@ -1658,9 +1661,10 @@ charLIdKey = mkPreludeMiscIdUnique 210 stringLIdKey = mkPreludeMiscIdUnique 211 integerLIdKey = mkPreludeMiscIdUnique 212 intPrimLIdKey = mkPreludeMiscIdUnique 213 -floatPrimLIdKey = mkPreludeMiscIdUnique 214 -doublePrimLIdKey = mkPreludeMiscIdUnique 215 -rationalLIdKey = mkPreludeMiscIdUnique 216 +wordPrimLIdKey = mkPreludeMiscIdUnique 214 +floatPrimLIdKey = mkPreludeMiscIdUnique 215 +doublePrimLIdKey = mkPreludeMiscIdUnique 216 +rationalLIdKey = mkPreludeMiscIdUnique 217 -- data Pat = ... litPIdKey = mkPreludeMiscIdUnique 220 diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 24dff8d..31d3c28 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -69,6 +69,7 @@ dsLit :: HsLit -> DsM CoreExpr dsLit (HsStringPrim s) = return (mkLit (MachStr s)) dsLit (HsCharPrim c) = return (mkLit (MachChar c)) dsLit (HsIntPrim i) = return (mkLit (MachInt i)) +dsLit (HsWordPrim w) = return (mkLit (MachWord w)) dsLit (HsFloatPrim f) = return (mkLit (MachFloat f)) dsLit (HsDoublePrim d) = return (mkLit (MachDouble d)) @@ -103,6 +104,7 @@ hsLitKey :: HsLit -> Literal -- It only works for primitive types and strings; -- others have been removed by tidy hsLitKey (HsIntPrim i) = mkMachInt i +hsLitKey (HsWordPrim w) = mkMachWord w hsLitKey (HsCharPrim c) = MachChar c hsLitKey (HsStringPrim s) = MachStr s hsLitKey (HsFloatPrim f) = MachFloat f @@ -128,7 +130,7 @@ hsOverLitKey (HsIsString s _ _) False = MachStr s \begin{code} tidyLitPat :: HsLit -> Pat Id -- Result has only the following HsLits: --- HsIntPrim, HsCharPrim, HsFloatPrim +-- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim -- HsDoublePrim, HsStringPrim, HsString -- * HsInteger, HsRat, HsInt can't show up in LitPats -- * We get rid of HsChar right here @@ -145,6 +147,7 @@ tidyLitPat lit = LitPat lit tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id tidyNPat over_lit mb_neg eq | isIntTy (overLitType over_lit) = mk_con_pat intDataCon (HsIntPrim int_val) + | isWordTy (overLitType over_lit) = mk_con_pat wordDataCon (HsWordPrim int_val) | isFloatTy (overLitType over_lit) = mk_con_pat floatDataCon (HsFloatPrim rat_val) | isDoubleTy (overLitType over_lit) = mk_con_pat doubleDataCon (HsDoublePrim rat_val) -- | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val) diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 5113f77..42aa001 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -455,6 +455,7 @@ cvtOverLit (StringL s) = do { let { s' = mkFastString s }; force s'; return $ cvtLit :: Lit -> CvtM HsLit cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i } +cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w } cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f } cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f } cvtLit (CharL c) = do { force c; return $ HsChar c } diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs index a85bc62..55260eb 100644 --- a/compiler/hsSyn/HsLit.lhs +++ b/compiler/hsSyn/HsLit.lhs @@ -34,6 +34,7 @@ data HsLit | HsInt Integer -- Genuinely an Int; arises from TcGenDeriv, -- and from TRANSLATION | HsIntPrim Integer -- Unboxed Int + | HsWordPrim Integer -- Unboxed Word | HsInteger Integer Type -- Genuinely an integer; arises only from TRANSLATION -- (overloaded literals are done with HsOverLit) | HsRat Rational Type -- Genuinely a rational; arises only from TRANSLATION @@ -48,6 +49,7 @@ instance Eq HsLit where (HsStringPrim x1) == (HsStringPrim x2) = x1==x2 (HsInt x1) == (HsInt x2) = x1==x2 (HsIntPrim x1) == (HsIntPrim x2) = x1==x2 + (HsWordPrim x1) == (HsWordPrim x2) = x1==x2 (HsInteger x1 _) == (HsInteger x2 _) = x1==x2 (HsRat x1 _) == (HsRat x2 _) = x1==x2 (HsFloatPrim x1) == (HsFloatPrim x2) = x1==x2 @@ -112,6 +114,7 @@ instance Outputable HsLit where ppr (HsFloatPrim f) = rational f <> char '#' ppr (HsDoublePrim d) = rational d <> text "##" ppr (HsIntPrim i) = integer i <> char '#' + ppr (HsWordPrim w) = integer w <> text "##" -- in debug mode, print the expression that it's resolved to, too instance OutputableBndr id => Outputable (HsOverLit id) where diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index b73e430..e891cae 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -385,7 +385,7 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } } <0> { - -- Unboxed ints (:: Int#) + -- Unboxed ints (:: Int#) and words (:: Word#) -- It's simpler (and faster?) to give separate cases to the negatives, -- especially considering octal/hexadecimal prefixes. @decimal \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal } @@ -395,6 +395,10 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } @negative 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal } @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal } + @decimal \# \# / { ifExtension magicHashEnabled } { tok_primword 0 2 decimal } + 0[oO] @octal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal } + 0[xX] @hexadecimal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal } + -- Unboxed floats and doubles (:: Float#, :: Double#) -- prim_{float,double} work with signed literals @signed @floating_point \# / { ifExtension magicHashEnabled } { init_strtoken 1 tok_primfloat } @@ -533,6 +537,7 @@ data Token | ITprimchar Char | ITprimstring FastString | ITprimint Integer + | ITprimword Integer | ITprimfloat Rational | ITprimdouble Rational @@ -971,6 +976,7 @@ tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = -- some conveniences for use with tok_integral tok_num = tok_integral ITinteger tok_primint = tok_integral ITprimint +tok_primword = tok_integral ITprimword positive positive = id negative = negate decimal = (10,octDecDigit) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index c9e843e..bfcc856 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -316,6 +316,7 @@ incorrect. PRIMCHAR { L _ (ITprimchar _) } PRIMSTRING { L _ (ITprimstring _) } PRIMINTEGER { L _ (ITprimint _) } + PRIMWORD { L _ (ITprimword _) } PRIMFLOAT { L _ (ITprimfloat _) } PRIMDOUBLE { L _ (ITprimdouble _) } @@ -1862,6 +1863,7 @@ literal :: { Located HsLit } : CHAR { L1 $ HsChar $ getCHAR $1 } | STRING { L1 $ HsString $ getSTRING $1 } | PRIMINTEGER { L1 $ HsIntPrim $ getPRIMINTEGER $1 } + | PRIMWORD { L1 $ HsWordPrim $ getPRIMWORD $1 } | PRIMCHAR { L1 $ HsCharPrim $ getPRIMCHAR $1 } | PRIMSTRING { L1 $ HsStringPrim $ getPRIMSTRING $1 } | PRIMFLOAT { L1 $ HsFloatPrim $ getPRIMFLOAT $1 } @@ -1955,6 +1957,7 @@ getRATIONAL (L _ (ITrational x)) = x getPRIMCHAR (L _ (ITprimchar x)) = x getPRIMSTRING (L _ (ITprimstring x)) = x getPRIMINTEGER (L _ (ITprimint x)) = x +getPRIMWORD (L _ (ITprimword x)) = x getPRIMFLOAT (L _ (ITprimfloat x)) = x getPRIMDOUBLE (L _ (ITprimdouble x)) = x getTH_ID_SPLICE (L _ (ITidEscape x)) = x diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 7606ff6..ccdfbe2 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -28,6 +28,8 @@ module TysWiredIn ( intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName, intTy, + wordTyCon, wordDataCon, wordTyConName, wordTy, + listTyCon, nilDataCon, consDataCon, listTyCon_RDR, consDataCon_RDR, listTyConName, mkListTy, @@ -352,6 +354,16 @@ intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon \end{code} \begin{code} +wordTy :: Type +wordTy = mkTyConTy wordTyCon + +wordTyCon :: TyCon +wordTyCon = pcNonRecDataTyCon wordTyConName [] [wordDataCon] +wordDataCon :: DataCon +wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon +\end{code} + +\begin{code} floatTy :: Type floatTy = mkTyConTy floatTyCon diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index b1636a7..0c18a01 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -474,6 +474,7 @@ newMethod inst_loc id tys = do shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId) shortCutIntLit i ty | isIntTy ty && inIntRange i = Just (HsLit (HsInt i)) + | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i)) | isIntegerTy ty = Just (HsLit (HsInteger i ty)) | otherwise = shortCutFracLit (fromInteger i) ty -- The 'otherwise' case is important @@ -484,11 +485,13 @@ shortCutIntLit i ty shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId) shortCutFracLit f ty - | isFloatTy ty = Just (mk_lit floatDataCon (HsFloatPrim f)) - | isDoubleTy ty = Just (mk_lit doubleDataCon (HsDoublePrim f)) + | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim f)) + | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f)) | otherwise = Nothing where - mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit) + +mkLit :: DataCon -> HsLit -> HsExpr Id +mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit) shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId) shortCutStringLit s ty diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 3804903..160170f 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -118,6 +118,7 @@ hsLitType (HsString str) = stringTy hsLitType (HsStringPrim s) = addrPrimTy hsLitType (HsInt i) = intTy hsLitType (HsIntPrim i) = intPrimTy +hsLitType (HsWordPrim w) = wordPrimTy hsLitType (HsInteger i ty) = ty hsLitType (HsRat _ ty) = ty hsLitType (HsFloatPrim f) = floatPrimTy diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 8212cf5..f68d949 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -62,7 +62,7 @@ module TcType ( tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX, eqKind, isSigmaTy, isOverloadedTy, isRigidTy, isBoxyTy, - isDoubleTy, isFloatTy, isIntTy, isStringTy, + isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, isIntegerTy, isBoolTy, isUnitTy, isCharTy, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, isOpenSynTyConApp, @@ -972,6 +972,7 @@ isFloatTy = is_tc floatTyConKey isDoubleTy = is_tc doubleTyConKey isIntegerTy = is_tc integerTyConKey isIntTy = is_tc intTyConKey +isWordTy = is_tc wordTyConKey isBoolTy = is_tc boolTyConKey isUnitTy = is_tc unitTyConKey isCharTy = is_tc charTyConKey -- 1.7.10.4