Changeset 14214

Timestamp:

10/11/06 05:36:36 (2 years ago)

Author:

audreyt

Message:

* Rationalize Perl5 embedding's GC interface by passing

StablePtr? instead of Ptr around, as well as _not_ placing
GC burden on VError{} and VUndef, as they should be all
referring to a static &PL_sv_undef now.

Location:

src

Files:

• Pugs/AST/Internals.hs (modified) (5 diffs)
• Pugs/AST/Internals.hs-boot (modified) (1 diff)
• Pugs/Embed.hs (modified) (1 diff)
• Pugs/Embed/Perl5.hs (modified) (17 diffs)
• Pugs/Parser/Charnames.hs (modified) (1 diff)
• Pugs/Prim.hs (modified) (2 diffs)
• Pugs/Run.hs (modified) (1 diff)
• Pugs/Run/Perl5.hs (modified) (3 diffs)
• Pugs/Types/Array.hs (modified) (1 diff)
• perl5/p5embed.c (modified) (1 diff)
• perl5/p5embed.h (modified) (1 diff)

src/Pugs/AST/Internals.hs

@@ -76 +76 @@
     newObjectId, runInvokePerl5,
     
-    errStr, errStrPos, errValPos, enterAtomicEnv, valToBool, envPos', -- for circularity
+    showVal, errStr, errStrPos, errValPos, enterAtomicEnv, valToBool, envPos', -- for circularity
     expToEvalVal, -- Hack, should be removed once it's figured out how
 
@@ -406 +406 @@
     env     <- ask
     rv      <- liftIO $ do
-        envSV   <- mkVal (VControl $ ControlEnv env)
+        envSV   <- mkEnv env
         invokePerl5 sub inv args envSV (enumCxt $ envContext env)
     case rv of
@@ -417 +417 @@
     svToVal ptr = liftIO $ do
         pv  <- pugs_SvToVal ptr
-        deRefStablePtr (castPtrToStablePtr pv)
+        deRefStablePtr pv
 #else
     svToVal _ = fail "Perl 5 not embedded"
@@ -576 +576 @@
     VSocket{}   -> mkValRef val "Socket"
     VList{}     -> mkValRef val "Array"
+    VUndef      -> svUndef
+    VError{}    -> svUndef
     _           -> mkValRef val ""
 
@@ -714 +716 @@
         }
     deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-}
+
+showVal :: Val -> String
+showVal = show
 
 errStr :: VStr -> Val

src/Pugs/AST/Internals.hs-boot

@@ -23 +23 @@
 type VHash = Map VStr Val
 
+showVal :: Val -> String
 envPos' :: Env -> Pos
 errStr :: VStr -> Val

src/Pugs/Embed.hs

@@ -32 +32 @@
     return () -}
 evalEmbedded "Perl5" = \code -> do
-    interp <- initPerl5 "" (Nothing :: Maybe ())
-    evalPerl5 code nullSV 0
+    interp <- initPerl5 "" Nothing
+    evalPerl5 code nullEnv 0
     freePerl5 interp
 evalEmbedded s = const . fail $ "Cannot evaluate in " ++ s

src/Pugs/Embed/Perl5.hs

