Changeset 16341

Timestamp:

05/17/07 23:17:45 (18 months ago)

Author:

audreyt

Message:

* Tonights work

Files:

• docs/notes/pad-refactoring.pod (modified) (1 diff)
• src/DrIFT/YAML.hs (modified) (3 diffs)
• src/Pugs/AST/Internals.hs (modified) (2 diffs)
• src/Pugs/Eval.hs (modified) (8 diffs)
• src/Pugs/Meta/Str.hs (modified) (1 diff)
• src/Pugs/Monads.hs (modified) (1 diff)
• src/Pugs/Parser.hs (modified) (8 diffs)
• src/Pugs/Parser/Program.hs (modified) (2 diffs)
• src/Pugs/Parser/Types.hs (modified) (2 diffs)
• src/Pugs/Parser/Util.hs (modified) (1 diff)
• src/Pugs/Prim/Code.hs (modified) (1 diff)
• src/Pugs/Types.hs (modified) (1 diff)

docs/notes/pad-refactoring.pod

@@ -14 +14 @@
     -- otoh, it's rare enough that we don't actually care.
         -- but our Var is current symbolic.
+
+-- A subroutine when it's fully formed will always have its own pad as static.
+   (copied from envCompPad.)
+-- A subroutine when it's cloned wil use env's outer as outer.
 
 -- envLexPads :: LexPads

src/DrIFT/YAML.hs

