Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Support GHC as the only compiler to build happy generated parsers #278

Merged
merged 4 commits into from
Jun 23, 2024
Merged

Support GHC as the only compiler to build happy generated parsers #278

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
8af39e4
Assume GHC as the only compiler to build happy parsers, see #268
Kariiem Jun 15, 2024
3d5a060
Inline CPP macros that are defined unconditionally
Kariiem Jun 19, 2024
6c3719d
Rename FastInt to Happy_Int to avoid name clashes with user code
Kariiem Jun 22, 2024
1457766
Update Makefile
sgraf812 Jun 23, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
23 changes: 3 additions & 20 deletions packages/backend-glr/data/GLR_Lib.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -65,7 +64,6 @@ fakeimport DATA

{- borrowed from GenericTemplate.hs -}

#ifdef HAPPY_GHC
#define ILIT(n) n#
#define BANG !
#define IBOX(n) (I# (n))
Expand All @@ -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 ())
Expand Down
201 changes: 86 additions & 115 deletions packages/backend-lalr/data/HappyTemplate.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,61 +1,36 @@
-- $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

-- 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))

data Happy_IntList = HappyCons FAST_INT Happy_IntList

#define CONS(h,t) (HappyCons (h) (t))
type Happy_Int = Happy_GHC_Exts.Int#
data Happy_IntList = HappyCons Happy_Int Happy_IntList

#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)
# 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 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

Expand Down Expand Up @@ -85,144 +60,142 @@ 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# :: Happy_Int)) -> 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# :: 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# :: Happy_Int))
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# :: Happy_Int))
then EQ(indexShortOffAddr happyCheck off_i, i)
else Prelude.False
action
| check = indexShortOffAddr happyTable off_i
| Prelude.otherwise = indexShortOffAddr happyDefActions st

#ifdef HAPPY_GHC
indexShortOffAddr (HappyA# arr) off =
Happy_GHC_Exts.narrow16Int# i
where
i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)
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)
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
#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

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# :: 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)

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# :: Happy_Int)) 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#::Happy_Int)) 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

-----------------------------------------------------------------------------
Expand All @@ -239,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:

Expand All @@ -259,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 :: Happy_Int -> a -> a
happyTcHack x y = y
{-# INLINE happyTcHack #-}
#endif

-----------------------------------------------------------------------------
-- Seq-ing. If the --strict flag is given, then Happy emits
Expand Down
Loading
Loading