@@ -4 +4 @@
 module Pugs.Embed.Perl5 
     ( InvokePerl5Result(..)
-    , svToVBool, svToVInt, svToVNum, svToVStr, vstrToSV, vintToSV, svToVal, bufToSV
-    , vnumToSV, mkValRef , mkVal, PerlSV, nullSV, evalPerl5, invokePerl5
+    , svToVBool, svToVInt, svToVNum, svToVStr, vstrToSV, vintToSV, svToVal, bufToSV, svUndef
+    , vnumToSV, mkValRef , mkVal, mkEnv, PerlSV, nullSV, nullEnv, evalPerl5, invokePerl5
     , initPerl5, freePerl5, canPerl5
     , evalPCR, pugs_SvToVal
@@ -93 +93 @@
     deriving (Show, Eq, Ord, Typeable)
 type PugsVal = PerlSV
+type PugsEnv = PerlSV
 
 data InvokePerl5Result
@@ -108 +109 @@
 freePerl5 _ = return ()
 
-evalPerl5 :: String -> PerlSV -> CInt -> IO PerlSV
+evalPerl5 :: String -> PugsEnv -> CInt -> IO PerlSV
 evalPerl5 _ _ = constFail
 
@@ -129 +130 @@
 mkVal = constFail
 
+mkEnv :: (Show a) => a -> IO PugsVal
+mkEnv = constFail
+
 mkValRef :: a -> String -> IO PerlSV
 mkValRef _ = constFail
@@ -135 +139 @@
 vstrToSV = constFail
 
+svUndef :: IO PerlSV
+svUndef = error "perl5 not embedded"
+
 bufToSV :: ByteString -> IO PerlSV
 bufToSV = constFail
@@ -144 +151 @@
 vnumToSV = constFail
 
-invokePerl5 :: PerlSV -> PerlSV -> [PerlSV] -> PugsVal -> CInt -> IO InvokePerl5Result
+invokePerl5 :: PerlSV -> PerlSV -> [PerlSV] -> PugsEnv -> CInt -> IO InvokePerl5Result
 invokePerl5 _ _ _ _ = constFail
 
@@ -155 +162 @@
 nullSV :: PerlSV
 nullSV = error "perl5 not embedded"
+
+nullEnv :: PugsVal
+nullEnv = error "perl5 not embedded"
 
 -- Below are unused
@@ -176 +186 @@
 import Foreign.C.Types
 import Foreign.C.String
+import {-# SOURCE #-} Pugs.AST.Internals
 import qualified UTF8 as Str
 
 type PerlInterpreter = Ptr ()
 type PerlSV = Ptr ()
-type PugsVal = Ptr ()
+type PugsVal = StablePtr Val
+type PugsEnv = StablePtr Env
 
 foreign import ccall "EXTERN.h perl_alloc"
@@ -214 +226 @@
 foreign import ccall "../../perl5/p5embed.h perl5_newSVnv"
     perl5_newSVnv :: CDouble -> IO PerlSV
+foreign import ccall "../../perl5/p5embed.h perl5_sv_undef"
+    perl5_sv_undef :: IO PerlSV
 foreign import ccall "../../perl5/p5embed.h perl5_get_sv"
     perl5_get_sv :: CString -> IO PerlSV
 foreign import ccall "../../perl5/p5embed.h perl5_apply"
-    perl5_apply :: PerlSV -> PerlSV -> Ptr PerlSV -> PugsVal -> CInt -> IO (Ptr PugsVal)
+    perl5_apply :: PerlSV -> PerlSV -> Ptr PerlSV -> PugsEnv -> CInt -> IO (Ptr PerlSV)
 foreign import ccall "../../perl5/p5embed.h perl5_can"
     perl5_can :: PerlSV -> CString -> IO Bool
 foreign import ccall "../../perl5/p5embed.h perl5_eval"
-    perl5_eval :: CString -> PugsVal -> CInt -> IO PerlSV
+    perl5_eval :: CString -> PugsEnv -> CInt -> IO PerlSV
 foreign import ccall "../../perl5/p5embed.h perl5_init"
     perl5_init :: CInt -> Ptr CString -> IO PerlInterpreter
 
 foreign import ccall "../../perl5/pugsembed.h pugs_getenv"
-    pugs_getenv :: IO PugsVal
+    pugs_getenv :: IO PugsEnv
 foreign import ccall "../../perl5/pugsembed.h pugs_setenv"
-    pugs_setenv :: PugsVal -> IO ()
+    pugs_setenv :: PugsEnv -> IO ()
 
 foreign import ccall "../../perl5/pugsembed.h pugs_SvToVal"
@@ -235 +249 @@
     pugs_MkValRef :: PugsVal -> CString -> IO PerlSV
 
-initPerl5 :: (Show a) => String -> Maybe a -> IO PerlInterpreter
+initPerl5 :: String -> Maybe Env -> IO PerlInterpreter
 initPerl5 str env = do
     withCString "-e" $ \prog -> withCString str $ \cstr -> do
@@ -241 +255 @@
             interp <- perl5_init 3 argv
             case env of
-                Just val -> pugs_setenv =<< mkVal val
-                Nothing -> return ()
+                Just val    -> pugs_setenv =<< mkEnv val
+                Nothing     -> return ()
             modifyIORef _GlobalFinalizer (>> perl_free interp)
             return interp
 
-mkVal :: (Show a) => a -> IO PugsVal
-mkVal val = fmap castStablePtrToPtr $ newStablePtr val
+mkVal :: Val -> IO PugsVal
+mkVal x = do
+    -- warn "Creating nonblessed stable pointer for " (showVal x)
+    newStablePtr x
+
+mkEnv :: Env -> IO PugsEnv
+mkEnv = newStablePtr
 
 svToVStr :: PerlSV -> IO String
@@ -261 +280 @@
 svToVBool = perl5_SvTRUE
 
-svToVal :: (Show a) => PerlSV -> IO a
+svToVal :: PerlSV -> IO Val
 svToVal sv = do
     ptr <- pugs_SvToVal sv
-    deRefStablePtr (castPtrToStablePtr ptr)
-
-mkValRef :: a -> String -> IO PerlSV
+    deRefStablePtr ptr
+
+mkValRef :: Val -> String -> IO PerlSV
 mkValRef x typ = do
-    ptr <- fmap castStablePtrToPtr $ newStablePtr x
-    withCString typ (pugs_MkValRef ptr)
+    -- warn "Creating stable pointer for " (showVal x)
+    val <- mkVal x
+    withCString typ (pugs_MkValRef val)
+
+svUndef :: IO PerlSV
+svUndef = perl5_sv_undef
 
 vstrToSV :: String -> IO PerlSV
@@ -289 +312 @@
     | Perl5ErrorObject PerlSV
 
-invokePerl5 :: PerlSV -> PerlSV -> [PerlSV] -> PugsVal -> CInt -> IO InvokePerl5Result
+invokePerl5 :: PerlSV -> PerlSV -> [PerlSV] -> PugsEnv -> CInt -> IO InvokePerl5Result
 invokePerl5 sub inv args env cxt = do
     withArray0 nullPtr args $ \argv -> do
@@ -308 +331 @@
 
 mkSV :: IO PerlSV -> IO PerlSV
-mkSV = id
-{- 
-action = do
+mkSV action = action
+{-
+ - do
     sv <- action 
     addFinalizer sv (perl5_finalize sv)
@@ -316 +339 @@
 -}
 
-evalPerl5 :: String -> PugsVal -> CInt -> IO PerlSV
+evalPerl5 :: String -> PugsEnv -> CInt -> IO PerlSV
 evalPerl5 str env cxt = mkSV $ Str.useAsCString (cast str) $ \cstr -> perl5_eval cstr env cxt
 
@@ -327 +350 @@
 nullSV = nullPtr
 
+{-# NOINLINE nullEnv #-}
+nullEnv :: PugsEnv
+nullEnv = unsafePerformIO (newStablePtr (error "undefined environment"))
+
 evalPCR :: FilePath -> String -> String -> [(String, String)] -> IO String
 evalPCR path match rule subrules = do
-    envSV   <- mkVal ()
     let bridgeMod   = "Pugs::Runtime::Match::HsBridge"
         bridgeFile  = "Pugs/Runtime/Match/HsBridge.pm";
@@ -338 +364 @@
         , "}"
         , "'"++bridgeMod++"'"
-        ]) envSV 1
+        ]) nullEnv 1
     meth    <- vstrToSV "__RUN__"
     args    <- mapM vstrToSV $ concatMap (\(x, y) -> [x, y]) ((match, rule):subrules)
