Changeset 15296 for src/Pugs/Parser

Timestamp:

02/18/07 15:56:10 (21 months ago)

Author:

audreyt

Message:

* Convert VStr from String to ByteString?, and Syn from

String to ID, in Pugs. Benchmark shows the perf gain is 5%,
so it's not worth the trouble of writing a GHC 6.7-compatible
processor. The next commit will revert this commit.

Location:

src/Pugs/Parser

Files:

• Doc.hs (modified) (1 diff)
• Export.hs (modified) (2 diffs)
• Literal.hs (modified) (19 diffs)
• Operator.hs (modified) (9 diffs)
• Program.hs (modified) (2 diffs)
• Types.hs (modified) (1 diff)
• Unsafe.hs (modified) (2 diffs)
• Util.hs (modified) (6 diffs)

src/Pugs/Parser/Doc.hs

@@ -94 +94 @@
                 let lns' | For { headText = (_:txt) } <- docHead = txt:lns
                          | otherwise = lns
-                    linesVal    = map VStr lns'
+                    linesVal    = map _VStr lns'
                     linesStr    = unlines lns'
                     linesList   = VList (length linesVal `seq` linesVal)
                 unsafeEvalExp $ Stmts
-                    (App (_Var "&push") (Just $ _Var ("@=" ++ section)) [Val (VStr linesStr)])
+                    (App (_Var "&push") (Just $ _Var ("@=" ++ section)) [Val (_VStr linesStr)])
                     $ Stmts 
                         (App (_Var "&push") (Just $ _Var ("$=" ++ section)) [Val linesList])
-                        (App (_Var "&push") (Just $ Syn "{}" [_Var "%=POD", Val (VStr section)]) [Val linesList])
+                        (App (_Var "&push") (Just $ _Syn "{}" [_Var "%=POD", Val (_VStr section)]) [Val linesList])
             whiteSpace
             return (rv `seq` emptyExp)

src/Pugs/Parser/Export.hs

@@ -17 +17 @@
 exportSym :: Scope -> String -> Val -> RuleParser ()
 exportSym scope ('&':subname) ref = do
-    rv <- unsafeEvalExp $ Syn "," [App (_Var "&values") (Just (Val ref)) []]
+    rv <- unsafeEvalExp $ _Syn "," [App (_Var "&values") (Just (Val ref)) []]
     case rv of
         Val (VList subs) -> do
@@ -25 +25 @@
                         VCode sub | isMulti sub -> ('&':)
                         _                       -> id
-                    mkExp   = Syn ":=" [_Var name, Val val]
+                    mkExp   = _Syn ":=" [_Var name, Val val]
                     mkSym   = _Sym scope (mkMulti name) mkExp
                 doExport scope mkSym

src/Pugs/Parser/Literal.hs

@@ -1 @@
-{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}
+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -foverloaded-strings #-}
 module Pugs.Parser.Literal where
 
@@ -60 +60 @@
 arrayLiteral = try $ do
     item <- verbatimBrackets ruleBracketedExpression
-    return $ Syn "\\[]" [item]
+    return $ _Syn "\\[]" [item]
 
 ruleBracketedExpression :: RuleParser Exp
 ruleBracketedExpression = enterBracketLevel ParensBracket $
