{-# LANGUAGE CPP #-} -- Optimisation problem. There are two missed opportunities for optimisation in alex_scan_tkn, below. module Main (main) where import Data.Char ( ord ) import Control.Monad.ST import Control.Monad (when) import Data.STRef import GHC.ST import Data.Array import Data.Char (ord) import Data.Array.Base (unsafeAt) import GHC.Exts alex_base :: AlexAddr alex_base = AlexA# "\xf8\xff\xfd\xff\x02\x00\x4c\x00"# alex_table :: AlexAddr alex_table = AlexA# "\x00\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x03\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# alex_check :: AlexAddr alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x27\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# alex_deflt :: AlexAddr alex_deflt = AlexA# "\xff\xff\xff\xff\xff\xff\xff\xff"# alex_accept = listArray (0::Int,3) [[],[],[(AlexAcc 0 (alex_action_0) Nothing Nothing)],[(AlexAcc 1 (alex_action_1) Nothing Nothing)]] word (_,_,input) len = return (take len input) scanner str = runAlex str $ do let loop i = do tok <- alexScan; if tok == "stopped." || tok == "error." then return i else do let i' = i+1 in i' `seq` loop i' loop 0 alexEOF (_,_,"") = return "stopped." alexEOF (_,_,rest) = return "error." main = do s <- getContents print (scanner s) alex_action_0 = skip alex_action_1 = word -- {-# LINE 1 "GenericTemplate.hs" #-} -- ------------------------------------------------------------------------ ----- -- ALEX TEMPLATE -- -- (c) Chris Dornan and Simon Marlow 2003 -- ------------------------------------------------------------------------ ----- -- Token positions -- `Posn' records the location of a token in the input text. It has three -- fields: the address (number of chacaters preceding the token), line number -- and column of a token within the file. `start_pos' gives the position of the -- start of the file and `eof_pos' a standard encoding for the end of file. -- `move_pos' calculates the new position after traversing a given character, -- assuming the usual eight character tab stops. data AlexPosn = AlexPn !Int !Int !Int deriving (Eq,Show) alexStartPos :: AlexPosn alexStartPos = AlexPn 0 1 1 alexMove :: AlexPosn -> Char -> AlexPosn alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+7) `div` 8)*8+1) alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1) 1 alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) -- ------------------------------------------------------------------------ ----- -- The Alex monad -- -- Compile with -funbox-strict-fields for best results! data AlexState s = AlexState { alex_pos :: !(STRef s AlexPosn),-- position at current input location alex_inp :: !(STRef s String), -- the current input alex_chr :: !(STRef s Char), -- the character before the input alex_scd :: !(STRef s Int) -- the current startcode } type AlexInput = (AlexPosn,Char,String) alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (p,c,s) = c runAlex :: String -> Alex a -> a runAlex input (Alex f) = runST (do inp_r <- newSTRef input chr_r <- newSTRef '\n' pos_r <- newSTRef alexStartPos scd_r <- newSTRef 0 f (AlexState {alex_pos = pos_r, alex_inp = inp_r, alex_chr = chr_r, alex_scd = scd_r})) --TODO include error support newtype Alex a = Alex { unAlex :: forall s. AlexState s -> ST s a } instance Monad Alex where (Alex m) >>= k = Alex (\s -> m s >>= \a -> unAlex (k a) s) return a = Alex (\s -> return a) alexGetChar :: Alex (Maybe Char) alexGetChar = Alex (\st@AlexState{ alex_inp=inp_r, alex_chr=chr_r, alex_pos=pos_r } -> do inp <- readSTRef inp_r pos <- readSTRef pos_r case inp of [] -> return Nothing (c:s) -> do writeSTRef inp_r s writeSTRef chr_r c let p' = alexMove pos c p' `seq` writeSTRef pos_r p' return (Just c) ) alexGetInput :: Alex AlexInput alexGetInput = Alex (\s@AlexState{alex_pos=pos_r,alex_chr=chr_r,alex_inp=inp_r} -> do inp <- readSTRef inp_r chr <- readSTRef chr_r pos <- readSTRef pos_r return (pos,chr,inp) ) alexSetInput :: AlexInput -> Alex () alexSetInput (pos,chr,inp) = Alex (\s@AlexState{alex_pos=pos_r,alex_chr=chr_r,alex_inp=inp_r} -> do writeSTRef inp_r inp writeSTRef pos_r pos writeSTRef chr_r chr ) alexGetStartCode :: Alex Int alexGetStartCode = Alex (\s@AlexState{alex_scd=scd_r} -> do readSTRef scd_r) alexSetStartCode :: Int -> Alex () alexSetStartCode sc = Alex (\s@AlexState{alex_scd=scd_r} -> do writeSTRef scd_r sc) -- ----------------------------------------------------------------------------- -- Useful token actions -- just ignore this token and scan another one skip input len = alexScan -- ignore this token, but set the start code to a new value begin code input len = do alexSetStartCode code; alexScan -- perform an action for this token, and set the start code to a new value (token `andBegin` code) input len = do alexSetStartCode code; token input len -- ----------------------------------------------------------------------------- -- INTERNALS and main scanner engine -- {-# LINE 144 "GenericTemplate.hs" #-} data AlexAddr = AlexA# Addr# {-# INLINE alexIndexShortOffAddr #-} alexIndexShortOffAddr (AlexA# arr) off = narrow16Int# i where i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) low = int2Word# (ord# (indexCharOffAddr# arr off')) off' = off *# 2# -- ----------------------------------------------------------------------------- -- Main lexing routines -- alexScan :: some a . Alex a alexScan = do (I# (startcode)) <- alexGetStartCode -- the startcode is the initial state cur_input <- alexGetInput let c = alexInputPrevChar cur_input c `seq` do r <- alex_scan_tkn c 0# startcode AlexNone case r of AlexNone -> alexEOF cur_input AlexLastAcc k input len -> do alexSetInput input k cur_input len -- {-# LINE 221 "GenericTemplate.hs" #-} -- Push the input through the DFA, remembering the most recent accepting -- state it encountered. alex_scan_tkn lc len (-1#) last_acc = return last_acc alex_scan_tkn lc len s last_acc = do new_acc <- check_accs s lc len last_acc --danaxu extends arguments c <- alexGetChar let {-# INLINE [0] join #-} -- This is a *hack*, the compiler doesn't eliminate the Maybe return -- from alexGetChar unless we extract this join point and inline -- it later. join c' = alex_scan_tkn lc (len +# 1#) s' new_acc where base = alexIndexShortOffAddr alex_base s (I# (ord_c)) = ord c' offset = (base +# ord_c) check = alexIndexShortOffAddr alex_check offset s' = if (offset >=# 0#) && (check ==# ord_c) then alexIndexShortOffAddr alex_table offset else alexIndexShortOffAddr alex_deflt s case c of Nothing -> return new_acc -- end of input Just c' -> join c' -- where -- OPTIMISATION PROBLEM. We need to eta-expand -- check_accs and check_accs1. This needs a simple -- one-shot analysis of some kind, but note that -- check_accs1 is recursive. check_accs s lc len last_acc = check_accs1 (alex_accept `unsafeAt` (I# (s))) lc len last_acc check_accs1 accs lc len last_acc = case accs of [] -> return last_acc (AlexAcc _ a lctx rctx : rest) -> case lctx of Nothing -> check_rctx a rctx rest lc len last_acc Just arr | arr!lc -> check_rctx a rctx rest lc len last_acc | otherwise -> check_accs1 rest lc len last_acc -- where ok a len = do inp <- alexGetInput return (AlexLastAcc a inp (I# (len))) check_rctx a rctx rest lc len last_acc = case rctx of Nothing -> ok a len Just (I# (sn)) -> do inp <- alexGetInput let c = alexInputPrevChar inp c `seq` do acc <- alex_scan_tkn c 0# sn AlexNone alexSetInput inp case acc of AlexNone -> check_accs1 rest lc len last_acc AlexLastAcc{} -> ok a len -- TODO: there's no need to find the longest -- match when checking the right context, just -- the first match will do. data AlexLastAcc a = AlexNone | AlexLastAcc a !AlexInput !Int data AlexAcc a = AlexAcc Int a (Maybe (Array Char Bool)) (Maybe Int)