From 8af39e4d853b1c4a7ef38922e4dd4cc55e3af7a2 Mon Sep 17 00:00:00 2001 From: Karim Taha Date: Sat, 15 Jun 2024 15:17:49 +0300 Subject: [PATCH 1/4] Assume GHC as the only compiler to build happy parsers, see #268 --- packages/backend-glr/data/GLR_Lib.hs | 23 +----- packages/backend-lalr/data/HappyTemplate.hs | 65 +++++------------ .../backend-lalr/src/Happy/Backend/LALR.hs | 17 ++--- .../src/Happy/Backend/LALR/ProduceCode.lhs | 71 +++---------------- src/Main.lhs | 27 ++----- tests/Makefile | 26 +++---- 6 files changed, 54 insertions(+), 175 deletions(-) diff --git a/packages/backend-glr/data/GLR_Lib.hs b/packages/backend-glr/data/GLR_Lib.hs index abc660af..bcc88445 100644 --- a/packages/backend-glr/data/GLR_Lib.hs +++ b/packages/backend-glr/data/GLR_Lib.hs @@ -37,8 +37,8 @@ ) where -#if defined(HAPPY_GHC) && !defined(__GLASGOW_HASKELL__) -# error `HAPPY_GHC` is defined but this code isn't being built with GHC. +#if !defined(__GLASGOW_HASKELL__) +# error This code isn't being built with GHC. #endif import Data.Char @@ -48,10 +48,9 @@ import Control.Applicative (Applicative(..)) import Control.Monad (foldM, ap) import Data.Maybe (fromJust) import Data.List (insertBy, nub, maximumBy, partition, find, groupBy, delete) -#if defined(HAPPY_GHC) + import GHC.Prim import GHC.Exts -#endif #if defined(HAPPY_DEBUG) import System.IO @@ -65,7 +64,6 @@ fakeimport DATA {- borrowed from GenericTemplate.hs -} -#ifdef HAPPY_GHC #define ILIT(n) n# #define BANG ! #define IBOX(n) (I# (n)) @@ -87,21 +85,6 @@ fakeimport DATA #define NEGATE(n) (negateInt# (n)) #define IF_GHC(x) (x) -#else - -#define ILIT(n) (n) -#define BANG -#define IBOX(n) (n) -#define FAST_INT Int -#define ULT(n,m) (n < m) -#define GTE(n,m) (n >= m) -#define UEQ(n,m) (n == m) -#define PLUS(n,m) (n + m) -#define MINUS(n,m) (n - m) -#define TIMES(n,m) (n * m) -#define NEGATE(n) (negate (n)) -#define IF_GHC(x) -#endif #if defined(HAPPY_DEBUG) #define DEBUG_TRACE(s) (happyTrace (s) $ return ()) diff --git a/packages/backend-lalr/data/HappyTemplate.hs b/packages/backend-lalr/data/HappyTemplate.hs index ba5de31c..b33dbc82 100644 --- a/packages/backend-lalr/data/HappyTemplate.hs +++ b/packages/backend-lalr/data/HappyTemplate.hs @@ -1,40 +1,27 @@ -- $Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp $ -#ifdef HAPPY_GHC -# if !defined(__GLASGOW_HASKELL__) -# error `HAPPY_GHC` is defined but this code isn't being built with GHC. -# endif -# define ILIT(n) n# -# define IBOX(n) (Happy_GHC_Exts.I# (n)) -# define FAST_INT Happy_GHC_Exts.Int# +#if !defined(__GLASGOW_HASKELL__) +# error This code isn't being built with GHC. +#endif +#define ILIT(n) n# +#define IBOX(n) (Happy_GHC_Exts.I# (n)) +#define FAST_INT Happy_GHC_Exts.Int# -- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -# if __GLASGOW_HASKELL__ > 706 -# define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Prelude.Bool) -# define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Prelude.Bool) -# define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Prelude.Bool) -# else -# define LT(n,m) (n Happy_GHC_Exts.<# m) -# define GTE(n,m) (n Happy_GHC_Exts.>=# m) -# define EQ(n,m) (n Happy_GHC_Exts.==# m) -# endif -# define PLUS(n,m) (n Happy_GHC_Exts.+# m) -# define MINUS(n,m) (n Happy_GHC_Exts.-# m) -# define TIMES(n,m) (n Happy_GHC_Exts.*# m) -# define NEGATE(n) (Happy_GHC_Exts.negateInt# (n)) -# define IF_GHC(x) (x) +#if __GLASGOW_HASKELL__ > 706 +# define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Prelude.Bool) +# define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Prelude.Bool) +# define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Prelude.Bool) #else -# define ILIT(n) (n) -# define IBOX(n) (n) -# define FAST_INT Prelude.Int -# define LT(n,m) (n Prelude.< m) -# define GTE(n,m) (n Prelude.>= m) -# define EQ(n,m) (n Prelude.== m) -# define PLUS(n,m) (n Prelude.+ m) -# define MINUS(n,m) (n Prelude.- m) -# define TIMES(n,m) (n Prelude.* m) -# define NEGATE(n) (Prelude.negate (n)) -# define IF_GHC(x) +# define LT(n,m) (n Happy_GHC_Exts.<# m) +# define GTE(n,m) (n Happy_GHC_Exts.>=# m) +# define EQ(n,m) (n Happy_GHC_Exts.==# m) #endif +#define PLUS(n,m) (n Happy_GHC_Exts.+# m) +#define MINUS(n,m) (n Happy_GHC_Exts.-# m) +#define TIMES(n,m) (n Happy_GHC_Exts.*# m) +#define NEGATE(n) (Happy_GHC_Exts.negateInt# (n)) +#define IF_GHC(x) (x) + data Happy_IntList = HappyCons FAST_INT Happy_IntList @@ -47,9 +34,6 @@ data Happy_IntList = HappyCons FAST_INT Happy_IntList #define IF_ARRAYS(x) (x) #if defined(HAPPY_COERCE) -# if !defined(HAPPY_GHC) -# error `HAPPY_COERCE` requires `HAPPY_GHC` -# endif # define GET_ERROR_TOKEN(x) (case Happy_GHC_Exts.unsafeCoerce# x of { IBOX(i) -> i }) # define MK_ERROR_TOKEN(i) (Happy_GHC_Exts.unsafeCoerce# IBOX(i)) # define MK_TOKEN(x) (happyInTok (x)) @@ -117,7 +101,6 @@ happyDoAction i tk st | check = indexShortOffAddr happyTable off_i | Prelude.otherwise = indexShortOffAddr happyDefActions st -#ifdef HAPPY_GHC indexShortOffAddr (HappyA# arr) off = Happy_GHC_Exts.narrow16Int# i where @@ -125,25 +108,15 @@ indexShortOffAddr (HappyA# arr) off = high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) off' = off Happy_GHC_Exts.*# 2# -#else -indexShortOffAddr arr off = arr Happy_Data_Array.! off -#endif {-# INLINE happyLt #-} happyLt x y = LT(x,y) -#ifdef HAPPY_GHC readArrayBit arr bit = Bits.testBit IBOX(indexShortOffAddr arr ((unbox_int bit) `Happy_GHC_Exts.iShiftRA#` 4#)) (bit `Prelude.mod` 16) where unbox_int (Happy_GHC_Exts.I# x) = x -#else -readArrayBit arr bit = - Bits.testBit IBOX(indexShortOffAddr arr (bit `Prelude.div` 16)) (bit `Prelude.mod` 16) -#endif -#ifdef HAPPY_GHC data HappyAddr = HappyA# Happy_GHC_Exts.Addr# -#endif ----------------------------------------------------------------------------- -- Shifting a token diff --git a/packages/backend-lalr/src/Happy/Backend/LALR.hs b/packages/backend-lalr/src/Happy/Backend/LALR.hs index 54651041..ade8fe78 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR.hs +++ b/packages/backend-lalr/src/Happy/Backend/LALR.hs @@ -18,11 +18,9 @@ magicFilter magicName = case magicName of filter_output [] = [] in filter_output -importsToInject :: Bool -> Bool -> String -importsToInject ghc debug = concat ["\n", import_array, import_bits, glaexts_import, debug_imports, applicative_imports] +importsToInject :: Bool -> String +importsToInject debug = concat ["\n", import_array, import_bits, import_glaexts, debug_imports, applicative_imports] where - glaexts_import | ghc = import_glaexts - | otherwise = "" debug_imports | debug = import_debug | otherwise = "" applicative_imports = import_applicative @@ -36,16 +34,13 @@ importsToInject ghc debug = concat ["\n", import_array, import_bits, glaexts_imp import_applicative = "import Control.Applicative(Applicative(..))\n" ++ "import Control.Monad (ap)\n" -langExtsToInject :: Bool -> [String] -langExtsToInject ghc - | ghc = ["MagicHash", "BangPatterns", "TypeSynonymInstances", "FlexibleInstances"] - | otherwise = [] +langExtsToInject :: [String] +langExtsToInject = ["MagicHash", "BangPatterns", "TypeSynonymInstances", "FlexibleInstances"] -defines :: Bool -> Bool -> Bool -> String -defines debug ghc coerce = unlines [ "#define " ++ d ++ " 1" | d <- vars_to_define ] +defines :: Bool -> Bool -> String +defines debug coerce = unlines [ "#define " ++ d ++ " 1" | d <- vars_to_define ] where vars_to_define = concat [ [ "HAPPY_DEBUG" | debug ] - , [ "HAPPY_GHC" | ghc ] , [ "HAPPY_COERCE" | coerce ] ] diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index b134699b..838b012e 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -35,7 +35,6 @@ Produce the complete output file. > -> Maybe String -- module header > -> Maybe String -- module trailer > -> Bool -- use coercions -> -> Bool -- use ghc extensions > -> Bool -- strict parser > -> String @@ -62,7 +61,7 @@ Produce the complete output file. > , error_sig = error_sig' > }) > action goto lang_exts module_header module_trailer -> coerce ghc strict +> coerce strict > = ( top_opts > . maybestr module_header . nl > . str comment @@ -90,10 +89,9 @@ Produce the complete output file. > -- #ifdefs. For now I'm just disabling all of them. > > partTySigs_opts = ifGeGhc710 (str "{-# LANGUAGE PartialTypeSignatures #-}" . nl) -> -> intMaybeHash | ghc = str "Happy_GHC_Exts.Int#" -> | otherwise = str "Prelude.Int" -> + +> intMaybeHash = str "Happy_GHC_Exts.Int#" + > -- Parsing monad and its constraints > pty = str monad_tycon > pcont = str monad_context @@ -101,11 +99,10 @@ Produce the complete output file. > -- If GHC is enabled, wrap the content in a CPP ifdef that includes the > -- content and tests whether the GHC version is >= 7.10.3 > ifGeGhc710 :: (String -> String) -> String -> String -> ifGeGhc710 content | ghc = str "#if __GLASGOW_HASKELL__ >= 710" . nl -> . content -> . str "#endif" . nl -> | otherwise = id -> +> ifGeGhc710 content = str "#if __GLASGOW_HASKELL__ >= 710" . nl +> . content +> . str "#endif" . nl + > n_missing_types = length (filter isNothing (elems nt_types)) > happyAbsSyn = str "(HappyAbsSyn " . str wild_tyvars . str ")" > where wild_tyvars = unwords (replicate n_missing_types "_") @@ -505,7 +502,6 @@ machinery to discard states in the parser... action array indexed by (terminal * last_state) + state > produceActionArray -> | ghc > = str "happyActOffsets :: HappyAddr\n" > . str "happyActOffsets = HappyA# \"" --" > . str (checkedHexChars min_off act_offs) @@ -540,55 +536,13 @@ action array indexed by (terminal * last_state) + state > . str (hexChars table) > . str "\"#\n\n" --" -> | otherwise -> = str "happyActOffsets :: Happy_Data_Array.Array Prelude.Int Prelude.Int\n" -> . str "happyActOffsets = Happy_Data_Array.listArray (0," -> . shows n_states . str ") ([" -> . interleave' "," (map shows act_offs) -> . str "\n\t])\n\n" -> -> . str "happyGotoOffsets :: Happy_Data_Array.Array Prelude.Int Prelude.Int\n" -> . str "happyGotoOffsets = Happy_Data_Array.listArray (0," -> . shows n_states . str ") ([" -> . interleave' "," (map shows goto_offs) -> . str "\n\t])\n\n" -> -> . str "happyAdjustOffset :: Prelude.Int -> Prelude.Int\n" -> . str "happyAdjustOffset = Prelude.id\n\n" -> -> . str "happyDefActions :: Happy_Data_Array.Array Prelude.Int Prelude.Int\n" -> . str "happyDefActions = Happy_Data_Array.listArray (0," -> . shows n_states . str ") ([" -> . interleave' "," (map shows defaults) -> . str "\n\t])\n\n" -> -> . str "happyCheck :: Happy_Data_Array.Array Prelude.Int Prelude.Int\n" -> . str "happyCheck = Happy_Data_Array.listArray (0," -> . shows table_size . str ") ([" -> . interleave' "," (map shows check) -> . str "\n\t])\n\n" -> -> . str "happyTable :: Happy_Data_Array.Array Prelude.Int Prelude.Int\n" -> . str "happyTable = Happy_Data_Array.listArray (0," -> . shows table_size . str ") ([" -> . interleave' "," (map shows table) -> . str "\n\t])\n\n" > produceExpListArray -> | ghc > = str "happyExpList :: HappyAddr\n" > . str "happyExpList = HappyA# \"" --" > . str (hexChars explist) > . str "\"#\n\n" --" -> | otherwise -> = str "happyExpList :: Happy_Data_Array.Array Prelude.Int Prelude.Int\n" -> . str "happyExpList = Happy_Data_Array.listArray (0," -> . shows table_size . str ") ([" -> . interleave' "," (map shows explist) -> . str "\n\t])\n\n" - -> (_, last_state) = bounds action -> n_states = last_state + 1 + > n_terminals = length terms > n_nonterminals = length nonterms - n_starts -- lose %starts > @@ -596,8 +550,6 @@ action array indexed by (terminal * last_state) + state > = mkTables action goto first_nonterm' fst_term > n_terminals n_nonterminals n_starts (bounds token_names') > -> table_size = length table - 1 -> > produceReduceArray > = {- str "happyReduceArr :: Array Int a\n" -} > str "happyReduceArr = Happy_Data_Array.array (" @@ -610,8 +562,7 @@ action array indexed by (terminal * last_state) + state > n_rules = length prods - 1 :: Int -> showInt i | ghc = shows i . showChar '#' -> | otherwise = shows i +> showInt i = shows i . showChar '#' This lets examples like: @@ -781,7 +732,7 @@ directive determines the API of the provided function. > . str unmonad > . str "happySomeParser where\n" > . str " happySomeParser = happyThen (happyParse " -> . (if ghc then shows no . str "#" else shows no) +> . shows no . str "#" > . maybe_tks > . str ") " > . brack' (if coerce diff --git a/src/Main.lhs b/src/Main.lhs index 4279b2bb..93aa7207 100644 --- a/src/Main.lhs +++ b/src/Main.lhs @@ -173,7 +173,6 @@ of code we should generate, and where it should go: > outfilename <- getOutputFileName fl_name cli > opt_coerce <- getCoerce cli > opt_strict <- getStrict cli -> opt_ghc <- getGhc cli > opt_debug <- getDebug cli Add any special options or imports required by the parsing machinery. @@ -181,7 +180,7 @@ Add any special options or imports required by the parsing machinery. > let > header = Just $ > (case hd of Just s -> s; Nothing -> "") -> ++ importsToInject opt_ghc opt_debug +> ++ importsToInject opt_debug > if OptGLR `elem` cli @@ -198,14 +197,12 @@ Branch off to GLR parser production > filtering > | OptGLR_Filter `elem` cli = UseFiltering > | otherwise = NoFiltering -> ghc_exts -> | OptGhcTarget `elem` cli = UseGhcExts -> (importsToInject opt_ghc opt_debug) +> ghc_exts = UseGhcExts +> (importsToInject opt_debug) Unlike below, don't always pass CPP, because only one of the files needs it. -> (langExtsToInject opt_ghc) -> | otherwise = NoGhcExts +> (langExtsToInject) > template' <- getTemplate glrBackendDataDir cli > let basename = takeWhile (/='.') outfilename > let tbls = (action,goto) @@ -259,14 +256,13 @@ and generate the code. CPP is needed in all cases with unified template -> ("CPP" : langExtsToInject opt_ghc) +> ("CPP" : langExtsToInject) > header > tl > opt_coerce -> opt_ghc > opt_strict -> defines' = defines opt_debug opt_ghc opt_coerce +> defines' = defines opt_debug opt_coerce > (if outfilename == "-" then putStr else writeFile outfilename) > (magicFilter magic_name (outfile ++ defines' ++ templ)) @@ -414,16 +410,7 @@ Extract various command-line options. > f:fs -> return (Just (map toLower (last (f:fs)))) > getCoerce :: [CLIFlags] -> IO Bool -> getCoerce cli -> = if OptUseCoercions `elem` cli -> then if OptGhcTarget `elem` cli -> then return True -> else dieHappy ("-c/--coerce may only be used " ++ -> "in conjunction with -g/--ghc\n") -> else return False - -> getGhc :: [CLIFlags] -> IO Bool -> getGhc cli = return (OptGhcTarget `elem` cli) +> getCoerce cli = return (OptUseCoercions `elem` cli) > getStrict :: [CLIFlags] -> IO Bool > getStrict cli = return (OptStrict `elem` cli) diff --git a/tests/Makefile b/tests/Makefile index c90299f1..d2df586a 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -27,7 +27,7 @@ endif HC ?= ghc HC_OPTS=-Wall -Werror -.PRECIOUS: %.n.hs %.g.hs %.o %.exe %.bin +.PRECIOUS: %.n.hs %.o %.exe %.bin ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32" HS_PROG_EXT = .exe @@ -53,24 +53,18 @@ TEST_HAPPY_OPTS = --strict %.n.hs : %.ly $(HAPPY) $(TEST_HAPPY_OPTS) $< -o $@ -%.g.hs : %.ly - $(HAPPY) $(TEST_HAPPY_OPTS) -g $< -o $@ - -%.gc.hs : %.ly - $(HAPPY) $(TEST_HAPPY_OPTS) -gc $< -o $@ +%.c.hs : %.ly + $(HAPPY) $(TEST_HAPPY_OPTS) -c $< -o $@ %.n.hs : %.y $(HAPPY) $(TEST_HAPPY_OPTS) $< -o $@ -%.g.hs : %.y - $(HAPPY) $(TEST_HAPPY_OPTS) -g $< -o $@ - -%.gc.hs : %.y - $(HAPPY) $(TEST_HAPPY_OPTS) -gc $< -o $@ +%.c.hs : %.y + $(HAPPY) $(TEST_HAPPY_OPTS) -c $< -o $@ -CLEAN_FILES += *.n.hs *.g.hs *.gc.hs *.info *.hi *.bin *.exe *.o *.run.stdout *.run.stderr +CLEAN_FILES += *.n.hs *.c.hs *.info *.hi *.bin *.exe *.o *.run.stdout *.run.stderr -ALL_TEST_HS = $(shell echo $(TESTS) | sed -e 's/\([^\. ]*\)\.\(l\)\{0,1\}y/\1.n.hs \1.g.hs \1.gc.hs/g') +ALL_TEST_HS = $(shell echo $(TESTS) | sed -e 's/\([^\. ]*\)\.\(l\)\{0,1\}y/\1.n.hs \1.c.hs/g') ALL_TESTS = $(patsubst %.hs, %.run, $(ALL_TEST_HS)) @@ -101,11 +95,7 @@ check-todo:: $(HC) Test.hs -o happy_test ./happy_test -rm -f ./happy_test - $(HAPPY) $(TEST_HAPPY_OPTS) -gd Test.ly - $(HC) Test.hs -o happy_test - ./happy_test - -rm -f ./happy_test - $(HAPPY) $(TEST_HAPPY_OPTS) -gcd Test.ly + $(HAPPY) $(TEST_HAPPY_OPTS) -cd Test.ly $(HC) Test.hs -o happy_test ./happy_test -rm -f ./happy_test From 3d5a060d5a88415fd1fb9077a29e7ef129acee64 Mon Sep 17 00:00:00 2001 From: Karim Taha Date: Wed, 19 Jun 2024 21:00:20 +0300 Subject: [PATCH 2/4] Inline CPP macros that are defined unconditionally --- packages/backend-lalr/data/HappyTemplate.hs | 146 ++++++++++---------- 1 file changed, 72 insertions(+), 74 deletions(-) diff --git a/packages/backend-lalr/data/HappyTemplate.hs b/packages/backend-lalr/data/HappyTemplate.hs index b33dbc82..7c58da37 100644 --- a/packages/backend-lalr/data/HappyTemplate.hs +++ b/packages/backend-lalr/data/HappyTemplate.hs @@ -3,9 +3,7 @@ #if !defined(__GLASGOW_HASKELL__) # error This code isn't being built with GHC. #endif -#define ILIT(n) n# -#define IBOX(n) (Happy_GHC_Exts.I# (n)) -#define FAST_INT Happy_GHC_Exts.Int# + -- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. #if __GLASGOW_HASKELL__ > 706 # define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Prelude.Bool) @@ -20,26 +18,19 @@ #define MINUS(n,m) (n Happy_GHC_Exts.-# m) #define TIMES(n,m) (n Happy_GHC_Exts.*# m) #define NEGATE(n) (Happy_GHC_Exts.negateInt# (n)) -#define IF_GHC(x) (x) - -data Happy_IntList = HappyCons FAST_INT Happy_IntList +type FastInt = Happy_GHC_Exts.Int# +data Happy_IntList = HappyCons FastInt Happy_IntList -#define CONS(h,t) (HappyCons (h) (t)) - -#define ERROR_TOK ILIT(0) -#define DO_ACTION(state,i,tk,sts,stk) happyDoAction i tk state sts (stk) -#define HAPPYSTATE(i) (i) -#define GOTO(action) happyGoto -#define IF_ARRAYS(x) (x) +#define ERROR_TOK 0# #if defined(HAPPY_COERCE) -# define GET_ERROR_TOKEN(x) (case Happy_GHC_Exts.unsafeCoerce# x of { IBOX(i) -> i }) -# define MK_ERROR_TOKEN(i) (Happy_GHC_Exts.unsafeCoerce# IBOX(i)) +# define GET_ERROR_TOKEN(x) (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# i) -> i }) +# define MK_ERROR_TOKEN(i) (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# i)) # define MK_TOKEN(x) (happyInTok (x)) #else -# define GET_ERROR_TOKEN(x) (case x of { HappyErrorToken IBOX(i) -> i }) -# define MK_ERROR_TOKEN(i) (HappyErrorToken IBOX(i)) +# define GET_ERROR_TOKEN(x) (case x of { HappyErrorToken (Happy_GHC_Exts.I# i) -> i }) +# define MK_ERROR_TOKEN(i) (HappyErrorToken (Happy_GHC_Exts.I# i)) # define MK_TOKEN(x) (HappyTerminal (x)) #endif @@ -69,32 +60,34 @@ happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll happyAccept ERROR_TOK tk st sts (_ `HappyStk` ans `HappyStk` _) = happyReturn1 ans happyAccept j tk st sts (HappyStk ans _) = - IF_GHC(happyTcHack j IF_ARRAYS(happyTcHack st)) (happyReturn1 ans) + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) ----------------------------------------------------------------------------- -- Arrays only: do the next action happyDoAction i tk st - = DEBUG_TRACE("state: " ++ show IBOX(st) ++ - ",\ttoken: " ++ show IBOX(i) ++ + = DEBUG_TRACE("state: " ++ show (Happy_GHC_Exts.I# st) ++ + ",\ttoken: " ++ show (Happy_GHC_Exts.I# i) ++ ",\taction: ") case action of - ILIT(0) -> DEBUG_TRACE("fail.\n") - happyFail (happyExpListPerState (IBOX(st) :: Prelude.Int)) i tk st - ILIT(-1) -> DEBUG_TRACE("accept.\n") - happyAccept i tk st - n | LT(n,(ILIT(0) :: FAST_INT)) -> DEBUG_TRACE("reduce (rule " ++ show rule + 0# -> DEBUG_TRACE("fail.\n") + happyFail (happyExpListPerState ((Happy_GHC_Exts.I# st) :: Prelude.Int)) i tk st + -1# -> DEBUG_TRACE("accept.\n") + happyAccept i tk st + n | LT(n,(0# :: FastInt)) -> DEBUG_TRACE("reduce (rule " ++ show rule ++ ")") (happyReduceArr Happy_Data_Array.! rule) i tk st - where rule = IBOX(NEGATE(PLUS(n,(ILIT(1) :: FAST_INT)))) - n -> DEBUG_TRACE("shift, enter state " - ++ show IBOX(new_state) - ++ "\n") - happyShift new_state i tk st - where new_state = MINUS(n,(ILIT(1) :: FAST_INT)) + where + rule = Happy_GHC_Exts.I# (NEGATE(PLUS(n,(1# :: FastInt)))) + + n -> DEBUG_TRACE("shift, enter state " + ++ show (Happy_GHC_Exts.I# new_state) + ++ "\n") + happyShift new_state i tk st + where new_state = MINUS(n,(1# :: FastInt)) where off = happyAdjustOffset (indexShortOffAddr happyActOffsets st) off_i = PLUS(off, i) - check = if GTE(off_i,(ILIT(0) :: FAST_INT)) + check = if GTE(off_i,(0# :: FastInt)) then EQ(indexShortOffAddr happyCheck off_i, i) else Prelude.False action @@ -113,7 +106,8 @@ indexShortOffAddr (HappyA# arr) off = happyLt x y = LT(x,y) readArrayBit arr bit = - Bits.testBit IBOX(indexShortOffAddr arr ((unbox_int bit) `Happy_GHC_Exts.iShiftRA#` 4#)) (bit `Prelude.mod` 16) + Bits.testBit (Happy_GHC_Exts.I# (indexShortOffAddr arr ((unbox_int bit) `Happy_GHC_Exts.iShiftRA#` 4#))) + (bit `Prelude.mod` 16) where unbox_int (Happy_GHC_Exts.I# x) = x data HappyAddr = HappyA# Happy_GHC_Exts.Addr# @@ -123,79 +117,85 @@ data HappyAddr = HappyA# Happy_GHC_Exts.Addr# happyShift new_state ERROR_TOK tk st sts stk@(x `HappyStk` _) = let i = GET_ERROR_TOKEN(x) in --- trace "shifting the error token" $ - DO_ACTION(new_state,i,tk,CONS(st,sts),stk) +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons st sts) stk happyShift new_state i tk st sts stk = - happyNewToken new_state CONS(st,sts) (MK_TOKEN(tk)`HappyStk`stk) + happyNewToken new_state (HappyCons st sts) (MK_TOKEN(tk) `HappyStk` stk) -- happyReduce is specialised for the common cases. happySpecReduce_0 i fn ERROR_TOK tk st sts stk = happyFail [] ERROR_TOK tk st sts stk -happySpecReduce_0 nt fn j tk st@(HAPPYSTATE(action)) sts stk - = GOTO(action) nt j tk st CONS(st,sts) (fn `HappyStk` stk) +happySpecReduce_0 nt fn j tk st sts stk + = happyGoto nt j tk st (HappyCons st sts) (fn `HappyStk` stk) happySpecReduce_1 i fn ERROR_TOK tk st sts stk = happyFail [] ERROR_TOK tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@(CONS(st@HAPPYSTATE(action),_)) (v1`HappyStk`stk') +happySpecReduce_1 nt fn j tk _ sts@(HappyCons st _) (v1 `HappyStk` stk') = let r = fn v1 in - happySeq r (GOTO(action) nt j tk st sts (r `HappyStk` stk')) + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) happySpecReduce_2 i fn ERROR_TOK tk st sts stk = happyFail [] ERROR_TOK tk st sts stk -happySpecReduce_2 nt fn j tk _ CONS(_,sts@(CONS(st@HAPPYSTATE(action),_))) (v1`HappyStk`v2`HappyStk`stk') +happySpecReduce_2 nt fn j tk _ + (HappyCons _ sts@(HappyCons st _)) + (v1 `HappyStk` v2 `HappyStk` stk') = let r = fn v1 v2 in - happySeq r (GOTO(action) nt j tk st sts (r `HappyStk` stk')) + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) happySpecReduce_3 i fn ERROR_TOK tk st sts stk = happyFail [] ERROR_TOK tk st sts stk -happySpecReduce_3 nt fn j tk _ CONS(_,CONS(_,sts@(CONS(st@HAPPYSTATE(action),_)))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') +happySpecReduce_3 nt fn j tk _ + (HappyCons _ (HappyCons _ sts@(HappyCons st _))) + (v1 `HappyStk` v2 `HappyStk` v3 `HappyStk` stk') = let r = fn v1 v2 v3 in - happySeq r (GOTO(action) nt j tk st sts (r `HappyStk` stk')) + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) happyReduce k i fn ERROR_TOK tk st sts stk = happyFail [] ERROR_TOK tk st sts stk happyReduce k nt fn j tk st sts stk - = case happyDrop MINUS(k,(ILIT(1) :: FAST_INT)) sts of - sts1@(CONS(st1@HAPPYSTATE(action),_)) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (GOTO(action) nt j tk st1 sts1 r) + = case happyDrop MINUS(k,(1# :: FastInt)) sts of + sts1@(HappyCons st1 _) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) happyMonadReduce k nt fn ERROR_TOK tk st sts stk = happyFail [] ERROR_TOK tk st sts stk happyMonadReduce k nt fn j tk st sts stk = - case happyDrop k CONS(st,sts) of - sts1@(CONS(st1@HAPPYSTATE(action),_)) -> + case happyDrop k (HappyCons st sts) of + sts1@(HappyCons st1 _) -> let drop_stk = happyDropStk k stk in - happyThen1 (fn stk tk) (\r -> GOTO(action) nt j tk st1 sts1 (r `HappyStk` drop_stk)) + happyThen1 (fn stk tk) + (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) happyMonad2Reduce k nt fn ERROR_TOK tk st sts stk = happyFail [] ERROR_TOK tk st sts stk happyMonad2Reduce k nt fn j tk st sts stk = - case happyDrop k CONS(st,sts) of - sts1@(CONS(st1@HAPPYSTATE(action),_)) -> - let drop_stk = happyDropStk k stk - off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st1) - off_i = PLUS(off, nt) - new_state = indexShortOffAddr happyTable off_i + case happyDrop k (HappyCons st sts) of + sts1@(HappyCons st1 _) -> + let drop_stk = happyDropStk k stk + off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st1) + off_i = PLUS(off, nt) + new_state = indexShortOffAddr happyTable off_i in - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + happyThen1 (fn stk tk) + (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) -happyDrop ILIT(0) l = l -happyDrop n CONS(_,t) = happyDrop MINUS(n,(ILIT(1) :: FAST_INT)) t +happyDrop 0# l = l +happyDrop n (HappyCons _ t) = happyDrop MINUS(n,(1# :: FastInt)) t -happyDropStk ILIT(0) l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk MINUS(n,(ILIT(1)::FAST_INT)) xs +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk MINUS(n,(1#::FastInt)) xs ----------------------------------------------------------------------------- -- Moving to a new state after a reduction happyGoto nt j tk st = - DEBUG_TRACE(", goto state " ++ show IBOX(new_state) ++ "\n") + DEBUG_TRACE(", goto state " ++ show (Happy_GHC_Exts.I# new_state) ++ "\n") happyDoAction j tk new_state - where off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st) - off_i = PLUS(off, nt) + where off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st) + off_i = PLUS(off, nt) new_state = indexShortOffAddr happyTable off_i ----------------------------------------------------------------------------- @@ -212,17 +212,17 @@ happyFail explist ERROR_TOK tk old_st _ stk@(x `HappyStk` _) = for now --SDM -- discard a state -happyFail ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts) - (saved_tok `HappyStk` _ `HappyStk` stk) = +happyFail ERROR_TOK tk old_st (HappyCons action sts) + (saved_tok `HappyStk` _ `HappyStk` stk) = -- trace ("discarding state, depth " ++ show (length stk)) $ - DO_ACTION(action,ERROR_TOK,tk,sts,(saved_tok`HappyStk`stk)) + happyDoAction ERROR_TOK tk action sts (saved_tok`HappyStk`stk) -} -- Enter error recovery: generate an error token, -- save the old token and carry on. -happyFail explist i tk HAPPYSTATE(action) sts stk = --- trace "entering error recovery" $ - DO_ACTION(action,ERROR_TOK,tk,sts, MK_ERROR_TOKEN(i) `HappyStk` stk) +happyFail explist i tk action sts stk = +-- trace "entering error recovery" $ + happyDoAction ERROR_TOK tk action sts (MK_ERROR_TOKEN(i) `HappyStk` stk) -- Internal happy errors: @@ -232,11 +232,9 @@ notHappyAtAll = Prelude.error "Internal Happy error\n" ----------------------------------------------------------------------------- -- Hack to get the typechecker to accept our action functions -#if defined(HAPPY_GHC) -happyTcHack :: Happy_GHC_Exts.Int# -> a -> a +happyTcHack :: FastInt -> a -> a happyTcHack x y = y {-# INLINE happyTcHack #-} -#endif ----------------------------------------------------------------------------- -- Seq-ing. If the --strict flag is given, then Happy emits From 6c3719da82ff6e05950ff12a15cf19b2b90be950 Mon Sep 17 00:00:00 2001 From: Karim Taha Date: Sat, 22 Jun 2024 20:28:06 +0300 Subject: [PATCH 3/4] Rename FastInt to Happy_Int to avoid name clashes with user code --- packages/backend-lalr/data/HappyTemplate.hs | 20 ++++++++++---------- tests/Makefile | 8 +------- 2 files changed, 11 insertions(+), 17 deletions(-) diff --git a/packages/backend-lalr/data/HappyTemplate.hs b/packages/backend-lalr/data/HappyTemplate.hs index 7c58da37..25ff5d4b 100644 --- a/packages/backend-lalr/data/HappyTemplate.hs +++ b/packages/backend-lalr/data/HappyTemplate.hs @@ -19,8 +19,8 @@ #define TIMES(n,m) (n Happy_GHC_Exts.*# m) #define NEGATE(n) (Happy_GHC_Exts.negateInt# (n)) -type FastInt = Happy_GHC_Exts.Int# -data Happy_IntList = HappyCons FastInt Happy_IntList +type Happy_Int = Happy_GHC_Exts.Int# +data Happy_IntList = HappyCons Happy_Int Happy_IntList #define ERROR_TOK 0# @@ -74,20 +74,20 @@ happyDoAction i tk st happyFail (happyExpListPerState ((Happy_GHC_Exts.I# st) :: Prelude.Int)) i tk st -1# -> DEBUG_TRACE("accept.\n") happyAccept i tk st - n | LT(n,(0# :: FastInt)) -> DEBUG_TRACE("reduce (rule " ++ show rule + n | LT(n,(0# :: Happy_Int)) -> DEBUG_TRACE("reduce (rule " ++ show rule ++ ")") (happyReduceArr Happy_Data_Array.! rule) i tk st where - rule = Happy_GHC_Exts.I# (NEGATE(PLUS(n,(1# :: FastInt)))) + rule = Happy_GHC_Exts.I# (NEGATE(PLUS(n,(1# :: Happy_Int)))) n -> DEBUG_TRACE("shift, enter state " ++ show (Happy_GHC_Exts.I# new_state) ++ "\n") happyShift new_state i tk st - where new_state = MINUS(n,(1# :: FastInt)) + where new_state = MINUS(n,(1# :: Happy_Int)) where off = happyAdjustOffset (indexShortOffAddr happyActOffsets st) off_i = PLUS(off, i) - check = if GTE(off_i,(0# :: FastInt)) + check = if GTE(off_i,(0# :: Happy_Int)) then EQ(indexShortOffAddr happyCheck off_i, i) else Prelude.False action @@ -155,7 +155,7 @@ happySpecReduce_3 nt fn j tk _ happyReduce k i fn ERROR_TOK tk st sts stk = happyFail [] ERROR_TOK tk st sts stk happyReduce k nt fn j tk st sts stk - = case happyDrop MINUS(k,(1# :: FastInt)) sts of + = case happyDrop MINUS(k,(1# :: Happy_Int)) sts of sts1@(HappyCons st1 _) -> let r = fn stk in -- it doesn't hurt to always seq here... happyDoSeq r (happyGoto nt j tk st1 sts1 r) @@ -183,10 +183,10 @@ happyMonad2Reduce k nt fn j tk st sts stk = (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) happyDrop 0# l = l -happyDrop n (HappyCons _ t) = happyDrop MINUS(n,(1# :: FastInt)) t +happyDrop n (HappyCons _ t) = happyDrop MINUS(n,(1# :: Happy_Int)) t happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk MINUS(n,(1#::FastInt)) xs +happyDropStk n (x `HappyStk` xs) = happyDropStk MINUS(n,(1#::Happy_Int)) xs ----------------------------------------------------------------------------- -- Moving to a new state after a reduction @@ -232,7 +232,7 @@ notHappyAtAll = Prelude.error "Internal Happy error\n" ----------------------------------------------------------------------------- -- Hack to get the typechecker to accept our action functions -happyTcHack :: FastInt -> a -> a +happyTcHack :: Happy_Int -> a -> a happyTcHack x y = y {-# INLINE happyTcHack #-} diff --git a/tests/Makefile b/tests/Makefile index d2df586a..e34b0407 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -53,18 +53,12 @@ TEST_HAPPY_OPTS = --strict %.n.hs : %.ly $(HAPPY) $(TEST_HAPPY_OPTS) $< -o $@ -%.c.hs : %.ly - $(HAPPY) $(TEST_HAPPY_OPTS) -c $< -o $@ - %.n.hs : %.y $(HAPPY) $(TEST_HAPPY_OPTS) $< -o $@ -%.c.hs : %.y - $(HAPPY) $(TEST_HAPPY_OPTS) -c $< -o $@ - CLEAN_FILES += *.n.hs *.c.hs *.info *.hi *.bin *.exe *.o *.run.stdout *.run.stderr -ALL_TEST_HS = $(shell echo $(TESTS) | sed -e 's/\([^\. ]*\)\.\(l\)\{0,1\}y/\1.n.hs \1.c.hs/g') +ALL_TEST_HS = $(shell echo $(TESTS) | sed -e 's/\([^\. ]*\)\.\(l\)\{0,1\}y/\1.n.hs /g') ALL_TESTS = $(patsubst %.hs, %.run, $(ALL_TEST_HS)) From 14577665c5414836d26fc0a520bc56519ae8c036 Mon Sep 17 00:00:00 2001 From: Sebastian Graf Date: Sun, 23 Jun 2024 09:37:20 +0200 Subject: [PATCH 4/4] Update Makefile Applying a few suggestions on the PR --- tests/Makefile | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/tests/Makefile b/tests/Makefile index e34b0407..399126d1 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -25,9 +25,9 @@ endif # [2021-07-14, PR #196](https://github.com/haskell/happy/pull/196) # HC ?= ghc -HC_OPTS=-Wall -Werror +HC_OPTS=-package array -Wall -Werror -.PRECIOUS: %.n.hs %.o %.exe %.bin +.PRECIOUS: %.n.hs %.c.hs %.o %.exe %.bin ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32" HS_PROG_EXT = .exe @@ -50,15 +50,21 @@ ERROR_TESTS = error001.y #TEST_HAPPY_OPTS = --strict --template=.. TEST_HAPPY_OPTS = --strict -%.n.hs : %.ly +%.n.hs : %.y $(HAPPY) $(TEST_HAPPY_OPTS) $< -o $@ -%.n.hs : %.y +%.n.hs : %.ly + $(HAPPY) $(TEST_HAPPY_OPTS) -c $< -o $@ + +%.c.hs : %.y $(HAPPY) $(TEST_HAPPY_OPTS) $< -o $@ +%.c.hs : %.ly + $(HAPPY) $(TEST_HAPPY_OPTS) -c $< -o $@ + CLEAN_FILES += *.n.hs *.c.hs *.info *.hi *.bin *.exe *.o *.run.stdout *.run.stderr -ALL_TEST_HS = $(shell echo $(TESTS) | sed -e 's/\([^\. ]*\)\.\(l\)\{0,1\}y/\1.n.hs /g') +ALL_TEST_HS = $(shell echo $(TESTS) | sed -e 's/\([^\. ]*\)\.\(l\)\{0,1\}y/\1.n.hs \1.c.hs/g') ALL_TESTS = $(patsubst %.hs, %.run, $(ALL_TEST_HS))