-    ruleExpression <|> do { whiteSpace; return (Syn "," []) }
+    ruleExpression <|> do { whiteSpace; return (_Syn "," []) }
 
 {-|
@@ -77 +77 @@
     key <- identifier `tryFollowedBy` symbol "=>"
     val <- parseExpWithTightOps
-    return (Val (VStr key), val)
-    return $ App (_Var "&infix:=>") Nothing [Val (VStr key), val]
+    return (Val (_VStr key), val)
+    return $ App (_Var "&infix:=>") Nothing [Val (_VStr key), val]
 
 pairAdverb :: RuleParser Exp
@@ -88 +88 @@
         char '!'
         key <- many1 wordAny
-        return $ App (_Var "&infix:=>") Nothing [Val (VStr key), Val (VBool False)]
+        return $ App (_Var "&infix:=>") Nothing [Val (_VStr key), Val (VBool False)]
     shortcutPair = do
         (s:ss)              <- fmap reverse (many1 ruleSigil)
         varExp@(Var var)    <- fmap _Var (regularVarNameForSigil s)
         -- This turns ":$$$x" into "x=>$$$x"
-        let appCast sig exp = Syn (shows sig "{}") [exp]
+        let appCast sig exp = Syn (cast (shows sig "{}")) [exp]
         return $ App (_Var "&infix:=>") Nothing
-            [ Val (VStr $ cast (v_name var))
+            [ Val (_VStr $ cast (v_name var))
             , foldr appCast varExp ss
             ]
@@ -105 +105 @@
     val <- lexeme ((optional ruleDot >> valueExp lvl) <|> return (Val $ VBool True))
     return $ if (all isDigit key)
-        then App (_Var "&Pugs::Internals::base") Nothing [Val (VStr key), val]
-        else App (_Var "&infix:=>") Nothing [Val (VStr key), val]
+        then App (_Var "&Pugs::Internals::base") Nothing [Val (_VStr key), val]
+        else App (_Var "&infix:=>") Nothing [Val (_VStr key), val]
     where
     valueExp lvl = do
@@ -126 +126 @@
 yadaLiteral = expRule $ do
     sym  <- choice . map symbol $ words " ... ??? !!! "
-    return $ App (_Var $ doYada sym) Nothing [Val $ VStr (sym ++ " - not yet implemented")]
+    return $ App (_Var $ doYada sym) Nothing [Val $ _VStr (sym ++ " - not yet implemented")]
     where
     doYada "..." = "&fail_" -- XXX rename to fail() eventually
@@ -194 +194 @@
     char '\\'
     nextchar <- escapeCode -- see Lexer.hs
-    return (Val $ VStr nextchar)
+    return (Val $ _VStr nextchar)
 
 qInterpolateDelimiter :: Char -> RuleParser Exp
@@ -200 +200 @@
     char '\\'
     c <- oneOf (protectedChar:"\\")
-    return (Val $ VStr [c])
+    return (Val $ _VStr [c])
 
 qInterpolateDelimiterMinimal :: Char -> RuleParser Exp
@@ -206 +206 @@
     char '\\'
     c <- oneOf (protectedChar:"\\")
-    return (Val $ VStr ['\\',c])
+    return (Val $ _VStr ['\\',c])
 
 qInterpolateDelimiterBalanced :: Char -> RuleParser Exp
@@ -212 +212 @@
     char '\\'
     c <- oneOf (protectedChar:balancedDelim protectedChar:"\\")
-    return (Val $ VStr ['\\',c])
+    return (Val $ _VStr ['\\',c])
 
 qInterpolateQuoteConstruct :: RuleParser Exp
@@ -296 +296 @@
         markerExp  <- qLiteral1 qStart qEnd qFlags
         case unwrap markerExp of
-            Val (VStr endMarker) -> do
+            Val (VStr s) -> do
                 (restOfLine:restOfInput)    <- fmap lines getInput
                 -- When end marker is "END", a line matches it if it looks like "   END".
-                let foundEndMarker line
+                let endMarker = cast s
+                    foundEndMarker line
                         = (endMarker `isSuffixOf` line)
                             && (all isSpace (take (length line - length endMarker) line))
@@ -347 +348 @@
     string "q_to_eof()"
     source <- many anyChar
-    return $ Val $ VStr $ source
+    return $ Val $ _VStr $ source
 
 qLiteral1 :: RuleParser String    -- Opening delimiter
@@ -360 +361 @@
         QS_Yes      -> return (doSplitWords expr)
         QS_Protect  -> return $ case unwindGroups (unwindConcat (unwrap expr)) of
-            []  -> Syn "," []
+            []  -> _Syn "," []
             [x] -> x
-            xs  -> Syn "," xs
+            xs  -> _Syn "," xs
         QS_No       -> return $ case qfExecute flags of
             True -> App (_Var "&Pugs::Internals::runShellCommand") Nothing [expr]
@@ -370 +371 @@
     unwindConcat :: Exp -> [Exp]
     unwindConcat (App _ Nothing [l, r]) = unwindConcat l ++ unwindConcat r
-    unwindConcat (Val (VStr str))
+    unwindConcat (Val (VStr buf))
         | null str  = []
         | otherwise = sepBegin (sepEnd (intersperse Noop splitted))
         where
-        splitted = map (Val . VStr) (perl6Words str)
+        splitted = map (Val . _VStr) (perl6Words str)
         sepBegin = if isBreakingSpace (head str) then (Noop:) else id
         sepEnd   = if isBreakingSpace (last str) then (++ [Noop]) else id
+        str      = cast buf
     unwindConcat expr = [expr]
 
@@ -397 +399 @@
     -- a nonbreaking ws char.
     doSplitWords expr
-        | Val (VStr str) <- unwrap expr = doSplitStr perl6Words str
+        | Val (VStr str) <- unwrap expr = doSplitStr perl6Words (cast str)
         | otherwise                     = Ann (Cxt cxtSlurpyAny) (App (_Var "&infix:~~") Nothing [expr, rxSplit])
     {-
@@ -410 +412 @@
         ]
     -}
-    rxSplit = Syn "rx" $
-        [ Val $ VStr "([^\\x09\\x0a\\x0d\\x20]+)"
+    rxSplit = _Syn "rx" $
+        [ Val $ _VStr "([^\\x09\\x0a\\x0d\\x20]+)"
         , Val $ VList
-            [ castV (VStr "P5", VInt 1)
-            , castV (VStr "g", VInt 1)
-            , castV (VStr "stringify", VInt 1)
+            [ castV (_VStr "P5", VInt 1)
+            , castV (_VStr "g", VInt 1)
+            , castV (_VStr "stringify", VInt 1)
             ]
         ]
@@ -570 +572 @@
         True
         | (App (Var var) Nothing [Val (VStr name), _]) <- pairs
-        , var == cast "&infix:=>"
-        , (name ==) `any` words "P5 Perl5 perl5"
+        , var == cast (__"&infix:=>")
+        , (cast name ==) `any` words "P5 Perl5 perl5"
         ])
     = rxLiteral5
@@ -641 +643 @@
         = exp
     applyPseudo (Syn syn [Var var, exp])
-        | last syn == '='
+        | last (cast syn) == '='
         , var == varTopic
-        = App (_Var ("&infix:" ++ init syn)) Nothing [matchResult, exp]
+        = App (_Var ("&infix:" ++ init (cast syn))) Nothing [matchResult, exp]
     applyPseudo x = internalError $ "Unknown pseudo-assignment form:" ++ show x
     fixPseudo (Ann ann exp) = Ann ann (fixPseudo exp)
@@ -660 +662 @@
     where
     adv x (Syn "\\{}" [Syn "," pairs]) = Syn "\\{}"
-        [Syn "," (App (_Var "&infix:=>") Nothing [Val (VStr x), Val (VBool True)] : pairs)]
+        [Syn "," (App (_Var "&infix:=>") Nothing [Val (_VStr x), Val (VBool True)] : pairs)]
     adv _ _ = internalError "unexpected regex adverb specifier"
 

src/Pugs/Parser/Operator.hs

@@ -1 @@
-{-# OPTIONS_GHC -cpp -fglasgow-exts -funbox-strict-fields -fno-full-laziness -fno-cse -fallow-overlapping-instances -fno-warn-orphans #-}
+{-# OPTIONS_GHC -cpp -fglasgow-exts -funbox-strict-fields -fno-full-laziness -fno-cse -fallow-overlapping-instances -fno-warn-orphans -foverloaded-strings #-}
 
 module Pugs.Parser.Operator where
@@ -67 +67 @@
 
 termLevel, methLevel, incrLevel, expoLevel, symbLevel, multLevel, addiLevel, junaLevel, junoLevel :: [RuleOperator Exp]
-termLevel = circumOps (Set.singleton (MkOpName (cast "\\( )")))
+termLevel = circumOps (Set.singleton (MkOpName (_cast "\\( )")))
 methLevel = methOps (opWords " . .+ .? .* .+ .() .[] .{} .<<>> .= ")
 incrLevel = postOps incrOpsPost ++ preOps incrOpsPre
 expoLevel = rightOps (opWords " ** ")
-symbLevel = preSyn (Set.singleton (MkOpName (cast "|"))) ++ preOps symbPreops
+symbLevel = preSyn (Set.singleton (MkOpName (_cast "|"))) ++ preOps symbPreops
 multLevel = leftOps (opWords " * / % x xx +& +< +> ~& ~< ~> ?& ")
 addiLevel = leftOps (opWords " + - ~ +| +^ ~| ~^ ?| ")
@@ -268 +268 @@
 
 commaID :: ID
-commaID = cast ","
+commaID = _cast ","
 
 data TightFunctions = MkTightFunctions
@@ -306 +306 @@
 
 circumOps, rightSyn, chainOps, matchOps, nonSyn, listSyn, preSyn, optPreSyn, preOps, preSymOps, optSymOps, postOps, optOps, leftOps, rightOps, nonOps, listOps :: Set OpName -> [RuleOperator Exp]
-preSyn      = ops  $ makeOp1 Prefix "" Syn
-optPreSyn   = ops  $ makeOp1 OptionalPrefix "" Syn
+preSyn      = ops  $ makeOp1 Prefix "" _Syn
+optPreSyn   = ops  $ makeOp1 OptionalPrefix "" _Syn
 preOps      = (ops $ makeOp1 Prefix "&prefix:" doApp) . addHyperPrefix
 preSymOps   = (ops $ makeOp1 Prefix "&prefix:" doAppSym) . addHyperPrefix
@@ -319 +319 @@
 matchOps    = (ops $ makeOp2Match AssocLeft "&infix:" doApp) . addHyperInfix . addNegation
 chainOps    = (ops $ makeOp2 AssocLeft "&infix:" doApp) . addHyperInfix . addNegation
-rightSyn    = ops $ makeOp2 AssocRight "" Syn
-nonSyn      = ops $ makeOp2 AssocNone "" Syn
-listSyn     = ops $ makeOp0 AssocList "" Syn
+rightSyn    = ops $ makeOp2 AssocRight "" _Syn
+nonSyn      = ops $ makeOp2 AssocNone "" _Syn
+listSyn     = ops $ makeOp0 AssocList "" _Syn
 circumOps   = ops $ makeCircumOp "&circumfix:"
 rightAssignSyn :: RuleOperator Exp
-rightAssignSyn = makeOp2Assign AssocRight "" Syn
+rightAssignSyn = makeOp2Assign AssocRight "" _Syn
 rightDotAssignSyn :: RuleOperator Exp
-rightDotAssignSyn = makeOp2DotAssign AssocRight "" Syn
+rightDotAssignSyn = makeOp2DotAssign AssocRight "" _Syn
 
 {-# INLINE ops #-}
@@ -396 +396 @@
                 state_first_run <- newTVar =<< (fmap scalarRef $! newTVar (VInt 0))
                 state_fresh     <- newTVar False
-                return $! mkPad [(cast "$?STATE_START_RUN", [(state_fresh, state_first_run)])] in
+                return $! mkPad [(_cast "$?STATE_START_RUN", [(state_fresh, state_first_run)])] in
         Syn "block"
             [ Pad SState pad $!
@@ -488 +488 @@
     hyperFrench = Set.mapMonotonic french xs
     texan x = cast (__">>" +++ cast x)
-    french x = cast (cast "\187" +++ cast x)
+    french x = cast (_cast "\187" +++ cast x)
 
 {-|
@@ -522 +522 @@
     y <- parseExpWithTightOps
     symbol post
-    return $ \x z -> Syn syn [x, y, z]
-
-
-
+    return $ \x z -> _Syn syn [x, y, z]
 
 emptyTerm :: Exp
@@ -708 +705 @@
     char '|'
     ruleHyperPost
-    return $ cast "&prefix:|<<"
+    return $ _cast "&prefix:|<<"
 
 ruleInfixOp :: RuleParser String

src/Pugs/Parser/Program.hs

@@ -116 +116 @@
 runRule env p name str =
     case ( runParser p (makeState env) name str ) of
-        Left err    -> env { envBody = Val $ VError (VStr msg) [mkPos pos pos] }
+        Left err    -> env { envBody = Val $ VError (_VStr msg) [mkPos pos pos] }
             where
             msg = concat (intersperse "\n" (map filterUnexpected $ lines (showErr err)))
@@ -159 +159 @@
     -- S04: CHECK {...}*      at compile time, ALAP
     --  $_() for @*CHECK
-    rv <- unsafeEvalExp $ Syn "for"
+    rv <- unsafeEvalExp $ _Syn "for"
         [ _Var "@*CHECK"
-        , Syn "sub"
+        , _Syn "sub"
             [ Val . VCode $ mkSub
                 { subBody   = App (_Var "$_") Nothing []

src/Pugs/Parser/Types.hs

@@ -305 +305 @@
 parserWarn str val = do
     currPos <- getPosition
-    traceM (pretty (VError (VStr $ str ++ showVal) [mkPos currPos currPos]))
+    traceM (pretty (VError (_VStr $ str ++ showVal) [mkPos currPos currPos]))
     where
     showVal = case show val of

src/Pugs/Parser/Unsafe.hs

@@ -31 +31 @@
     -- pos <- getPosition
     env <- getRuleEnv
-    val <- unsafeEvalExp $ mergeStmts exp (Syn "continuation" [])
+    val <- unsafeEvalExp $ mergeStmts exp (_Syn "continuation" [])
     case val of
         Val (VControl (ControlContinuation { ccEnv = env' })) ->
@@ -96 +96 @@
         env          <- ask
         pos          <- getPosition
-        case envBody (parseProgram env ("MACRO { " ++ show pos ++" }") code) of
+        case envBody (parseProgram env ("MACRO { " ++ show pos ++" }") (cast code)) of
             Val (err@VError{})  -> fail $ pretty err
             exp                 -> return exp

src/Pugs/Parser/Util.hs

@@ -1 @@
-{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}
+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -foverloaded-strings #-}
 module Pugs.Parser.Util where
 
@@ -127 +127 @@
 
 _percentUnderscore :: Var
-_percentUnderscore = cast "%_"
+_percentUnderscore = _cast "%_"
 
 paramsFor :: SubType -> Maybe [Param] -> [Param] -> [Param]
@@ -157 +157 @@
     , isWritable    = True
     , isLazy        = False
-    , paramName     = cast "&self"
+    , paramName     = _cast "&self"
     , paramContext  = CxtItem typ
     , paramDefault  = Noop
@@ -177 +177 @@
     
     isHashOrPair (Ann _ exp) = isHashOrPair exp
-    isHashOrPair (App (Var var) _ _) = (var == cast "&pair") || (var == cast "&infix:=>") 
+    isHashOrPair (App (Var var) _ _) = (var == _cast "&pair") || (var == _cast "&infix:=>")
     isHashOrPair (Syn "%{}" _) = True
     isHashOrPair (Var var) = v_sigil var == SHash
@@ -208 +208 @@
 makeVarWithSigil :: Char -> Exp -> Exp
 makeVarWithSigil '$' x = x
-makeVarWithSigil s   x = Syn (s:"{}") [x]
+makeVarWithSigil s   x = Syn (cast (s:"{}")) [x]
 
 -- | splits the string into expressions on whitespace.
@@ -215 +215 @@
 doSplitStr f str = case f str of
     []  -> Syn "," []
-    [x] -> Val (VStr x)
-    xs  -> Syn "," $ map (Val . VStr) xs
+    [x] -> Val (_VStr x)
+    xs  -> Syn "," $ map (Val . _VStr) xs
 
 perl6Words :: String -> [String]