-    rv      <- invokePerl5 meth inv args envSV 1
+    rv      <- invokePerl5 meth inv args nullEnv 1
     case rv of
         Perl5ReturnValues []    -> return ""

src/Pugs/Parser/Charnames.hs

@@ -16 +16 @@
 nameToCode :: String -> Maybe Int
 nameToCode name = inlinePerformIO $ do
-    envSV   <- mkVal ()
-    sv      <- evalPerl5 ("use utf8; use charnames ':full'; ord(qq[\\N{"++name++"}])") envSV 1
+    sv      <- evalPerl5 ("use utf8; use charnames ':full'; ord(qq[\\N{"++name++"}])") nullEnv 1
     svToVInt sv >>= \iv -> case iv of
         0 -> svToVStr sv >>= \pv -> case pv of

src/Pugs/Prim.hs

@@ -248 +248 @@
     let requireLine = "require " ++ pkg ++ "; '" ++ pkg ++ "'"
     val     <- guardIO $ do
-        envSV   <- mkVal (VControl $ ControlEnv env)
+        envSV   <- mkEnv env
         sv      <- evalPerl5 requireLine envSV $ enumCxt cxtItemAny
         return (PerlSV sv)
@@ -285 +285 @@
     env <- ask
     tryIO undef $ do
-        envSV <- mkVal (VControl $ ControlEnv env)
+        envSV <- mkEnv env
         sv <- evalPerl5 str envSV $ enumCxt (envContext env)
         svToVal sv

