Changeset 15296

Show
Ignore:
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
Files:
46 modified

Legend:

Unmodified
Added
Removed
  • src/Pugs.hs

    r15139 r15296  
    312312    return () 
    313313    where 
    314     exp = App (_Var "&require") Nothing [Val $ VStr fn] 
     314    exp = App (_Var "&require") Nothing [Val $ _VStr fn] 
    315315 
    316316doRunSingle :: TVar Env -> RunOptions -> String -> IO () 
     
    354354        Val err@(VError (VStr msg) _) 
    355355            | runOptShowPretty opts 
    356             , any (== "Unexpected end of input") (lines msg) -> do 
     356            , any (== "Unexpected end of input") (lines (cast msg)) -> do 
    357357            cont <- readline "....> " 
    358358            case cont of 
     
    365365        _ -> return $ makeDumpEnv exp 
    366366    -- XXX Generalize this into structural folding 
    367     makeDumpEnv Noop              = Syn "continuation" [] 
    368     makeDumpEnv (Stmts x Noop)    = Stmts x   (Syn "continuation" []) 
     367    makeDumpEnv Noop              = _Syn "continuation" [] 
     368    makeDumpEnv (Stmts x Noop)    = Stmts x   (_Syn "continuation" []) 
    369369    makeDumpEnv (Stmts x exp)     = Stmts x   $ makeDumpEnv exp 
    370370    makeDumpEnv (Ann ann exp)     = Ann ann   $ makeDumpEnv exp 
    371371    makeDumpEnv (Pad x y exp)     = Pad x y   $ makeDumpEnv exp 
    372372    makeDumpEnv (Sym x y exp)     = Sym x y   $ makeDumpEnv exp 
    373     makeDumpEnv exp = Stmts exp (Syn "continuation" []) 
     373    makeDumpEnv exp = Stmts exp (_Syn "continuation" []) 
    374374    handler (IOException ioe) | isUserError ioe = do 
    375375        putStrLn "Internal error while running expression:" 
     
    405405 
    406406runProgramWith :: 
    407     (Env -> Env) -> (Val -> IO a) -> VStr -> [VStr] -> String -> IO a 
     407    (Env -> Env) -> (Val -> IO a) -> String -> [String] -> String -> IO a 
    408408runProgramWith fenv f name args prog = do 
    409409    env <- prepareEnv name args 
  • src/Pugs/AST.hs

    r14599 r15296  
    1 {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -funbox-strict-fields -fallow-overlapping-instances #-} 
     1{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -funbox-strict-fields -fallow-overlapping-instances -foverloaded-strings #-} 
    22 
    33{-| 
     
    216216mergeStmts x y = Stmts x y 
    217217 
    218 isImplicitTopic :: String -> Bool 
     218isImplicitTopic :: ID -> Bool 
    219219isImplicitTopic "subst" = True 
    220220isImplicitTopic "match" = True 
     
    234234 
    235235_underscore :: ID 
    236 _underscore = cast "_"  
     236_underscore = _cast "_" 
    237237 
    238238newPackage :: String -> String -> [String] -> [String] -> Exp 
     
    244244            (Just $ Val (VType $ mkType cls)) 
    245245            [ Syn "named" 
    246                 [ Val (VStr "is") 
    247                 , Val (VList $ map VStr classes) 
     246                [ Val (_VStr "is") 
     247                , Val (VList $ map castV classes) 
    248248                ] 
    249249            , Syn "named" 
    250                 [ Val (VStr "does") 
    251                 , Val (VList $ map VStr roles) 
     250                [ Val (_VStr "does") 
     251                , Val (VList $ map castV roles) 
    252252                ] 
    253253            , Syn "named" 
    254                 [ Val (VStr "name") 
    255                 , Val (VStr name) 
     254                [ Val (_VStr "name") 
     255                , Val (castV name) 
    256256                ] 
    257257            , Syn "named" 
    258                 [ Val (VStr "attrs") 
     258                [ Val (_VStr "attrs") 
    259259                , Syn "\\{}" [Noop] 
    260260                ] 
  • src/Pugs/AST/Eval.hs

    r14148 r15296  
    102102 
    103103instance Monad Eval where 
    104     return a = EvalT $ return (RNormal a) 
    105     m >>= k = EvalT $ do 
     104    {-# INLINE return #-} 
     105    return a = EvalT (return (RNormal a)) 
     106    {-# INLINE (>>=) #-} 
     107    m >>= k = EvalT (do 
    106108        a <- runEvalT m 
    107109        case a of 
    108             RNormal x   -> runEvalT (k x) 
    109             RException x-> return (RException x) 
     110            RNormal x       -> runEvalT $! k x 
     111            RException x    -> return (RException x)) 
     112    {-# INLINE fail #-} 
    110113    fail str = do 
    111114        pos <- asks envPos' 
    112         EvalT $ return (RException (errStrPos (cast str) pos)) 
     115        EvalT (return (RException (errStrPos (cast str) pos))) 
    113116 
    114117instance Error Val where 
    115     noMsg = errStr "" 
    116     strMsg = errStr 
     118    noMsg = errStr (_cast "") 
     119    strMsg = errStr . _cast 
    117120 
    118121instance MonadTrans EvalT where 
     
    186189instance MonadReader Env Eval where 
    187190    ask       = lift ask 
    188     local f m = EvalT $ local f (runEvalT m) 
     191    local f m = EvalT (local f (runEvalT m)) 
    189192 
    190193instance MonadCont Eval where 
  • src/Pugs/AST/Internals.hs

    r15227 r15296  
    1 {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances -fparr #-} 
     1{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances -fparr -foverloaded-strings #-} 
    22 
    33module Pugs.AST.Internals ( 
     
    8282    newSVval, -- used in Run.Perl5 
    8383 
    84     DebugInfo, _Sym, _Var -- String -> ByteString constructors 
     84    DebugInfo, _Syn, _Sym, _Var, _VStr -- String -> ByteString constructors 
    8585) where 
    8686 
     
    281281    => ObjectId -> Maybe Dynamic -> VType -> [(VStr, Val)] -> m VObject 
    282282createObjectRaw uniq opaq typ attrList = do 
    283     attrs   <- liftSTM . unsafeIOToSTM . H.fromList H.hashString $ map (\(a,b) -> (a, lazyScalar b)) attrList 
     283    attrs   <- liftSTM . unsafeIOToSTM . hashList $ map (\(a,b) -> (a, lazyScalar b)) attrList 
    284284    return $ MkObject 
    285285        { objType   = typ 
     
    324324        mapM fromVal vlist 
    325325    doCast v = castFailM v "[Int]" 
     326 
     327instance Value [String] where 
     328    castV = VList . map _VStr 
     329    fromVal v = do 
     330        vlist <- fromVal v 
     331        mapM fromVal vlist 
     332    doCast v = castFailM v "[String]" 
    326333 
    327334instance Value [VStr] where 
     
    385392    castV = VCode 
    386393    fromSV sv = return $ mkPrim 
    387         { subName     = cast "<anon>" 
     394        { subName     = cast ("<anon>" :: String) 
    388395        , subParams   = [defaultArrayParam] 
    389396        , subReturns  = mkType "Scalar::Perl5" 
     
    448455    doCast (VBool b)    = return $ if b then 1 % 1 else 0 % 1 
    449456    doCast (VList l)    = return $ genericLength l 
    450     doCast (VStr s) | not (null s) , isSpace $ last s = do 
    451         str <- fromVal (VStr $ init s) 
     457    doCast (VStr s) | not (Str.null s), isSpace $ Str.last s = do 
     458        str <- fromVal (castV $ Str.init s) 
    452459        return str 
    453     doCast (VStr s) | not (null s) , isSpace $ head s = do  
    454         str <- fromVal (VStr $ tail s) 
     460    doCast (VStr s) | not (Str.null s), isSpace $ Str.head s = do  
     461        str <- fromVal (castV $ Str.tail s) 
    455462        return str 
    456463    doCast (VStr s)     = return $ 
    457         case ( parseNatOrRat s ) of 
     464        case parseNatOrRat (cast s) of 
    458465            Left _   -> 0 % 1 
    459466            Right rv -> case rv of 
     
    473480    doCast (VNum n)     = return $ n 
    474481    doCast (VComplex (r :+ _)) = return $ r 
    475     doCast (VStr s) | not (null s) , isSpace $ last s = do 
    476         str <- fromVal (VStr $ init s) 
     482    doCast (VStr s) | not (Str.null s), isSpace $ Str.last s = do 
     483        str <- fromVal (castV $ Str.init s) 
    477484        return str 
    478     doCast (VStr s) | not (null s) , isSpace $ head s = do 
    479         str <- fromVal (VStr $ tail s) 
     485    doCast (VStr s) | not (Str.null s), isSpace $ Str.head s = do 
     486        str <- fromVal (castV $ Str.tail s) 
    480487        return str 
    481488    doCast (VStr "Inf") = return $ 1/0 
     
    483490    doCast (VStr "NaN") = return $ 0/0 
    484491    doCast (VStr s)     = return $ 
    485         case ( parseNatOrRat s ) of 
     492        case ( parseNatOrRat (cast s) ) of 
    486493            Left _   -> 0 
    487494            Right rv -> case rv of 
     
    520527instance Value VStr where 
    521528    castV = VStr 
     529    fromSV sv = fmap cast (liftIO $ svToVStr sv) 
     530    fromVV vv = liftSIO $ cast (Val.asStr vv) 
     531    fromVal (VList l)    = return . Str.unwords =<< mapM fromVal l 
     532    fromVal v@(PerlSV _) = fromVal' v 
     533    fromVal VUndef       = return (__"") 
     534    fromVal (VType t)    = return (cast t) 
     535    fromVal v = do 
     536        vt  <- evalValType v 
     537        case vt of 
     538            MkType "Pair" -> do 
     539                -- Special case for pairs: "$pair" eq 
     540                -- "$pair.key()\t$pair.value()" 
     541                (k, v)  <- join $ doPair v pair_fetch 
     542                k'      <- fromVal k 
     543                v'      <- fromVal v 
     544                return $ k' +++ __"\t" +++ v' 
     545            MkType "Hash" -> do 
     546                --- XXX special case for Hash -- need to Objectify 
     547                hv      <- join $ doHash v hash_fetch 
     548                lns     <- forM (Map.assocs hv) $ \(k, v) -> do 
     549                    str <- fromVal v 
     550                    return $ k +++ __"\t" +++ str 
     551                return $ Str.unlines lns 
     552            _ -> fromVal' v 
     553    doCast VUndef        = return $ __"" 
     554    doCast VType{}       = return $ __"" 
     555    doCast (VStr s)      = return s 
     556    doCast (VBool b)     = return $ if b then __"1" else __"" 
     557    doCast (VInt i)      = return $ __(show i) 
     558    doCast (VRat r)      = return $ __(showRat r) 
     559    doCast (VNum n)      = return $ __(showNum n) 
     560    doCast (VComplex (r :+ i)) = return $ __(showNum r ++ " + " ++ showNum i ++ "i") 
     561    doCast (VList l)     = fmap Str.unwords (mapM fromVal l) 
     562    doCast (VCode s)     = return $ __("<" ++ show (subType s) ++ "(" ++ cast (subName s) ++ ")>") 
     563    doCast (VJunc j)     = return $ __(show j) 
     564    doCast (VThread t)   = return $ __(takeWhile isDigit $ dropWhile (not . isDigit) $ show t) 
     565    doCast (VHandle h)   = return $ __"<VHandle (" +++ __(show h) +++ __">" 
     566    doCast (VMatch m)    = return $ matchStr m 
     567 -- doCast (VType typ)   = return $ showType typ -- "::" ++ showType typ 
     568    doCast (VObject o)   = return $ __"<obj:" +++ cast (objType o) +++ __">" 
     569    doCast x             = return $ __"<" +++ cast (valType x) +++ __">" 
     570 
     571instance Value String where 
     572    castV = VStr . cast 
    522573    fromSV sv = liftIO $ svToVStr sv 
    523574    fromVV vv = liftSIO $ cast (Val.asStr vv) 
     
    541592                lns     <- forM (Map.assocs hv) $ \(k, v) -> do 
    542593                    str <- fromVal v 
    543                     return $ k ++ "\t" ++ str 
    544                 return $ unlines lns 
     594                    return $ k +++ __"\t" +++ str 
     595                return $ unlines (cast lns) 
    545596            _ -> fromVal' v 
    546597    doCast VUndef        = return "" 
    547598    doCast VType{}       = return "" 
    548     doCast (VStr s)      = return s 
     599    doCast (VStr s)      = return (cast s) 
    549600    doCast (VBool b)     = return $ if b then "1" else "" 
    550601    doCast (VInt i)      = return $ show i 
     
    557608    doCast (VThread t)   = return $ takeWhile isDigit $ dropWhile (not . isDigit) $ show t 
    558609    doCast (VHandle h)   = return $ "<" ++ "VHandle (" ++ (show h) ++ ">" 
    559     doCast (VMatch m)    = return $ matchStr m 
     610    doCast (VMatch m)    = return $ (cast (matchStr m)) 
    560611 -- doCast (VType typ)   = return $ showType typ -- "::" ++ showType typ 
    561612    doCast (VObject o)   = return $ "<obj:" ++ showType (objType o) ++ ">" 
     
    574625newSVval val = case val of 
    575626    PerlSV sv   -> return sv 
    576     VStr str    -> vstrToSV str 
     627    VStr str    -> bufToSV str 
    577628    VType typ   -> vstrToSV (showType typ) 
    578629    VBool bool  -> vintToSV (fromEnum bool) 
     
    10181069mkPrim = MkCode 
    10191070    { isMulti = True 
    1020     , subName = cast "&" 
     1071    , subName = cast ("&" :: String) 
    10211072    , subType = SubPrim 
    10221073    , subEnv = Nothing 
     
    10451096mkSub = MkCode 
    10461097    { isMulti = False 
    1047     , subName = cast "&" 
     1098    , subName = cast ("&" :: String) 
    10481099    , subType = SubBlock 
    10491100    , subEnv = Nothing 
     
    10721123mkCode = MkCode 
    10731124    { isMulti = False 
    1074     , subName = cast "&" 
     1125    , subName = cast ("&" :: String) 
    10751126    , subType = SubBlock 
    10761127    , subEnv = Nothing 
     
    11301181    | App !Exp !(Maybe Exp) ![Exp]      -- ^ Function application 
    11311182                                        --     e.g. myfun($invocant: $arg) 
    1132     | Syn !String ![Exp]                -- ^ Syntactic construct that cannot 
     1183    | Syn !ID ![Exp]                    -- ^ Syntactic construct that cannot 
    11331184                                        --     be represented by 'App'. 
    11341185    | Ann !Ann !Exp                     -- ^ Annotation (see @Ann@) 
     
    11471198_Var :: String -> Exp 
    11481199_Var str = Var (possiblyFixOperatorName (cast str)) 
     1200 
     1201_VStr :: String -> Val 
     1202_VStr = VStr . cast 
     1203 
     1204_Syn :: String -> [Exp] -> Exp 
     1205_Syn s xs = Syn (cast s) xs 
    11491206 
    11501207instance Value Exp where 
     
    12331290    (exps', vs') = foldr extractPlaceholderVarsExp ([], vs) exps 
    12341291    vs'' = case n of 
    1235         "when"  -> Set.insert (cast "$_") vs' 
    1236         "given" -> Set.delete (cast "$_") vs' 
     1292        "when"  -> Set.insert varTopic vs' 
     1293        "given" -> Set.delete varTopic vs' 
    12371294        _       -> vs' 
    12381295extractPlaceholderVars (Var var) vs 
     
    12401297    , var' <- var{ v_twigil = TNil } 
    12411298    = (Var var', Set.insert var' vs) 
    1242     | var == cast "$_" 
     1299    | var == varTopic 
    12431300    = (Var var, Set.insert var vs) 
    12441301    | otherwise 
     
    12821339defaultArrayParam   = buildParam "" "*" "@_" (Val VUndef) 
    12831340defaultHashParam    = buildParam "" "*" "%_" (Val VUndef) 
    1284 defaultScalarParam  = buildParam "" "?" "$_" (Var $ cast "$_") 
     1341defaultScalarParam  = buildParam "" "?" "$_" (_Var "$_") 
    12851342 
    12861343type DebugInfo = Maybe (TVar (Map ID String)) 
     
    15571614dumpRef (MkRef (ICode cv)) = do 
    15581615    vsub <- code_assuming cv [] [] 
    1559     return (VStr $ "(MkRef (ICode $ " ++ show vsub ++ "))") 
     1616    return (castV $ "(MkRef (ICode $ " ++ show vsub ++ "))") 
    15601617dumpRef (MkRef (IScalar sv)) | scalar_iType sv == mkType "Scalar::Const" = do 
    15611618    sv <- scalar_fetch sv 
    1562     return (VStr $ "(MkRef (IScalar $ " ++ show sv ++ "))") 
    1563 dumpRef ref = return (VStr $ "(unsafePerformIO . newObject $ mkType \"" ++ showType (refType ref) ++ "\")") 
     1619    return (castV $ "(MkRef (IScalar $ " ++ show sv ++ "))") 
     1620dumpRef ref = return (castV $ "(unsafePerformIO . newObject $ mkType \"" ++ showType (refType ref) ++ "\")") 
    15641621 
    15651622readRef :: VRef -> Eval Val 
     
    16241681        return $ arrayRef (MkIArray iv) 
    16251682    "Hash"      -> do 
    1626         h   <- liftIO (H.new (==) H.hashString) 
     1683        h   <- liftIO hashNew 
    16271684        return $ hashRef (h :: IHash) 
    16281685    "Code"      -> return $! codeRef $ mkPrim 
     
    18541911newHash hash = do 
    18551912    --liftSTM $ unsafeIOToSTM $ putStrLn "new hash" 
    1856     ihash <- liftSTM . unsafeIOToSTM $ H.fromList H.hashString (map (\(a,b) -> (a, lazyScalar b)) (Map.toList hash)) 
     1913    ihash <- liftSTM . unsafeIOToSTM $ hashList (map (\(a,b) -> (a, lazyScalar b)) (Map.toList hash)) 
    18571914    return $ IHash ihash 
    18581915 
     
    19552012        , envLValue  = False 
    19562013        , envGlobal  = glob 
    1957         , envPackage = cast "Main" 
     2014        , envPackage = _cast "Main" 
    19582015        , envClasses = initTree 
    19592016        , envEval    = const (return VUndef) 
     
    19862043    asYAML x = asYAMLmap "Map" $ Map.toAscList (Map.map asYAML x) 
    19872044    fromYAML node = fmap Map.fromList (fromYAMLmap node) 
     2045instance YAML a => YAML (Map ByteString a) where 
     2046    asYAML x = asYAMLmapBuf "Map" $ Map.toAscList (Map.map asYAML x) 
     2047    fromYAML node = fmap Map.fromList (fromYAMLmapBuf node) 
    19882048instance YAML a => YAML (Map Var a) where 
    19892049    asYAML x = asYAMLmap "Map" . sortBy (\x y -> fst x `compare` fst y) $ 
     
    20382098     asYAML x = do 
    20392099         l      <- liftIO $ H.toList x 
    2040          asYAMLmap "IHash" (map (\(k, v) -> (k, asYAML v)) l) 
     2100         asYAMLmapBuf "IHash" (map (\(k, v) -> (k, asYAML v)) l) 
    20412101     fromYAML node = do 
    2042          l  <- fromYAMLmap node 
    2043          l' <- H.fromList H.hashString l 
     2102         l  <- fromYAMLmapBuf node 
     2103         l' <- hashList l 
    20442104         return l' 
    20452105 
  • src/Pugs/AST/Internals/Instances.hs

    r15248 r15296  
    1 {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances -fparr #-} 
     1{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances -fparr -foverloaded-strings #-} 
    22 
    33 
     
    6363        , envLValue  = False 
    6464        , envGlobal  = glob 
    65         , envPackage = cast "Main" 
     65        , envPackage = _cast "Main" 
    6666        , envClasses = initTree 
    6767        , envEval    = const (return VUndef) 
     
    9494    asYAML x = asYAMLmap "Map" $ Map.toAscList (Map.map asYAML x) 
    9595    fromYAML node = fmap Map.fromList (fromYAMLmap node) 
     96instance YAML a => YAML (Map ByteString a) where 
     97    asYAML x = asYAMLmapBuf "Map" $ Map.toAscList (Map.map asYAML x) 
     98    fromYAML node = fmap Map.fromList (fromYAMLmapBuf node) 
    9699instance YAML a => YAML (Map Var a) where 
    97100    asYAML x = asYAMLmap "Map" . sortBy (\x y -> fst x `compare` fst y) $ 
     
    146149     asYAML x = do 
    147150         l      <- liftIO $ H.toList x 
    148          asYAMLmap "IHash" (map (\(k, v) -> (k, asYAML v)) l) 
     151         asYAMLmapBuf "IHash" (map (\(k, v) -> (k, asYAML v)) l) 
    149152     fromYAML node = do 
    150          l  <- fromYAMLmap node 
    151          l' <- H.fromList H.hashString l 
     153         l  <- fromYAMLmapBuf node 
     154         l' <- hashList l 
    152155         return l' 
    153156 
  • src/Pugs/Bind.hs

    r14643 r15296  
    1 {-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-} 
     1{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -foverloaded-strings #-} 
    22 
    33{-| 
  • src/Pugs/CodeGen.hs

    r14058 r15296  
    4343    , ("Parse-YAML",  genParseYAML) 
    4444    , ("Parse-HsYAML",genParseHsYAML) 
    45     , ("Parse-Pretty",fmap (VStr . (++"\n") . pretty) (asks envBody)) 
     45    , ("Parse-Pretty",fmap (_VStr . (++"\n") . pretty) (asks envBody)) 
    4646--  , ("XML",         genXML) 
    4747    ] 
     
    9191    rv <- runEvalIO env gen 
    9292    case rv of 
    93         VStr str    -> return str 
     93        VStr str    -> return (cast str) 
    9494        _           -> fail (show rv) 
  • src/Pugs/CodeGen/JSON.hs

    r13448 r15296  
    1111genJSON = do 
    1212    penv <- compile () :: Eval PIL_Environment 
    13     return . VStr . unlines $ [showJSON penv] 
     13    return . _VStr . unlines $ [showJSON penv] 
  • src/Pugs/CodeGen/PIL1.hs

    r13448 r15296  
    1010genPIL1 = do 
    1111    penv <- compile () 
    12     return . VStr . unlines $ 
     12    return . _VStr . unlines $ 
    1313        [ "PIL_Environment" 
    1414        , "    { pilMain = (" ++ show (pilMain penv) ++ ")" 
  • src/Pugs/CodeGen/PIL2.hs

    r10059 r15296  
    1717genPIL2 = do 
    1818    penv <- compile () 
    19     return . VStr . unlines $ 
     19    return . _VStr . unlines $ 
    2020        [ "PIL_Environment" 
    2121        , "    { pilMain = (" ++ show (pilMain penv) ++ ")" 
     
    2727genPIL2Perl5 = do 
    2828    penv <- compile () :: Eval PIL_Environment 
    29     return . VStr . unlines $ [showPerl5 penv] 
     29    return . _VStr . unlines $ [showPerl5 penv] 
    3030 
    3131genPIL2JSON :: Eval Val 
    3232genPIL2JSON = do 
    3333    penv <- compile () :: Eval PIL_Environment 
    34     return . VStr . unlines $ [showJSON penv] 
     34    return . _VStr . unlines $ [showJSON penv] 
    3535 
    3636genPIL2YAML :: Eval Val 
     
    3838    penv <- compile () :: Eval PIL_Environment