Changeset 15616

Show
Ignore:
Timestamp:
03/12/07 01:43:31 (19 months ago)
Author:
audreyt
Message:

* Change all liftSTM into stm and all liftIO into io.

Location:
src/Pugs
Files:
25 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/AST.hs

    r15611 r15616  
    155155        return (EntryConstant typ ref) 
    156156    | isStaticScope scope = do 
    157         tvar    <- liftSTM $ newTVar ref 
     157        tvar    <- stm $ newTVar ref 
    158158        return (EntryStatic typ ref tvar) 
    159159    | otherwise = do 
    160         tvar    <- liftSTM $ newTVar ref 
    161         fresh   <- liftSTM $ newTVar True 
     160        tvar    <- stm $ newTVar ref 
     161        fresh   <- stm $ newTVar True 
    162162        return (EntryLexical typ ref tvar fresh) 
    163163    where 
    … …  
    369369filterPrim :: (TVar Pad) -> Eval Pad 
    370370filterPrim glob = do 
    371     MkPad pad   <- liftSTM $ readTVar glob 
     371    MkPad pad   <- stm $ readTVar glob 
    372372    fmap (MkPad . Map.fromAscList . catMaybes) . mapM checkPrim $ Map.toAscList pad 
    373373 

  • src/Pugs/AST/CapInternals.hs

    r15464 r15616  
    409409        lv <- asks envLValue 
    410410        case lv of 
    411             RValue -> liftSTM (readTVar t) 
     411            RValue -> stm (readTVar t) 
    412412            LValue typ -> do 
    413413                rv <- readTVar t 

  • src/Pugs/AST/Eval.hs

    r15572 r15616  
    3232 
    3333tryIO :: a -> IO a -> Eval a 
    34 tryIO err = liftEval . liftIO . (`catchIO` (const $ return err)) 
     34tryIO err = liftEval . io . (`catchIO` (const $ return err)) 
    3535 
    3636{-| 
    … …  
    137137 
    138138instance MonadIO Eval where 
    139     liftIO = liftEval . liftIO 
     139    liftIO = liftEval . io 
    140140 
    141141instance MonadError Val Eval where 
    … …  
    153153-} 
    154154guardIO :: IO a -> Eval a 
    155 guardIO io = do 
    156     rv <- liftIO $ try io 
     155guardIO x = do 
     156    rv <- io $ try x 
    157157    case rv of 
    158158        Left e -> fail (show e) 
    … …  
    166166-} 
    167167guardIOexcept :: MonadIO m => [((Exception -> Bool), a)] -> IO a -> m a 
    168 guardIOexcept safetyNet io = do 
    169     rv <- liftIO $ try io 
     168guardIOexcept safetyNet x = do 
     169    rv <- io $ try x 
    170170    case rv of 
    171171        Right v -> return v 
    … …  
    178178 
    179179guardSTM :: STM a -> Eval a 
    180 guardSTM stm = do 
    181     rv <- liftSTM $ fmap Right stm `catchSTM` (return . Left) 
     180guardSTM x = do 
     181    rv <- stm $ fmap Right x `catchSTM` (return . Left) 
    182182    case rv of 
    183183        Left e -> fail (show e) 
    … …  
    186186instance MonadSTM Eval where 
    187187    liftSIO = EvalT . fmap RNormal . lift . lift 
    188     liftSTM stm = do 
     188    liftSTM x = do 
    189189        atom <- asks envAtomic 
    190190        if atom 
    191             then EvalT (fmap RNormal . lift . lift . liftSTM $ stm) 
    192             else EvalT (fmap RNormal . lift . lift . liftIO . liftSTM $ stm) 
     191            then EvalT (fmap RNormal . lift . lift . stm $ x) 
     192            else EvalT (fmap RNormal . lift . lift . io . stm $ x) 
    193193 
    194194instance MonadReader Env Eval where 

  • src/Pugs/AST/Internals.hs

    r15611 r15616  
    226226    fromSV :: PerlSV -> Eval n 
    227227    fromSV sv = do 
    228         str <- liftIO $ svToVStr sv 
     228        str <- io $ svToVStr sv 
    229229        fail $ "Cannot cast from SV (" ++ str ++ ") to " ++ errType (undefined :: n) 
    230230    castV :: n -> Val 
    … …  
    247247    isRef _         = False 
    248248fromVal' (PerlSV sv) = do 
    249     v <- liftIO $ svToVal sv 
     249    v <- io $ svToVal sv 
    250250    case v of 
    251251        PerlSV sv'  -> fromSV sv'   -- it was a SV 
    … …  
    266266vvToVal x 
    267267    | Just sv <- Val.castVal x  = do 
    268         rv <- liftIO (svToVal sv) 
     268        rv <- io (svToVal sv) 
    269269        case rv of 
    270270            VV vv 
    … …  
    287287    -- first, check if the list is at least abs(idx) long 
    288288    MkIArray iv <- getArr 
    289     a   <- liftSTM $ readTVar iv 
     289    a   <- stm $ readTVar iv 
    290290    let size = a_size a 
    291291    if size > abs (idx+1) 
    292         then return (IScalar (a !: (idx `mod` size))) 
     292        then return (a !: (idx `mod` size)) 
    293293        else errIndex def idx 
    294294-- now we are all positive; either extend or return 
    295295getArrayIndex idx def getArr ext = do 
    296296    MkIArray iv <- getArr 
    297     a   <- liftSTM $ readTVar iv 
     297    a   <- stm $ readTVar iv 
    298298    let size = a_size a 
    299299    if size > idx 
    300         then return (IScalar (a !: idx)) 
     300        then return (a !: idx) 
    301301        else case ext of 
    302302            Just doExt -> do { doExt; getArrayIndex idx def getArr Nothing } 
    … …  
    306306    => ObjectId -> Maybe Dynamic -> VType -> [(VStr, Val)] -> m VObject 
    307307createObjectRaw uniq opaq typ attrList = do 
    308     attrs   <- liftSTM . unsafeIOToSTM . H.fromList H.hashString $ map (\(a,b) -> (a, lazyScalar b)) attrList 
     308    attrs   <- stm . unsafeIOToSTM . H.fromList H.hashString $ map (\(a,b) -> (a, lazyScalar b)) attrList 
    309309    return $ MkObject 
    310310        { objType   = typ 
    … …  
    381381instance Value VHash where 
    382382    fromVal (VObject o) = do 
    383         l <- liftIO $ H.toList (objAttrs o) 
     383        l <- io $ H.toList (objAttrs o) 
    384384        fmap Map.fromList . forM l $ \(k, ivar) -> do 
    385385            v <- readIVar ivar 
    … …  
    433433runInvokePerl5 sub inv args = do  
    434434    env     <- ask 
    435     rv      <- liftIO $ do 
     435    rv      <- io $ do 
    436436        envSV   <- mkEnv env 
    437437        invokePerl5 sub inv args envSV (enumCxt $ envContext env) 
    438438    case rv of 
    439         Perl5ReturnValues [x]   -> liftIO $ svToVal x 
    440         Perl5ReturnValues xs    -> liftIO $ fmap VList (mapM svToVal xs) 
     439        Perl5ReturnValues [x]   -> io $ svToVal x 
     440        Perl5ReturnValues xs    -> io $ fmap VList (mapM svToVal xs) 
    441441        Perl5ErrorString str    -> fail str 
    442442        Perl5ErrorObject err    -> throwError (PerlSV err) 
    … …  
    459459instance Value VBool where 
    460460    castV = VBool 
    461     fromSV sv = liftIO $ svToVBool sv 
     461    fromSV sv = io $ svToVBool sv 
    462462    fromVV vv = fmap cast (Val.asBit vv) 
    463463    doCast (VJunc j)   = juncToBool j 
    … …  
    478478    castV = VInt 
    479479    fromVV vv = fmap cast (Val.asInt vv) 
    480     fromSV sv = liftIO $ svToVInt sv 
     480    fromSV sv = io $ svToVInt sv 
    481481    doCast (VInt i)     = return $ i 
    482482    doCast x            = fmap truncate (fromVal x :: Eval VRat) 
    … …  
    484484instance Value VRat where 
    485485    castV = VRat 
    486     fromSV sv = liftIO $ svToVNum sv 
     486    fromSV sv = io $ svToVNum sv 
    487487    doCast (VInt i)     = return $ i % 1 
    488488    doCast (VRat r)     = return $ r 
    … …  
    506506    castV = VNum 
    507507    fromVV vv = fmap cast (Val.asNum vv) 
    508     fromSV sv = liftIO $ svToVNum sv 
     508    fromSV sv = io $ svToVNum sv 
    509509    doCast VUndef       = return $ 0 
    510510    doCast VType{}      = return $ 0 
    … …  
    554554instance Value ID where 
    555555    castV = VStr . cast 
    556     fromSV sv = fmap cast (liftIO $ svToVStr sv) 
     556    fromSV sv = fmap cast (io $ svToVStr sv) 
    557557    fromVV vv = fmap cast (Val.asStr vv) 
    558558    fromVal = fmap (cast :: VStr -> ID) . fromVal 
    … …  
    561561instance Value VStr where 
    562562    castV = VStr 
    563     fromSV sv = liftIO $ svToVStr sv 
     563    fromSV sv = io $ svToVStr sv 
    564564    fromVV vv = fmap cast (Val.asStr vv) 
    565565    fromVal (VList l)    = return . unwords =<< mapM fromVal l 
    … …  
    609609 
    610610instance Value PerlSV where 
    611     fromVal val = liftIO $ newSVval val 
     611    fromVal val = io $ newSVval val 
    612612    doCast v = castFailM v "PerlSV" 
    613613 
    … …  
    696696 
    697697instance Value Int where 
    698     fromSV sv = liftIO $ svToVInt sv 
     698    fromSV sv = io $ svToVInt sv 
    699699    doCast x = intCast x 
    700700    castV = VInt . fromIntegral 
    … …  
    14231423readPadEntry :: MonadSTM m => PadEntry -> m VRef 
    14241424readPadEntry EntryConstant{ pe_proto = v } = return v 
    1425 readPadEntry x                             = liftSTM (readTVar (pe_store x)) 
     1425readPadEntry x                             = stm (readTVar (pe_store x)) 
    14261426 
    14271427{-# SPECIALISE writePadEntry :: PadEntry -> VRef -> Eval () #-} 
    … …  
    14291429writePadEntry :: MonadSTM m => PadEntry -> VRef -> m () 
    14301430writePadEntry x@EntryConstant{} _ = die "Cannot rebind constant" x 
    1431 writePadEntry x                 v = liftSTM (writeTVar (pe_store x) v) 
     1431writePadEntry x                 v = stm (writeTVar (pe_store x) v) 
    14321432 
    14331433refreshPad :: Pad -> Eval Pad 
    … …  
    14351435    fmap listToPad $ forM (padToList pad) $ \(name, entry) -> do 
    14361436        entry' <- case entry of 
    1437             EntryLexical{ pe_proto = proto, pe_fresh = fresh } -> do 
    1438                 isFresh <- liftSTM $ readTVar fresh 
    1439                 if isFresh then liftSTM (writeTVar fresh False) >> return entry else do 
     1437            EntryLexical{ pe_proto = proto, pe_fresh = fresh } -> stm $ do 
     1438                isFresh <- readTVar fresh 
     1439                if isFresh then writeTVar fresh False >> return entry else do 
    14401440                    ref     <- cloneRef proto 
    1441                     tvar'   <- liftSTM (newTVar ref) 
     1441                    tvar'   <- newTVar ref 
    14421442                    return entry{ pe_store = tvar' } 
    14431443            _ -> return entry 
    … …  
    14711471 
    14721472findSymRef :: Var -> Pad -> Eval VRef 
    1473 findSymRef name pad = liftSTM $ join (findSym name pad) 
     1473findSymRef name pad = stm $ join (findSym name pad) 
    14741474 
    14751475{-# SPECIALISE findSym :: Var -> Pad -> Eval (STM VRef) #-} 
    … …  
    15381538askGlobal = do 
    15391539    glob <- asks envGlobal 
    1540     liftSTM $ readTVar glob 
     1540    stm $ readTVar glob 
    15411541 
    15421542writeVar :: Var -> Val -> Eval () 
    … …  
    15461546        Just EntryConstant{} -> fail $ "Cannot rebind constant: " ++ show name 
    15471547        Just c -> do 
    1548             ref <- liftSTM $ readTVar (pe_store c) 
     1548            ref <- stm $ readTVar (pe_store c) 
    15491549            writeRef ref val 
    15501550        _  -> fail $ "Cannot bind to non-existing variable: " ++ show name 
    … …  
    15551555        glob <- askGlobal 
    15561556        case findSym var glob of 
    1557             Just action -> liftSTM action >>= readRef 
     1557            Just action -> stm action >>= readRef 
    15581558            _           -> case v_sigil var of 
    15591559                SCode   -> readVar var{ v_sigil = SCodeMulti } 
    … …  
    15621562        lex <- asks envLexical 
    15631563        case findSym var lex of 
    1564             Just action -> liftSTM action >>= readRef 
     1564            Just action -> stm action >>= readRef 
    15651565            -- XXX - fallback to global should be eliminated here 
    15661566            _  -> case findSym var{ v_sigil = SCodeMulti } lex of 
    1567                 Just action -> liftSTM action >>= readRef 
     1567                Just action -> stm action >>= readRef 
    15681568                _           -> readVar (toGlobalVar var) 
    15691569 
    … …  
    16541654writeRef r _ = die "Cannot writeRef" r 
    16551655 
    1656 cloneRef :: VRef -> Eval VRef 
     1656cloneRef :: VRef -> STM VRef 
    16571657cloneRef (MkRef x) = fmap MkRef (cloneIVar x) 
    16581658 
    … …  
    16691669newObject :: (MonadSTM m, MonadIO m) => Type -> m VRef 
    16701670newObject typ = case showType typ of 
    1671     "Any"       -> liftSTM $ fmap scalarRef $ newTVar undef 
    1672     "Item"      -> liftSTM $ fmap scalarRef $ newTVar undef 
    1673     "Scalar"    -> liftSTM $ fmap scalarRef $ newTVar undef 
    1674     "Array"     -> liftSTM $ do 
     1671    "Any"       -> stm $ fmap scalarRef $ newTVar undef 
     1672    "Item"      -> stm $ fmap scalarRef $ newTVar undef 
     1673    "Scalar"    -> stm $ fmap scalarRef $ newTVar undef 
     1674    "Array"     -> stm $ do 
    16751675        iv  <- newTVar [::] 
    16761676        return $ arrayRef (MkIArray iv) 
    16771677    "Hash"      -> do 
    1678         h   <- liftIO (H.new (==) H.hashString) 
     1678        h   <- io (H.new (==) H.hashString) 
    16791679        return $ hashRef (h :: IHash) 
    16801680    "Sub"       -> newObject $ mkType "Code" 
    … …  
    16861686        , subBody  = Prim . const $ fail "Cannot use Undef as a Code object" 
    16871687        } 
    1688     "Type"      -> liftSTM $ fmap scalarRef $ newTVar undef 
     1688    "Type"      -> stm $ fmap scalarRef $ newTVar undef 
    16891689    "Pair"      -> do 
    16901690        key <- newObject (mkType "Scalar") 
    16911691        val <- newObject (mkType "Scalar") 
    16921692        return $ MkRef (IPair (VRef key, VRef val)) 
    1693     "Regex"     -> liftSTM $ fmap scalarRef $ newTVar undef -- XXX Wrong 
    1694     "Capture"   -> liftSTM $ fmap scalarRef $ newTVar undef -- XXX Wrong 
     1693    "Regex"     -> stm $ fmap scalarRef $ newTVar undef -- XXX Wrong 
     1694    "Capture"   -> stm $ fmap scalarRef $ newTVar undef -- XXX Wrong 
    16951695    _           -> fail ("Class prototype occured where its instance object expected: " ++ showType typ) 
    16961696 
    … …  
    18381838readIVar _ = fail "readIVar" 
    18391839 
    1840 cloneIVar :: IVar v -> Eval (IVar v) 
     1840cloneIVar :: IVar v -> STM (IVar v) 
    18411841cloneIVar (IScalar x) = fmap IScalar $ scalar_clone x 
    18421842cloneIVar (IArray x)  = fmap IArray  $ array_clone x 
    … …  
    19071907 
    19081908newScalar :: (MonadSTM m) => VScalar -> m (IVar VScalar) 
    1909 newScalar = liftSTM . (fmap IScalar) . newTVar 
     1909newScalar = stm . (fmap IScalar) . newTVar 
    19101910 
    19111911newArray :: (MonadSTM m) => VArray -> m (IVar VArray) 
    1912 newArray vals = liftSTM $ do 
    1913     tvs <- mapM newTVar vals 
     1912newArray vals = stm $ do 
     1913    tvs <- mapM newScalar vals 
    19141914    iv  <- newTVar (toP tvs) 
    19151915    return $ IArray (MkIArray iv) 
    … …  
    19171917newHash :: (MonadSTM m) => VHash -> m (IVar VHash) 
    19181918newHash hash = do 
    1919     --liftSTM $ unsafeIOToSTM $ putStrLn "new hash" 
    1920     ihash <- liftSTM . unsafeIOToSTM $ H.fromList H.hashString (map (\(a,b) -> (a, lazyScalar b)) (Map.toList hash)) 
     1919    --stm $ unsafeIOToSTM $ putStrLn "new hash" 
     1920    ihash <- stm . unsafeIOToSTM $ H.fromList H.hashString (map (\(a,b) -> (a, lazyScalar b)) (Map.toList hash)) 
    19211921    return $ IHash ihash 
    19221922 
    … …  
    19671967-} 
    19681968 
    1969 newtype IArray = MkIArray (TVar [:TVar VScalar:]) 
     1969newtype IArray = MkIArray (TVar [:IVar VScalar:]) 
    19701970    deriving (Typeable) 
    19711971 
    … …  
    20132013{-# NOINLINE _FakeEnv #-} 
    20142014_FakeEnv :: Env 
    2015 _FakeEnv = unsafePerformIO $ liftSTM $ do 
     2015_FakeEnv = unsafePerformIO $ stm $ do 
    20162016    ref  <- newTVar Map.empty 
    20172017    glob <- newTVar $ MkPad Map.empty 
    … …  
    20402040 
    20412041fakeEval :: MonadIO m => Eval Val -> m Val 
    2042 fakeEval = liftIO . runEvalIO _FakeEnv 
     2042fakeEval = io . runEvalIO _FakeEnv 
    20432043 
    20442044instance YAML Val.Val 
    … …  
    21032103        val <- fakeEval $ readRef ref 
    21042104        svC <- asYAML val 
    2105         liftIO $ print "====>" 
    2106         liftIO $ print svC 
     2105        io $ print "====>" 
     2106        io $ print svC 
    21072107        fail ("Not implemented: asYAML \"" ++ showType (refType ref) ++ "\"") 
    21082108    fromYAML MkNode{n_tag=Just s, n_elem=ESeq [node]} 
    … …  
    21242124instance YAML IHash where 
    21252125     asYAML x = do 
    2126          l      <- liftIO $ H.toList x 
     2126         l      <- io $ H.toList x 
    21272127         asYAMLmap "IHash" (map (\(k, v) -> (k, asYAML v)) l) 
    21282128     fromYAML node = do 

  • src/Pugs/AST/Utils.hs

    r15572 r15616  
    7676newObjectId = do 
    7777    tv <- asks envMaxId 
    78     liftSTM $ do 
     78    stm $ do 
    7979        rv <- readTVar tv 
    8080        writeTVar tv (MkObjectId (succ (unObjectId rv))) 

  • src/Pugs/CodeGen/Binary.hs

    r10059 r15616  
    1313genBinary = do 
    1414    penv <- compile () :: Eval PIL_Environment 
    15     liftIO $ do 
     15    io $ do 
    1616        tmp         <- getTemporaryDirectory 
    1717        (file, fh)  <- openBinaryTempFile tmp "pugs.bin" 

  • src/Pugs/CodeGen/PIL2.hs

    r15297 r15616  
    3737genPIL2YAML = do 
    3838    penv <- compile () :: Eval PIL_Environment 
    39     yaml <- liftIO (showYaml penv) 
     39    yaml <- io (showYaml penv) 
    4040    return . VStr . unlines $ [yaml] 

  • src/Pugs/CodeGen/PIR.hs

    r15503 r15616  
    316316lastPMC = do 
    317317    tvar    <- asks tReg 
    318     liftIO $ liftSTM $ do 
     318    io $ stm $ do 
    319319        (cur, name) <- readTVar tvar 
    320320        return $ case cur of 
    … …  
    325325genPMC name = do 
    326326    tvar    <- asks tReg 
    327     name'   <- liftIO $ liftSTM $ do 
     327    name'   <- io $ stm $ do 
    328328        (cur, _) <- readTVar tvar 
    329329        writeTVar tvar (cur + 1, name) 
    … …  
    350350genLabel names = do 
    351351    tvar    <- asks tLabel 
    352     cnt     <- liftIO $ liftSTM $ do 
     352    cnt     <- io $ stm $ do 
    353353        cur <- readTVar tvar 
    354354        writeTVar tvar (cur + 1) 
    … …  
    372372genPIR_YAML :: Eval Val 
    373373genPIR_YAML = genPIRWith $ \globPIR mainPIR _ -> do 
    374     yaml <- liftIO (showYaml (mainPIR, globPIR)) 
     374    yaml <- io (showYaml (mainPIR, globPIR)) 
    375375    return (VStr yaml) 
    376376 
    … …  
    378378genPIR :: Eval Val 
    379379genPIR = genPIRWith $ \globPIR mainPIR penv -> do 
    380     libs        <- liftIO $ getLibs 
     380    libs        <- io $ getLibs 
    381381    return . VStr . unlines $ 
    382382        [ "#!/usr/bin/env parrot" 
    … …  
    452452 
    453453runCodeGen :: (Translate a b) => TEnv -> a -> Eval (b, [Stmt]) 
    454 runCodeGen tenv = liftIO . (`runReaderT` tenv) . runWriterT . trans 
     454runCodeGen tenv = io . (`runReaderT` tenv) . runWriterT . trans 

  • src/Pugs/CodeGen/YAML.hs

    r15297 r15616  
    1717    pad  <- filterPrim =<< asks envGlobal 
    1818    main <- asks envBody 
    19     yaml <- liftIO $ f $ mkCompUnit "<unused>" pad main 
     19    yaml <- io $ f $ mkCompUnit "<unused>" pad main 
    2020    return $ VStr yaml 
    2121 
    … …  
    2323genYAML = do 
    2424    penv <- compile () :: Eval PIL_Environment 
    25     yaml <- liftIO (showYaml penv) 
     25    yaml <- io (showYaml penv) 
    2626    return $ VStr yaml 

  • src/Pugs/Compile.hs

    r15582 r15616  
    444444initTEnv :: Eval TEnv 
    445445initTEnv = do 
    446     initReg <- liftSTM $ newTVar (0, "") 
    447     initLbl <- liftSTM $ newTVar 0 
     446    initReg <- stm $ newTVar (0, "") 
     447    initLbl <- stm $ newTVar 0 
    448448    return $ MkTEnv 
    449449        { tLexDepth = 0 

  • src/Pugs/Compile/Haskell.hs

    r12328 r15616  
    2424genGHC = do 
    2525    exp <- asks envBody 
    26     liftIO (TH.runQ [d| 
     26    io (TH.runQ [d| 
    2727        mainCC :: IO Val 
    2828        mainCC = runComp $(compile exp) |]) >>= \str -> return . VStr . unlines $ 

  • src/Pugs/Compile/PIL2.hs

    r13863 r15616  
    6868            fmap concat $ mapM (\x -> canCompile (name, [x])) xs 
    6969        canCompile (name@('&':_), [(_, sym)]) = do 
    70             ref <- liftSTM $ readTVar sym 
     70            ref <- stm $ readTVar sym 
    7171            case ref of 
    7272                MkRef (ICode cv) 
    … …  
    7676                _ -> return [] 
    7777        canCompile ("@*END", [(_, sym)]) = do 
    78             ref     <- liftSTM $ readTVar sym 
     78            ref     <- stm $ readTVar sym 
    7979            cvList  <- fromVals =<< readRef ref :: Comp [VCode] 
    8080            decls   <- eachM cvList $ \(i, cv) -> do 
    … …  
    8585            -- translate them into store_global calls? 
    8686            -- placing them each into one separate init function? 
    87             val     <- readRef =<< liftSTM (readTVar sym) 
     87            val     <- readRef =&l