@@ -16 +16 @@
 import Data.List        ( foldl' )
 import Data.Int         ( Int32, Int64 )
-import Pugs.Internals (encodeUTF8, decodeUTF8)
+import Pugs.Internals (encodeUTF8, decodeUTF8, addressOf)
 import Data.HashTable (HashTable)
 import qualified UTF8 as Buf
 import qualified Data.ByteString as Bytes
-import qualified Data.IntMap as IntMap
+import qualified Data.IntSet as IntSet
 import qualified Data.HashTable as Hash
 
@@ -28 +28 @@
 type YAMLKey = String
 type YAMLVal = YamlNode
-type SeenCache = IORef (IntMap.IntMap (Ptr ()))
+type SeenCache = IORef IntSet.IntSet
 
 toYamlNode :: YAML a => a -> IO YamlNode
 toYamlNode x = do
-    cache   <- newIORef IntMap.empty 
+    cache   <- newIORef IntSet.empty 
     runReaderT (asYAML x) cache
 
@@ -235 +235 @@
 
 asYAMLanchor :: a -> EmitAs YamlNode -> EmitAs YamlNode
-asYAMLanchor _ m = m
-{-do
+asYAMLanchor x m = do
     cache   <- ask
     seen    <- liftIO $ readIORef cache
-    ref     <- liftIO $ fmap castStablePtrToPtr (newStablePtr x)
-    let ptr = ref `minusPtr` nullPtr
-    if IntMap.member ptr seen
+    let ptr = -(fromEnum (addressOf x))
+    if IntSet.member ptr seen
         then return nilNode{ n_anchor = AReference ptr } 
         else do
-            liftIO $ modifyIORef cache (IntMap.insert ptr ref)
+            liftIO $ modifyIORef cache (IntSet.insert ptr)
             rv  <- m
             return rv{ n_anchor = AAnchor ptr }
--}
 
 asYAMLwith :: (YAML a, YAML b) => (a -> EmitAs b) -> a -> EmitAs YamlNode

src/Pugs/AST/Internals.hs

@@ -1312 +1312 @@
 defaultArrayParam   = buildParam "" "*" "@_" (Val VUndef)
 defaultHashParam    = buildParam "" "*" "%_" (Val VUndef)
-defaultScalarParam  = buildParam "" "?" "$_" (Var $ cast "$_")
+defaultScalarParam  = buildParam "" "?" "$_" (Var $ cast "$OUTER::_")
 
 type DebugInfo = Maybe (TVar (Map ID String))
@@ -1558 +1558 @@
 
 writeVar :: Var -> Val -> Eval ()
-writeVar name val = do
-    glob <- askGlobal
-    case lookupPad name glob of
-        Just PEConstant{} -> fail $ "Cannot rebind constant: " ++ show name
-        Just c -> do
-            ref <- stm $ readTVar (pe_store c)
-            writeRef ref val
-        _  -> fail $ "Cannot bind to non-existing variable: " ++ show name
+writeVar var val
+    | isLexicalVar var  = doWriteVar (asks envLexical)
+    | otherwise         = doWriteVar askGlobal
+    where
+    doWriteVar askPad = do
+        pad <- askPad
+        case lookupPad var pad of
+            Just PEConstant{} -> fail $ "Cannot rebind constant: " ++ show var
+            Just c -> do
+                ref <- stm $ readTVar (pe_store c)
+                writeRef ref val
+            _  -> fail $ "Cannot bind to non-existing variable: " ++ show var
 
 readVar :: Var -> Eval Val

src/Pugs/Eval.hs

@@ -445 +445 @@
         unless (isEmptyParams (subParams sub)) $
             fail "Blocks with implicit params cannot occur at statement level"
-        env <- ask
         enterSub sub . reduce $ case unwrap (subBody sub) of
             Syn "block" [exp] -> case unwrap exp of
@@ -475 +474 @@
     -- newBody <- transformExp cloneBodyStates $ subBody sub
     -- add &?BLOCK &?ROUTINE etc here
-    started <- if isCompileTime env then return Nothing else fmap Just (stm $ newTVar False)
-    pad     <- fmap (`mappend` subInnerPad sub) $ mergeLexPads (envLexPads env)
+    started         <- if isCompileTime env then return Nothing else fmap Just (stm $ newTVar False)
+    inner           <- clonePad (subInnerPad sub) 
+    (lpads, outer)  <- cloneLexPads (envLexPads env)
     return $ VCode sub
         { subCont       = cont
-        , subOuterPads  = envLexPads env
-        , subLexical    = pad
+        , subOuterPads  = lpads
+        , subInnerPad   = inner
+        , subLexical    = outer `mappend` inner 
         , subStarted    = started
         }
     where
+    cloneLexPads chain = do
+        pads <- forM chain $ \lpad -> case lpad of
+            PRuntime p      -> do
+                p'  <- snapPad p
+                return (PRuntime p', p')
+            PCompiling p    -> do
+                p'  <- stm $ readTVar p
+                return (lpad, p')
+        let merged  = MkPad $ Map.unionsWith mergePadEntry (map (padEntries . snd) pads)
+            lexpads = map fst pads
+        return (lexpads, merged)
 --    cloneBodyStates (Pad scope pad exp) | scope <= SMy = do
 --        pad' <- clonePad pad
 --        return $ Pad scope pad' exp
     cloneBodyStates x = return x -- XXX!
+    snapPad pad = stm $ do
+        fmap listToPad $ forM (padToList pad) $ \(var, entry) -> do
+            case entry of
+                PELexical{} -> do
+                    store <- newTVar =<< readTVar (pe_store entry)
+                    return (var, entry{ pe_store = store })
+                _   -> return (var, entry)
     clonePad pad = stm $ do
         fmap listToPad $ forM (padToList pad) $ \(var, entry) -> do
@@ -503 +522 @@
     clonePadEntry x@PELexical{} f = do
         tvar'   <- newTVar =<< f x
-        fresh'  <- newTVar False
         return x{ pe_store = tvar' }
 
@@ -1350 +1368 @@
 applyThunk styp bound@(arg:_) thunk = do
     -- introduce self and $_ as the first invocant.
+    {-
     inv     <- case styp of
         SubPointy               -> aliased [cast "$_"]
-        _ | styp <= SubMethod   -> aliased [cast "&self"] -- , "$_"]
+        _ | styp <= SubMethod   -> aliased [cast "&self"]
         _                       -> return []
-    pad <- formal
-    enterLex (inv ++ pad) $ thunk_force thunk
-    where
-    -- Don't generate pad entries for siglets such as "$" and "@".
-    formal = sequence
-        [ genSym var =<< fromVal val
-        | ApplyArg var val _ <- bound
-        , v_name var /= nullID
-        ]
-    aliased names = do
-        argRef  <- fromVal (argValue arg)
-        mapM (`genSym` argRef) names
+    -}
+    let withInv | styp <= SubMethod = (ApplyArg (cast "&self") (argValue arg) False:)
+                | otherwise         = id
+    sequence_ [ bindVar var val
+              | ApplyArg var val _ <- withInv bound
+              -- Don't generate pad entries for siglets such as "$" and "@".
+              , v_name var /= nullID
+              ]
+    thunk_force thunk
+
+bindVar :: Var -> Val -> Eval ()
+bindVar var val
+    | isLexicalVar var  = doBindVar (asks envLexical)
+    | otherwise         = doBindVar askGlobal
+    where
+    doBindVar askPad = do
+        pad <- askPad
+        case lookupPad var pad of
+            Just PEConstant{} -> fail $ "Cannot rebind constant: " ++ show var
+            Just c -> do
+                ref <- fromVal val
+                stm $ writeTVar (pe_store c) ref
+            _  -> fail $ "Cannot bind to non-existing variable: " ++ show var
 
 {-|
@@ -1411 +1441 @@
                         ++ show ((genericLength (take 1000 extra)) + n) ++ " actual, "
                         ++ show n ++ " expected"
-            (syms, bound) <- doBind [] (subBindings sub)
+            bound <- mapM doBind (subBindings sub)
             -- trace (show bound) $ return ()
-            val <- local fixEnv $ enterLex syms $ do
+            val <- local fixEnv $ do
                 (`juncApply` bound) $ \realBound -> do
                     enterSub sub $ case cont of
@@ -1441 +1471 @@
     fixEnv | typ >= SubBlock = id
            | otherwise       = envEnterCaller
-    doBind :: [PadMutator] -> [(Param, Exp)] -> Eval ([PadMutator], [ApplyArg])
-    doBind syms [] = return (syms, [])
-    doBind syms ((prm, exp):rest) = do
+    doBind :: (Param, Exp) -> Eval ApplyArg -- ([PadMutator], [ApplyArg])
+    doBind (prm, exp) = do
         -- trace ("<== " ++ (show (prm, exp))) $ return ()
         let var = paramName prm
@@ -1449 +1478 @@
         (val, coll) <- enterContext cxt $ case exp of
             Syn "param-default" [exp, Val (VCode sub)] -> do
-                local (fixSub sub . fixEnv) $ enterLex syms $ expToVal prm exp
+                local (fixSub sub . fixEnv) $ expToVal prm exp
             _  -> expToVal prm exp
         -- trace ("==> " ++ (show val)) $ return ()
-        boundRef <- fromVal val
-        newSym   <- genSym var boundRef
-        (syms', restArgs) <- doBind (newSym:syms) rest
-        return (syms', ApplyArg var val coll:restArgs)
+        -- boundRef <- fromVal val
+        -- newSym   <- genSym var boundRef
+        return $ ApplyArg var val coll
     expToVal :: Param -> Exp -> Eval (Val, Bool)
     expToVal MkOldParam{ isLazy = thunk, isLValue = lv, paramContext = cxt, paramName = var, isWritable = rw } exp = do
@@ -1562 +1590 @@
     Syn "block" [Val VCode{}]   -> fromClosure x
     Syn "block" [_]             -> do
-        env <- ask
         return $ mkCode
             { -- subEnv        = Just env - XXX

src/Pugs/Meta/Str.hs

@@ -1 +1 @@
 {-# OPTIONS_GHC -fglasgow-exts #-}
 
-module Pugs.Meta.Str where
+module Pugs.Meta.Str (_StrClass) where
 import Data.Maybe
 import Pugs.Val

src/Pugs/Monads.hs

@@ -276 +276 @@
             -- Entering a block.
             blockRec  <- genSym (cast "&?BLOCK") (codeRef (orig sub))
-            pad       <- fmap (`mappend` pad) $ mergeLexPads (subOuterPads sub)
             return $ \e -> e
-                { envLexical = combine [blockRec] pad
+                { envLexical = combine [blockRec] (envLexical env `mappend` pad)
                 , envPackage = subPackage sub
-                , envLexPads = (PRuntime pad:subOuterPads sub)
+                , envLexPads = (PRuntime pad:envLexPads env)
                 }
         | otherwise = do
             subRec    <- genSym (cast "&?ROUTINE") (codeRef (orig sub))
             callerRec <- genSym (cast "&?CALLER_CONTINUATION") (codeRef $ ccSub cc env)
-            pad       <- fmap (`mappend` pad) $ mergeLexPads (subOuterPads sub)
+            pad'      <- fmap (`mappend` pad) $ mergeLexPads (subOuterPads sub)
             return $ \e -> e
-                { envLexical = combine ([subRec, callerRec]) pad
+                { envLexical = combine ([subRec, callerRec]) pad'
                 , envPackage = subPackage sub
-                , envLexPads = (PRuntime pad:subOuterPads sub)
+                , envLexPads = (PRuntime pad':subOuterPads sub)
                 }
     ccSub :: (Val -> Eval Val) -> Env -> VCode

src/Pugs/Parser.hs

@@ -26 +26 @@
     ruleInvocationParens, verbatimVarNameString, ruleVerbatimBlock, retVerbatimBlock,
     ruleBlockLiteral, ruleDoBlock, regularVarName, regularVarNameForSigil, ruleNamedMethodCall,
+
+    genParamEntries
 ) where
 import Pugs.Internals
@@ -388 +390 @@
     -- XXX - Generate init pad for each of our params...
 
-    paramsPad   <- genParamEntries signature
+    paramsPad   <- genParamEntries styp signature
     modify $ \s -> s{ s_protoPad = paramsPad }
     block       <- ruleBlock
@@ -410 +412 @@
     
     -- Don't add the sub if it's unsafe and we're in safemode.
-    if "unsafe" `elem` traits && safeMode then return emptyExp else do
+    if "unsafe" `elem` traits && safeMode then return (Var var) else do
     (`finallyM` clearDynParsers) $ if not (isLexicalVar var)
-        then do unsafeEvalExp $ mkSym sub nameQualified Noop
+        then do unsafeEvalExp $ mkSym sub nameQualified (Var var)
         else do
-            let doExportCode rv = if not isExported then return emptyExp else do
+            let doExportCode = if not isExported then return (Var var) else do
                     -- we mustn't perform the export immediately upon parse, because
                     -- then only the first consumer of a module will see it. Instead,
@@ -433 +435 @@
                                 , subParams = multiSig
                                 }
-                    return . seq rv $ Syn "|="
+                    unsafeEvalExp $ Syn "|="
                         [ Syn "{}" [_Var ("%" ++ pkg ++ "::EXPORTS"), Val $ VStr exportedName]
                         , Val exportedSub
                         ]
+                    return (Var var)
             case lookupPad var newPad of
                 Just entry  -> do
-                    Val val@(VCode code) <- unsafeEvalExp (Syn "sub" [Val sub])
+                    Val (VCode code) <- unsafeEvalExp (Syn "sub" [Val sub])
                     let entry'  = entry{ pe_proto = cv' }
                         cv'     = MkRef (ICode code)
                     addBlockPad (adjustPad (const entry') var newPad)
-                    result <- doExportCode val
+                    result <- doExportCode
                     case entry' of
-                        PEConstant{} -> return result
+                        PEConstant{}    -> return result
                         _               -> return $! unsafePerformSTM $! do
                             rv  <- writePadEntry entry' cv'
@@ -1248 +1251 @@
 ruleBlockVariants variants = do
     (styp, formal, lvalue) <- option (SubBlock, Nothing, False) $ choice variants
+
+    paramsPad  <- genParamEntries styp (maybe (defaultParamFor styp) id formal)
+    modify $ \s -> s{ s_protoPad = paramsPad }
+
     block <- ruleBlock
     retBlock styp formal lvalue block
@@ -1329 +1336 @@
         | otherwise                     = t
 
-genParamEntries params = genNameTypeEntries SMy (paramsToNameTypes params "")
+genParamEntries styp params
+    | styp >= SubBlock  = genNameTypeEntries SMy nameTypes
+    | otherwise         = genNameTypeEntries SMy (foldl' withImplicit nameTypes implicitNames)
+    where
+    nameTypes       = paramsToNameTypes params ""
+    names           = Set.fromList $ map (\(n, _, _, _) -> n) nameTypes
+    implicitNames   = ["$_"] -- , "$/", "$!"]
+    withImplicit ntys name
+        | Set.member (cast name) names  = ntys
+        | otherwise                     = (((cast name), anyType, MkEntryFlags True, Noop):ntys)
 
 ruleVarDecl :: RuleParser Exp
@@ -1371 +1387 @@
     makeAccessor prm = do
         -- Generate accessor for class attributes.
-        pkg <- asks envPackage
+        pkg         <- asks envPackage
+        paramsPad   <- genParamEntries SubPrim [selfParam $ cast pkg]
         let sub = mkPrim
                 { isMulti       = False
@@ -1380 +1397 @@
                 , subLValue     = isWritable prm
                 , subType       = SubMethod
+                , subInnerPad   = paramsPad
                 }
             fun = Var var{ v_twigil = TNil }

src/Pugs/Parser/Program.hs

@@ -165 +165 @@
 ruleProgram = rule "program" $ do
     env     <- getRuleEnv
+
+    topPad  <- genParamEntries SubRoutine [defaultArrayParam]
+    modify $ \s -> s{ s_protoPad = topPad }
+
     block   <- ruleBlockBody
-    main    <- retVerbatimBlock SubRoutine Nothing False $
+    main    <- retVerbatimBlock SubPointy Nothing False $
         block{ bi_body = mergeStmts emptyExp $ bi_body block }
+
     -- error $ show statements
     eof
@@ -185 +190 @@
     env' <- getRuleEnv
     return $ env'
-        { envBody       = App main Nothing [_Var "@*ARGS"]
+        { envBody       = App main Nothing [] -- _Var "@*ARGS"]
         , envPackage    = envPackage env
         }

src/Pugs/Parser/Types.hs

@@ -252 +252 @@
     -- First we check that our pad does not contain shadows OUTER symbols.
     state <- get
-    let myVars  = padKeys pad
-        dupVars = myVars `Set.intersection` Map.keysSet (s_knownVars state)
+    let myVars          = padKeys pad
+        dupVars         = myVars `Set.intersection` Map.keysSet outerKnownVars
+        outerKnownVars  = Map.filter (/= compPad) (s_knownVars state)
+        Just compPad    = envCompPad (s_env state)
 
     unless (Set.null dupVars) $ do
@@ -261 +263 @@
 
     -- Then we merge the Pad into COMPILING, and add those vars into s_knownVars.
-    Just compPad <- asks envCompPad
-    ()           <- stm $ modifyTVar compPad (`unionPads` pad)
+    ()  <- stm $ modifyTVar compPad (`unionPads` pad)
 
     let myKnownVars = Map.fromDistinctAscList [ (var, compPad) | var <- Set.toAscList myVars ]

src/Pugs/Parser/Util.hs

@@ -118 +118 @@
     
 defaultParamFor :: SubType -> [Param]
-defaultParamFor SubBlock    = [defaultScalarParam]
+defaultParamFor SubBlock    = [] -- defaultScalarParam]
 defaultParamFor SubPointy   = []
 defaultParamFor _           = [defaultArrayParam]

src/Pugs/Prim/Code.hs

@@ -37 +37 @@
 
 op1CodePos :: Val -> Eval Val
-op1CodePos v = die "XXX - code.pos not implemented" v
+op1CodePos v = do -- die "XXX - code.pos not implemented" v
+    return $ castV (show v)
 {-
 do

src/Pugs/Types.hs

@@ -464 +464 @@
     (twi, (pkg, (cat, afterCat)))
         | len == 0 = (TNil, (emptyPkg, (CNil, afterSig)))
+--      | len <= 1 = (TNil, (emptyPkg, (CNil, afterSig)))
         | len == 1 = case Buf.head afterSig of
             '!' -> (TGlobal, (emptyPkg, (CNil, afterSig)))  -- XXX $! always global - WRONG