src/Pugs/Run.hs

@@ -170 +170 @@
             }
     -}
-    initPerl5 "" (Just . VControl $ ControlEnv env'{ envDebug = Nothing })
+    initPerl5 "" (Just env')
     initPreludePC env'             -- null in first pass
     where

src/Pugs/Run/Perl5.hs

@@ -49 +49 @@
 
 askPerl5Env :: IO Env
-askPerl5Env = do
-    val <- deVal =<< pugs_getenv
-    case val of
-        VControl (ControlEnv env)   -> return env
-        _                           -> do
-            print val
-            fail "cannot fetch $pugs::env"
+askPerl5Env = deEnv =<< pugs_getenv
 
 pugs_eval :: CString -> IO PugsVal
@@ -74 +68 @@
     sub     <- deVal subPtr
     inv     <- deValMaybe invPtr
-    args    <- mapM deVal =<< peekArray0 nullPtr argsPtr
+    args    <- mapM deVal =<< peekArray0 nullVal argsPtr
     let subExp = case sub of
             VStr name@('&':_)   -> _Var name
@@ -85 +79 @@
 
 deVal :: PugsVal -> IO Val
-deVal ptr = deRefStablePtr (castPtrToStablePtr ptr)
+deVal ptr = deRefStablePtr ptr
+
+deEnv :: PugsEnv -> IO Env
+deEnv ptr = deRefStablePtr ptr
+
+nullVal :: PugsVal
+nullVal = unsafeCoerce# nullPtr
 
 deValMaybe :: PugsVal -> IO (Maybe Val)
-deValMaybe ptr | ptr == nullPtr = return Nothing
+deValMaybe ptr | nullVal == nullVal = return Nothing
 deValMaybe ptr = fmap Just (deVal ptr)
 

src/Pugs/Types/Array.hs

@@ -280 +280 @@
 perl5EvalApply code args = do
     env     <- ask
-    envSV   <- liftIO $ mkVal env
+    envSV   <- liftIO $ mkEnv env
     subSV   <- liftIO $ evalPerl5 code envSV (enumCxt cxtItemAny)
     runInvokePerl5 subSV nullSV args

src/perl5/p5embed.c

@@ -403 +403 @@
 
 SV *
+perl5_sv_undef ()
+{
+    return(&PL_sv_undef);
+}
+
+SV *
 perl5_newSVpvn ( char * pv, int len )
 {

src/perl5/p5embed.h

@@ -21 +21 @@
 SV * perl5_get_sv ( const char *name );
 void perl5_finalize ( SV* sv );
-
+SV * perl5_sv_undef ();