blip 0.2.0 → 0.2.1

raw patch · 11 files changed

+3431/−1 lines, 11 files

Files

• blip.cabal +12/−1
• src/Assemble.hs +67/−0
• src/Compile.hs +1413/−0
• src/Desugar.hs +159/−0
• src/Monad.hs +31/−0
• src/ProgName.hs +18/−0
• src/Scope.hs +517/−0
• src/StackDepth.hs +320/−0
• src/State.hs +543/−0
• src/Types.hs +143/−0
• src/Utils.hs +208/−0

@@ -1,5 +1,5 @@ Name:                blip -Version:             0.2.0+Version:             0.2.1 Synopsis:            Python to bytecode compiler. Homepage:            https://github.com/bjpop/blip   License:             BSD3@@ -35,4 +35,15 @@      old-time==1.1.*,      pretty==1.1.*      -- utf8-string==0.3.*+  other-modules:+     Assemble+     Desugar+     Monad+     Scope+     State+     Utils+     Compile+     ProgName+     StackDepth+     Types }

@@ -0,0 +1,67 @@+{-# LANGUAGE RecordWildCards #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Assemble+-- Copyright   : (c) 2012, 2013 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Convert the jump targets in the annotated bytecode to real offsets.+--+-----------------------------------------------------------------------------++module Assemble (assemble) where+ +import Utils (isRelativeJump, isAbsoluteJump)+import Types (BlockState (..), AnnotatedCode (..), LabelMap)+import State (getBlockState, getLabelMap, modifyBlockState)+import Blip.Bytecode (Bytecode (..), BytecodeArg (..), bytecodeSize)+import Monad (Compile (..))+import Data.Map as Map (lookup)+import Data.Word (Word16)++assemble :: Compile ()+assemble = do+   -- The bytecode instructions within the compiler state are+   -- in a list in reverse order.+   annotatedCode <- reverse `fmap` getBlockState state_instructions+   labelMap <- getLabelMap+   let finalAnnotatedCode = applyLabelMap labelMap annotatedCode+   modifyBlockState $ \s -> s { state_instructions = finalAnnotatedCode }++applyLabelMap :: LabelMap -> [AnnotatedCode] -> [AnnotatedCode]+applyLabelMap labelMap code =+   map fixJumpTarget code+   where+   fixJumpTarget :: AnnotatedCode -> AnnotatedCode+   fixJumpTarget annotatedCode =+      annotatedCode { annotatedCode_bytecode = newBytecode }+      where+      thisOpCode = opcode bytecode+      newBytecode+         | isRelativeJump thisOpCode = relativeTarget bytecode index jumpTarget+         | isAbsoluteJump thisOpCode = absoluteTarget bytecode jumpTarget+         | otherwise = bytecode+      bytecode = annotatedCode_bytecode annotatedCode+      index = annotatedCode_index annotatedCode+      jumpTarget =+         case args bytecode of+            Nothing ->+               error $ "Jump instruction without argument: " ++ show code +            Just (Arg16 label) -> +               case Map.lookup label labelMap of+                  Nothing ->+                     error $ "Jump instruction to unknown target label: " ++ show code+                  Just target -> target++relativeTarget :: Bytecode -> Word16 -> Word16 -> Bytecode+relativeTarget code@(Bytecode {..}) index target+   = code { args = Just $ Arg16 newTarget } +   where+   newTarget = target - (index + (fromIntegral $ bytecodeSize code))++absoluteTarget :: Bytecode -> Word16 -> Bytecode+absoluteTarget code@(Bytecode {..}) target+   = code { args = Just $ Arg16 target }

@@ -0,0 +1,1413 @@+{-# LANGUAGE TypeFamilies, TypeSynonymInstances, FlexibleInstances,+    PatternGuards, RecordWildCards #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Compile+-- Copyright   : (c) 2012, 2013 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Compilation of Python 3 source code into bytecode.+-- +-- Basic algorithm:+--+-- 1) Parse the source code into an AST.+-- 2) Compute the scope of all variables in the module+--    (one pass over the AST).+-- 3) Compile the AST for the whole module into a (possibly nested)+--    code object (one pass over the AST).+-- 4) Write the code object to a .pyc file.+--+-- The following Python constructs are compiled into code objects:+--    - The top-level of the module.+--    - Function definitions (def and lambda).+--    - Class definitions.+--    - Comprehensions.+--+-- The statements and expressions in each of the above constructs are+-- recursively compiled into bytecode instructions. Initially, the actual+-- addresses of jump instruction targets are not known. Instead the jump+-- targets are just labels. At the end of the compilation of each+-- construct the labelled instructions are converted into jumps to+-- actual addresses (one pass over the bytecode stream).+-- Also the maximum stack size of each code object is computed (one pass+-- over the bytecode stream).+--+-- We currently make no attempt to optimise the generated code.+--+-- Bytecode is generated directly from the AST, there is no intermediate+-- language, and no explict control-flow graph.+--+-----------------------------------------------------------------------------++module Compile (compileFile) where++import Prelude hiding (mapM)+import Desugar (desugarComprehension, desugarWith, resultName)+import Utils +   ( isPureExpr, isPyObjectExpr, mkAssignVar, mkList+   , mkVar, mkMethodCall, mkStmtExpr, mkSet, mkDict, mkAssign+   , mkSubscript, mkReturn, mkYield, spanToScopeIdentifier )+import StackDepth (maxStackDepth)+import ProgName (progName)+import State+   ( setBlockState, getBlockState, initBlockState, initState+   , emitCodeNoArg, emitCodeArg, compileConstantEmit+   , compileConstant, getFileName, newLabel, labelNextInstruction+   , getObjectName, setObjectName+   , getNestedScope, ifDump, getLocalScope+   , indexedVarSetKeys, emitReadVar, emitWriteVar, emitDeleteVar+   , lookupNameVar, lookupClosureVar, setFlag+   , peekFrameBlock, withFrameBlock, setFastLocals, setArgCount+   , setLineNumber, setFirstLineNumber )+import Assemble (assemble)+import Monad (Compile (..), runCompileMonad)+import Types+   ( Identifier, CompileConfig (..)+   , CompileState (..), BlockState (..)+   , AnnotatedCode (..), Dumpable (..), IndexedVarSet, VarInfo (..)+   , FrameBlockInfo (..), Context (..), ParameterTypes (..), LocalScope (..) )+import Scope (topScope, renderScope)+import Blip.Marshal as Blip+   ( writePyc, PycFile (..), PyObject (..), co_generator )+import Blip.Bytecode (Opcode (..), encode)+import Language.Python.Version3.Parser (parseModule)+import Language.Python.Common.AST as AST+   ( Annotated (..), ModuleSpan, Module (..), StatementSpan, Statement (..)+   , ExprSpan, Expr (..), Ident (..), ArgumentSpan, Argument (..)+   , OpSpan, Op (..), Handler (..), HandlerSpan, ExceptClause (..)+   , ExceptClauseSpan, ImportItem (..), ImportItemSpan, ImportRelative (..)+   , ImportRelativeSpan, FromItems (..), FromItemsSpan, FromItem (..)+   , FromItemSpan, DecoratorSpan, Decorator (..), ComprehensionSpan+   , Comprehension (..), SliceSpan, Slice (..), AssignOpSpan, AssignOp (..)+   , ParameterSpan, Parameter (..), RaiseExpr (..), RaiseExprSpan )+import Language.Python.Common (prettyText)+import Language.Python.Common.StringEscape (unescapeString)+import Language.Python.Common.SrcLocation (SrcSpan (..))+import System.FilePath ((<.>), takeBaseName)+-- XXX Commented out to avoid bug in unix package when building on OS X, +-- The unix package is depended on by the directory package.+-- import System.Directory (getModificationTime, canonicalizePath)+-- import System.Time (ClockTime (..))+import System.IO (openFile, IOMode(..), hClose, hFileSize, hGetContents)+import Data.Word (Word32, Word16)+import Data.Int (Int32)+import Data.Traversable as Traversable (mapM)+import qualified Data.ByteString.Lazy as B (pack)+import Data.String (fromString)+import Data.List (intersperse)+import Control.Monad (unless, forM_, when, replicateM_, foldM)+import Control.Exception (try)+import Control.Monad.Trans (liftIO)+import Data.Bits ((.|.), shiftL)++-- Compile Python source code to bytecode and write the+-- result out to a .pyc file. The name of the output+-- file is based on the name of the input file. For example+-- the input 'foo.py' will result in an output file called 'foo.pyc'.++compileFile :: CompileConfig -- Configuration options+            -> FilePath      -- The file path of the input Python source+            -> IO ()+compileFile config path = do+   r <- try $ do+      pyHandle <- openFile path ReadMode+      sizeInBytes <- hFileSize pyHandle+      fileContents <- hGetContents pyHandle+      -- modifiedTime <- getModificationTime path+      -- let modSeconds = case modifiedTime of TOD secs _picoSecs -> secs+      let modSeconds = (0 :: Integer)+      pyModule <- parseAndCheckErrors fileContents path+      (moduleLocals, nestedScope) <- topScope pyModule+      -- canonicalPath <- canonicalizePath path +      canonicalPath <- return path +      let state = initState ModuleContext moduleLocals +                     nestedScope config canonicalPath+      pyc <- compileModule state (fromIntegral modSeconds)+                (fromIntegral sizeInBytes) pyModule+      let pycFilePath = takeBaseName path <.> ".pyc"+      pycHandle <- openFile pycFilePath WriteMode +      writePyc pycHandle pyc+      hClose pycHandle+   -- XXX maybe we want more customised error messages for different kinds of+   -- IOErrors?+   case r of+      Left e -> putStrLn $ progName ++ ": " ++ show (e :: IOError)+      Right () -> return ()++-- Parse the Python source into an AST, check for any syntax errors.+parseAndCheckErrors :: String -> FilePath -> IO ModuleSpan+parseAndCheckErrors fileContents sourceName =+   case parseModule fileContents sourceName of+      Left e -> error $ "parse error: " ++ prettyText e+      Right (pyModule, _comments) -> return pyModule++compileModule :: CompileState   -- initial compiler state+              -> Word32         -- modification time+              -> Word32         -- size in bytes+              -> ModuleSpan     -- AST+              -> IO PycFile+compileModule state pyFileModifiedTime pyFileSizeBytes mod = do+   obj <- compiler mod state+   return $ PycFile+      { magic = compileConfig_magic $ state_config state+      , modified_time = pyFileModifiedTime +      , size = pyFileSizeBytes+      , object = obj }++compiler :: Compilable a => a -> CompileState -> IO (CompileResult a)+compiler = runCompileMonad . compile++class Compilable a where+   type CompileResult a :: *+   compile :: a -> Compile (CompileResult a)++instance Compilable a => Compilable [a] where+   type CompileResult [a] = [CompileResult a]+   compile = mapM compile++instance Compilable ModuleSpan where+   type CompileResult ModuleSpan = PyObject+   compile ast@(Module stmts) = do+      maybeDumpScope +      maybeDumpAST ast+      setObjectName "<module>"+      compileClassModuleDocString stmts+      compile $ Body stmts++-- body of module, function and class+newtype Body = Body [StatementSpan]++instance Compilable Body where+   type CompileResult Body = PyObject+   compile (Body stmts) = do+      mapM_ compile stmts+      -- XXX we could avoid this 'return None' if all branches in the code+      -- ended with a return statement. Can fix this in an optimisation step+      -- with control flow analysis.+      returnNone+      assemble+      makeObject++-- Build an object from all the state computed during compilation, such+-- as the bytecode sequence, variable information and so on.+-- argcount is the number of arguments, not counting *varargs or **kwargs.+makeObject :: Compile PyObject+makeObject = do+   annotatedCode <- getBlockState state_instructions+   let stackDepth = maxStackDepth annotatedCode+   names <- getBlockState state_names+   constants <- getBlockState state_constants+   freeVars <- getBlockState state_freeVars+   cellVars <- getBlockState state_cellVars+   argcount <- getBlockState state_argcount+   flags <- getBlockState state_flags+   fastLocals <- getBlockState state_fastLocals+   firstLineNumber <- getBlockState state_firstLineNumber+   lineNumberTable <- compileLineNumberTable firstLineNumber+   let code = map annotatedCode_bytecode annotatedCode +       localVarNames = map Unicode $ indexedVarSetKeys fastLocals+       maxStackDepth = maxBound +   if stackDepth > maxStackDepth+      -- XXX make a better error message+      then error $ "Maximum stack depth " ++ show maxStackDepth +++                   " exceeded: " ++ show stackDepth+      else do+         pyFileName <- getFileName+         objectName <- getObjectName+         let obj = Code+                   { argcount = argcount+                   , kwonlyargcount = 0+                   , nlocals = fromIntegral $ length localVarNames+                   , stacksize = stackDepth +                   , flags = flags +                   , code = String $ encode code+                   , consts = makeConstants constants+                   , names = makeNames names+                   , varnames = Blip.Tuple localVarNames+                   , freevars = makeVarSetTuple freeVars+                   , cellvars = makeVarSetTuple cellVars+                   , filename = Unicode pyFileName+                   , name = Unicode objectName+                   , firstlineno = firstLineNumber+                   , lnotab = lineNumberTable+                   }+         return obj+   where+   makeVarSetTuple :: IndexedVarSet -> PyObject+   makeVarSetTuple varSet =+      Blip.Tuple $ map Unicode $ indexedVarSetKeys varSet+   makeConstants :: [PyObject] -> PyObject+   makeConstants = Blip.Tuple . reverse+   makeNames :: [Identifier] -> PyObject+   makeNames = Blip.Tuple . map Unicode . reverse ++instance Compilable StatementSpan where+   type CompileResult StatementSpan = ()+   compile stmt =+      setLineNumber (annot stmt) >>+      compileStmt stmt+  +compileStmt :: StatementSpan -> Compile ()+compileStmt (Assign {..}) = do+   compile assign_expr+   compileAssignments assign_to+compileStmt (AugmentedAssign {..}) =+   case aug_assign_to of+      Var {..} -> do+         let varIdent = ident_string var_ident+         emitReadVar varIdent+         compile aug_assign_expr+         compile aug_assign_op+         emitWriteVar varIdent+      Subscript {..} -> do+         compile subscriptee+         compile subscript_expr+         emitCodeNoArg DUP_TOP_TWO -- avoids re-doing the above two later when we store+         emitCodeNoArg BINARY_SUBSCR+         compile aug_assign_expr+         compile aug_assign_op+         emitCodeNoArg ROT_THREE+         emitCodeNoArg STORE_SUBSCR+      SlicedExpr {..} -> do+         compile slicee+         compileSlices slices+         emitCodeNoArg DUP_TOP_TWO -- avoids re-doing the above two later when we store+         emitCodeNoArg BINARY_SUBSCR+         compile aug_assign_expr+         compile aug_assign_op+         emitCodeNoArg ROT_THREE+         emitCodeNoArg STORE_SUBSCR+      expr@(BinaryOp { operator = Dot {}, right_op_arg = Var {..}}) -> do+         compile $ left_op_arg expr+         emitCodeNoArg DUP_TOP+         index <- lookupNameVar $ ident_string $ var_ident+         emitCodeArg LOAD_ATTR index +         compile aug_assign_expr+         compile aug_assign_op+         emitCodeNoArg ROT_TWO+         emitCodeArg STORE_ATTR index +      other -> error $ "unexpected expression in augmented assignment: " ++ prettyText other+compileStmt (Return { return_expr = Nothing }) = returnNone+compileStmt (Return { return_expr = Just expr }) =  +   compile expr >> emitCodeNoArg RETURN_VALUE+compileStmt (Pass {}) = return ()+compileStmt (StmtExpr {..}) = +   unless (isPureExpr stmt_expr) $ +      compile stmt_expr >> emitCodeNoArg POP_TOP+compileStmt (Conditional {..}) = do+   restLabel <- newLabel+   mapM_ (compileGuard restLabel) cond_guards +   mapM_ compile cond_else+   labelNextInstruction restLabel+compileStmt (While {..}) = do+   startLoop <- newLabel+   endLoop <- newLabel+   anchor <- newLabel+   emitCodeArg SETUP_LOOP endLoop+   withFrameBlock (FrameBlockLoop startLoop) $ do+       labelNextInstruction startLoop+       compile while_cond+       emitCodeArg POP_JUMP_IF_FALSE anchor+       mapM_ compile while_body+       emitCodeArg JUMP_ABSOLUTE startLoop+       labelNextInstruction anchor +       emitCodeNoArg POP_BLOCK+   mapM_ compile while_else+   labelNextInstruction endLoop+compileStmt (For {..}) = do+   startLoop <- newLabel+   endLoop <- newLabel+   withFrameBlock (FrameBlockLoop startLoop) $ do+      anchor <- newLabel+      emitCodeArg SETUP_LOOP endLoop+      compile for_generator+      emitCodeNoArg GET_ITER+      labelNextInstruction startLoop+      emitCodeArg FOR_ITER anchor+      let num_targets = length for_targets+      when (num_targets > 1) $ do+         emitCodeArg UNPACK_SEQUENCE $ fromIntegral num_targets+      mapM_ compileAssignTo for_targets +      mapM_ compile for_body +      emitCodeArg JUMP_ABSOLUTE startLoop+      labelNextInstruction anchor+      emitCodeNoArg POP_BLOCK+   mapM_ compile for_else+   labelNextInstruction endLoop+compileStmt stmt@(Fun {..}) = compileFun stmt []+compileStmt stmt@(Class {..}) = compileClass stmt []+-- XXX assertions appear to be turned off if the code is compiled+-- for optimisation+-- If the assertion expression is a tuple of non-zero length, then+-- it is always True: CPython warns about this+compileStmt (Assert {..}) = do+   case assert_exprs of+      test_expr:restAssertExprs -> do+         compile test_expr+         end <- newLabel+         emitCodeArg POP_JUMP_IF_TRUE end+         assertionErrorVar <- lookupNameVar "AssertionError"+         emitCodeArg LOAD_GLOBAL assertionErrorVar+         case restAssertExprs of+            assertMsgExpr:_ -> do+               compile assertMsgExpr+               emitCodeArg CALL_FUNCTION 1+            _other -> return ()+         emitCodeArg RAISE_VARARGS 1+         labelNextInstruction end+      _other -> error "assert with no test"+compileStmt stmt@(Try {..}) = compileTry stmt+compileStmt (Import {..}) = mapM_ compile import_items+-- XXX need to handle from __future__ +compileStmt (FromImport {..}) = do+   let level = 0 -- XXX this should be the level of nesting+   compileConstantEmit $ Blip.Int level+   let names = fromItemsIdentifiers from_items +       namesTuple = Blip.Tuple $ map Unicode names+   compileConstantEmit namesTuple+   compileFromModule from_module+   case from_items of+      ImportEverything {} -> do+         emitCodeNoArg IMPORT_STAR+      FromItems {..} -> do+         forM_ from_items_items $ \FromItem {..} -> do+             index <- lookupNameVar $ ident_string from_item_name+             emitCodeArg IMPORT_FROM index+             let storeName = case from_as_name of+                    Nothing -> from_item_name+                    Just asName -> asName+             emitWriteVar $ ident_string storeName+         emitCodeNoArg POP_TOP+-- XXX should check that we are inside a loop+compileStmt (Break {}) = emitCodeNoArg BREAK_LOOP+compileStmt (Continue {}) = do+   maybeFrameBlockInfo <- peekFrameBlock+   case maybeFrameBlockInfo of+      Nothing -> error loopError+      Just (FrameBlockLoop label) -> emitCodeArg JUMP_ABSOLUTE label +      Just FrameBlockFinallyEnd ->+         error finallyError+      Just _other -> checkFrameBlocks+   where+   -- keep blocking the frame block stack until we either find+   -- a loop entry, otherwise generate an error+   checkFrameBlocks :: Compile ()+   checkFrameBlocks = do+      maybeFrameBlockInfo <- peekFrameBlock+      case maybeFrameBlockInfo of+         Nothing -> error loopError+         Just FrameBlockFinallyEnd -> error finallyError +         Just (FrameBlockLoop label) ->+            emitCodeArg CONTINUE_LOOP label+         Just _other -> checkFrameBlocks+   loopError = "'continue' not properly in loop"+   finallyError = "'continue' not supported inside 'finally' clause"+compileStmt (NonLocal {}) = return ()+compileStmt (Global {}) = return ()+compileStmt (Decorated {..}) =+   case decorated_def of+      Fun {} -> compileFun decorated_def decorated_decorators+      Class {} -> compileClass decorated_def decorated_decorators+      other -> error $ "Decorated statement is not a function or a class: " ++ prettyText other+compileStmt (Delete {..}) = mapM_ compileDelete del_exprs+compileStmt stmt@(With {..})+   -- desugar with statements containing multiple contexts into nested+   -- with statements containing single contexts+   | length with_context > 1 = compileWith $ desugarWith stmt +   | otherwise = compileWith stmt+compileStmt (Raise {..}) = compile raise_expr+compileStmt other = error $ "Unsupported statement:\n" ++ prettyText other++instance Compilable ExprSpan where+   type CompileResult ExprSpan = ()+   compile expr = +      setLineNumber (annot expr) >>+      compileExpr expr++compileExpr :: ExprSpan -> Compile ()+compileExpr (Var { var_ident = ident }) = do+   emitReadVar $ ident_string ident+compileExpr expr@(AST.Strings {}) =+   compileConstantEmit $ constantToPyObject expr +compileExpr expr@(AST.ByteStrings {}) =+   compileConstantEmit $ constantToPyObject expr +compileExpr expr@(AST.Int {}) =+   compileConstantEmit $ constantToPyObject expr+compileExpr expr@(AST.Float {}) =+   compileConstantEmit $ constantToPyObject expr+compileExpr expr@(AST.Imaginary {}) =+   compileConstantEmit $ constantToPyObject expr+compileExpr expr@(AST.Bool {}) =+   compileConstantEmit $ constantToPyObject expr+compileExpr expr@(AST.None {}) =+   compileConstantEmit $ constantToPyObject expr+compileExpr expr@(AST.Ellipsis {}) =+   compileConstantEmit $ constantToPyObject expr+compileExpr (AST.Paren {..}) = compile paren_expr+compileExpr (AST.CondExpr {..}) = do+   compile ce_condition+   falseLabel <- newLabel+   emitCodeArg POP_JUMP_IF_FALSE falseLabel+   compile ce_true_branch+   restLabel <- newLabel+   emitCodeArg JUMP_FORWARD restLabel+   labelNextInstruction falseLabel +   compile ce_false_branch+   labelNextInstruction restLabel+compileExpr expr@(AST.Tuple {..})+   | isPyObjectExpr expr =+        compileConstantEmit $ constantToPyObject expr+   | otherwise = do+        mapM_ compile tuple_exprs+        emitCodeArg BUILD_TUPLE $ fromIntegral $ length tuple_exprs+compileExpr (AST.List {..}) = do+   mapM_ compile list_exprs+   emitCodeArg BUILD_LIST $ fromIntegral $ length list_exprs+compileExpr (AST.Set {..}) = do+   mapM_ compile set_exprs+   emitCodeArg BUILD_SET $ fromIntegral $ length set_exprs+compileExpr (Dictionary {..}) = do+   emitCodeArg BUILD_MAP $ fromIntegral $ length dict_mappings+   forM_ dict_mappings $ \(key, value) -> do+      compile value+      compile key+      emitCodeNoArg STORE_MAP+compileExpr (ListComp {..}) = do+   let initStmt = [mkAssignVar resultName (mkList [])]+       updater = \expr -> mkStmtExpr $ mkMethodCall (mkVar $ resultName) "append" expr+       returnStmt = [mkReturn $ mkVar $ resultName]+   compileComprehension "<listcomp>" initStmt updater returnStmt list_comprehension+compileExpr (SetComp {..}) = do+   let initStmt = [mkAssignVar resultName (mkSet [])]+       updater = \expr -> mkStmtExpr $ mkMethodCall (mkVar $ resultName) "add" expr+       returnStmt = [mkReturn $ mkVar $ resultName]+   compileComprehension "<setcomp>" initStmt updater returnStmt set_comprehension+compileExpr (DictComp {..}) = do+   let initStmt = [mkAssignVar resultName (mkDict [])]+       updater = \(key, val) -> +          mkAssign (mkSubscript (mkVar $ resultName) key) val+       returnStmt = [mkReturn $ mkVar $ resultName]+   compileComprehension "<dictcomp>" initStmt updater returnStmt dict_comprehension+compileExpr (Generator {..}) = do+   let updater = \expr -> mkStmtExpr $ mkYield expr+   compileComprehension "<gencomp>" [] updater [] gen_comprehension+compileExpr (Yield { yield_expr = Nothing }) =+   compileConstantEmit Blip.None >> emitCodeNoArg YIELD_VALUE >> setFlag co_generator+compileExpr (Yield { yield_expr = Just expr }) =+   compile expr >> emitCodeNoArg YIELD_VALUE >> setFlag co_generator+compileExpr (Call {..}) = do+   compile call_fun+   compileCall 0 call_args+compileExpr (Subscript {..}) = do+   compile subscriptee+   compile subscript_expr+   emitCodeNoArg BINARY_SUBSCR+compileExpr (SlicedExpr {..}) = do+   compile slicee+   compileSlices slices+   emitCodeNoArg BINARY_SUBSCR+compileExpr exp@(BinaryOp {..})+   | isBoolean operator = compileBoolOpExpr exp+   | isComparison operator = compileCompareOpExpr exp+   | isDot operator = compileDot exp +   | otherwise = do +        compile left_op_arg+        compile right_op_arg+        compileOp operator +compileExpr (UnaryOp {..}) = do+   compile op_arg+   compileUnaryOp operator+compileExpr (Lambda {..}) = do+   funBodyObj <- nestedBlock FunctionContext expr_annot $ do+      -- make the first constant None, to indicate no doc string+      -- for the lambda+      _ <- compileConstant Blip.None+      compile lambda_body+      emitCodeNoArg RETURN_VALUE+      assemble+      makeObject+   numDefaults <- compileDefaultParams lambda_args+   compileClosure "<lambda>" funBodyObj numDefaults+compileExpr other = error $ "Unsupported expr:\n" ++ prettyText other++instance Compilable AssignOpSpan where+   type CompileResult AssignOpSpan = ()+   compile = emitCodeNoArg . assignOpCode++instance Compilable DecoratorSpan where+   type CompileResult DecoratorSpan = ()+   compile dec@(Decorator {..}) = do+      compileDottedName decorator_name+      let numDecorators = length decorator_args+      when (numDecorators > 0) $ +          compileCall 0 decorator_args+      where+      compileDottedName (name:rest) = do+         emitReadVar $ ident_string name+         forM_ rest $ \var -> do+            index <- lookupNameVar $ ident_string var+            emitCodeArg LOAD_ATTR index+      compileDottedName [] =+         error $ "decorator with no name: " ++ prettyText dec++instance Compilable ArgumentSpan where+   type CompileResult ArgumentSpan = ()+   compile (ArgExpr {..}) = compile arg_expr+   compile other = error $ "Unsupported argument:\n" ++ prettyText other++instance Compilable ImportItemSpan where+   type CompileResult ImportItemSpan = ()+   compile (ImportItem {..}) = do+      compileConstantEmit $ Blip.Int 0 -- this always seems to be zero+      compileConstantEmit Blip.None+      let dottedNames = map ident_string import_item_name+      -- assert (length dottedNames > 0)+      let dottedNameStr =+             concat $ intersperse "." dottedNames+      index <- lookupNameVar dottedNameStr+      emitCodeArg IMPORT_NAME index+      storeName <- +         case import_as_name of+            Nothing -> return $ head import_item_name+            Just asName -> do+               forM_ (tail dottedNames) $ \attribute -> do+                  index <- lookupNameVar attribute+                  emitCodeArg LOAD_ATTR index +               return asName+      emitWriteVar $ ident_string storeName++instance Compilable RaiseExprSpan where+   type CompileResult RaiseExprSpan = ()+   compile (RaiseV3 maybeRaiseArg) = do+      n <- case maybeRaiseArg of+              Nothing -> return 0+              Just (raiseExpr, maybeFrom) -> do+                 compile raiseExpr+                 case maybeFrom of+                    Nothing -> return 1+                    Just fromExpr -> do+                       compile fromExpr+                       return 2+      emitCodeArg RAISE_VARARGS n +   compile stmt@(RaiseV2 _) =+      error $ "Python version 2 raise statement encountered: " ++ prettyText stmt++{-+   From CPython compile.c++   Code generated for "try: S except E1 as V1: S1 except E2 as V2: S2 ...":+   (The contents of the value stack is shown in [], with the top+   at the right; 'tb' is trace-back info, 'val' the exception's+   associated value, and 'exc' the exception.)++   Value stack          Label   Instruction     Argument+   []                           SETUP_EXCEPT    L1+   []                           <code for S>+   []                           POP_BLOCK+   []                           JUMP_FORWARD    L0++   [tb, val, exc]       L1:     DUP                             )+   [tb, val, exc, exc]          <evaluate E1>                   )+   [tb, val, exc, exc, E1]      COMPARE_OP      EXC_MATCH       ) only if E1+   [tb, val, exc, 1-or-0]       POP_JUMP_IF_FALSE       L2      )+   [tb, val, exc]               POP+   [tb, val]                    <assign to V1>  (or POP if no V1)+   [tb]                         POP+   []                           <code for S1>+                                POP_EXCEPT+                                JUMP_FORWARD    L0++   [tb, val, exc]       L2:     DUP+   .............................etc.......................++   [tb, val, exc]       Ln+1:   END_FINALLY     # re-raise exception++   []                   L0:     <next statement>++   Of course, parts are not generated if Vi or Ei is not present.+-}++compileTry :: StatementSpan -> Compile ()+compileTry stmt@(Try {..})+   | length try_finally == 0 = compileTryExcept stmt+   | otherwise = compileTryFinally stmt+compileTry other =+   error $ "Unexpected statement when compiling a try-except: " ++ prettyText other ++compileTryFinally :: StatementSpan -> Compile ()+compileTryFinally stmt@(Try {..}) = do+   end <- newLabel+   emitCodeArg SETUP_FINALLY end+   body <- newLabel+   labelNextInstruction body+   withFrameBlock FrameBlockFinallyTry $ do+      if length try_excepts > 0+         then compileTryExcept stmt +         else mapM_ compile try_body+      emitCodeNoArg POP_BLOCK+   _ <- compileConstantEmit Blip.None+   labelNextInstruction end+   withFrameBlock FrameBlockFinallyEnd $ do+      mapM_ compile try_finally+      emitCodeNoArg END_FINALLY+compileTryFinally other =+   error $ "Unexpected statement when compiling a try-except: " ++ prettyText other ++compileTryExcept :: StatementSpan -> Compile ()+compileTryExcept (Try {..}) = do+   firstHandler <- newLabel                      -- L1+   emitCodeArg SETUP_EXCEPT firstHandler         -- pushes handler onto block stack+   withFrameBlock FrameBlockExcept $ do+      mapM_ compile try_body                     -- <code for S>+      emitCodeNoArg POP_BLOCK                    -- pops handler off block stack+   orElse <- newLabel+   emitCodeArg JUMP_FORWARD orElse +   end <- newLabel                               -- L0+   compileHandlers end firstHandler try_excepts+   labelNextInstruction orElse+   mapM_ compile try_else+   labelNextInstruction end                      -- L0: <next statement>+compileTryExcept other =+   error $ "Unexpected statement when compiling a try-except: " ++ prettyText other ++-- Compile a sequence of exception handlers+compileHandlers :: Word16 -> Word16 -> [HandlerSpan] -> Compile ()+compileHandlers _end handlerLabel [] = do+   labelNextInstruction handlerLabel             -- Ln+1, # re-raise exception+   emitCodeNoArg END_FINALLY+compileHandlers end handlerLabel (Handler {..} : rest) = do+   labelNextInstruction handlerLabel+   nextLabel <- newLabel +   compileHandlerClause nextLabel handler_clause+   emitCodeNoArg POP_TOP                         -- pop the traceback (tb) off the stack+   withFrameBlock FrameBlockFinallyTry $ do+      mapM_ compile handler_suite                   -- <code for S1, S2 ..>+      emitCodeNoArg POP_EXCEPT                      -- pop handler off the block stack+   emitCodeArg JUMP_FORWARD end+   compileHandlers end nextLabel rest ++-- enter here with stack == (s ++ [tb, val, exc]), leave with stack == s+compileHandlerClause :: Word16 -> ExceptClauseSpan -> Compile ()+compileHandlerClause nextHandler (ExceptClause {..}) = do+   case except_clause of+      Nothing -> do+         emitCodeNoArg POP_TOP                  -- pop exc off the stack+         emitCodeNoArg POP_TOP                  -- pop val off the stack+      Just (target, asExpr) -> do+         emitCodeNoArg DUP_TOP                  -- duplicate exc on stack+         compile target                         -- <evaluate E1>+         emitCodeArg COMPARE_OP exactMatchOp    -- compare E1 to exc+         emitCodeArg POP_JUMP_IF_FALSE nextHandler -- pop True/False and if no match try next handler+         emitCodeNoArg POP_TOP                  -- pop exc off the stack+         case asExpr of+            Nothing -> emitCodeNoArg POP_TOP    -- pop val off the stack+            -- XXX we should del this name at the end.+            Just expr -> compileAssignTo expr   -- assign the exception to the as name, will remove val from stack+   where+   -- The code for an exact match operator.+   exactMatchOp :: Word16+   exactMatchOp = 10++withDecorators :: [DecoratorSpan] -> Compile () -> Compile ()+withDecorators decorators comp = do+   -- push each of the decorators on the stack+   mapM_ compile decorators+   -- run the enclosed computation+   comp+   -- call each of the decorators+   replicateM_ (length decorators) $ +      emitCodeArg CALL_FUNCTION 1++nestedBlock :: Context -> SrcSpan -> Compile a -> Compile a+nestedBlock context span comp = do+   -- save the current block state+   oldBlockState <- getBlockState id+   -- set the new block state to initial values, and the+   -- scope of the current definition+   (name, localScope) <- getLocalScope $ spanToScopeIdentifier span +   setBlockState $ initBlockState context localScope+   -- set the new object name+   setObjectName name+   -- set the first line number of the block+   setFirstLineNumber span+   -- run the nested computation+   result <- comp+   -- restore the original block state+   setBlockState oldBlockState+   return result++-- Compile a function definition, possibly with decorators.+compileFun :: StatementSpan -> [DecoratorSpan] -> Compile ()+compileFun (Fun {..}) decorators = do+   let funName = ident_string $ fun_name+   withDecorators decorators $ do+      funBodyObj <- nestedBlock FunctionContext stmt_annot $ do+         compileFunDocString fun_body+         compile $ Body fun_body+      numDefaults <- compileDefaultParams fun_args+      compileClosure funName funBodyObj numDefaults+   emitWriteVar funName+compileFun other _decorators = error $ "compileFun applied to a non function: " ++ prettyText other++-- Compile a class definition, possibly with decorators.+compileClass :: StatementSpan -> [DecoratorSpan] -> Compile ()+compileClass (Class {..}) decorators = do+   let className = ident_string $ class_name+   withDecorators decorators $ do+      classBodyObj <- nestedBlock ClassContext stmt_annot $ do+         -- classes have a special argument called __locals__+         -- it is the only argument they have in the byte code, but it+         -- does not come from the source code, so we have to add it.+         setFastLocals ["__locals__"]+         setArgCount 1+         emitCodeArg LOAD_FAST 0+         emitCodeNoArg STORE_LOCALS+         emitReadVar "__name__"+         emitWriteVar "__module__"+         compileConstantEmit $ Unicode className+         emitWriteVar "__qualname__"+         compileClassModuleDocString class_body+         compile $ Body class_body+      emitCodeNoArg LOAD_BUILD_CLASS+      compileClosure className classBodyObj 0+      compileConstantEmit $ Unicode className+      compileCall 2 class_args+   emitWriteVar className+compileClass other _decorators = error $ "compileClass applied to a non class: " ++ prettyText other++-- XXX CPython uses a "qualified" name for the code object. For instance+-- nested functions look like "f.<locals>.g", whereas we currently use+-- just "g".++-- The free variables in a code object will either be cell variables+-- or free variables in the enclosing object. If there are no free+-- variables then we can avoid building the closure, and just make the function.+compileClosure :: String -> PyObject -> Word16 -> Compile ()+compileClosure name obj numDefaults = do+   -- get the list of free variables from the code object+   let Blip.Tuple freeVarStringObjs = freevars obj+       freeVarIdentifiers = map unicode freeVarStringObjs+       numFreeVars = length freeVarIdentifiers+   if numFreeVars == 0+      then do+         compileConstantEmit obj +         compileConstantEmit $ Unicode name+         emitCodeArg MAKE_FUNCTION numDefaults  +      else do+         forM_ freeVarIdentifiers $ \var -> do+            maybeVarInfo <- lookupClosureVar var+            -- we don't use emitReadVar because it would generate+            -- LOAD_DEREF instructions, but we want LOAD_CLOSURE+            -- instead.+            case maybeVarInfo of+               Just (CellVar index) -> emitCodeArg LOAD_CLOSURE index+               Just (FreeVar index) -> emitCodeArg LOAD_CLOSURE index+               _other -> error $ name ++ " closure free variable not cell or free var in outer context: " ++ var+         emitCodeArg BUILD_TUPLE $ fromIntegral numFreeVars+         compileConstantEmit obj +         compileConstantEmit $ Unicode name+         emitCodeArg MAKE_CLOSURE numDefaults++-- Compile default parameters and return how many there are+compileDefaultParams :: [ParameterSpan] -> Compile Word16+compileDefaultParams = foldM compileParam 0+   where+   compileParam :: Word16 -> ParameterSpan -> Compile Word16+   compileParam count (Param {..}) = do+      case param_default of+         Nothing -> return count+         Just expr -> do+            compile expr+            return $ count + 1+   compileParam count _other = return count++-- Compile a 'from module import'.+compileFromModule :: ImportRelativeSpan -> Compile ()+-- XXX what to do about the initial dots?+compileFromModule (ImportRelative {..}) = do+   let moduleName =+          case import_relative_module of+             Nothing -> ""+             Just dottedNames ->+                concat $ intersperse "." $ map ident_string dottedNames+   index <- lookupNameVar moduleName +   emitCodeArg IMPORT_NAME index++fromItemsIdentifiers :: FromItemsSpan -> [Identifier]+fromItemsIdentifiers (ImportEverything {}) = ["*"]+fromItemsIdentifiers (FromItems {..}) =+   map fromItemIdentifier from_items_items+   where+   fromItemIdentifier :: FromItemSpan -> Identifier+   fromItemIdentifier (FromItem {..}) = ident_string $ from_item_name++-- compile multiple possible assignments:+-- x = y = z = rhs+compileAssignments :: [ExprSpan] -> Compile ()+compileAssignments [] = return ()+compileAssignments [e] = compileAssignTo e+compileAssignments (e1:e2:rest) = do+   emitCodeNoArg DUP_TOP+   compileAssignTo e1+   compileAssignments (e2:rest)++-- the lhs of an assignment statement+-- we can assume that the parser has only accepted the appropriate+-- subset of expression types+compileAssignTo :: ExprSpan -> Compile ()+compileAssignTo (Var {..}) =+   emitWriteVar $ ident_string var_ident+compileAssignTo (Subscript {..}) = +   compile subscriptee >>+   compile subscript_expr >>+   emitCodeNoArg STORE_SUBSCR+-- XXX this can be optimised in places where the rhs is a+-- manifest list or tuple, avoiding the building list/tuple+-- only to deconstruct again+compileAssignTo (AST.Tuple {..}) = do+   emitCodeArg UNPACK_SEQUENCE $ fromIntegral $ length tuple_exprs+   mapM_ compileAssignTo tuple_exprs+compileAssignTo (AST.List {..}) = do+   emitCodeArg UNPACK_SEQUENCE $ fromIntegral $ length list_exprs+   mapM_ compileAssignTo list_exprs+compileAssignTo (AST.Paren {..}) = compileAssignTo paren_expr+compileAssignTo expr@(BinaryOp { operator = Dot {}, right_op_arg = Var {..}}) = do+   compile $ left_op_arg expr+   index <- lookupNameVar $ ident_string $ var_ident+   emitCodeArg STORE_ATTR index+compileAssignTo (SlicedExpr {..}) = do+   compile slicee+   compileSlices slices+   emitCodeNoArg STORE_SUBSCR  +compileAssignTo other = error $ "assignment to unexpected expression:\n" ++ prettyText other++compileDelete :: ExprSpan -> Compile ()+compileDelete (Var {..}) = do+   emitDeleteVar $ ident_string var_ident+compileDelete (Subscript {..}) =+   compile subscriptee >>+   compile subscript_expr >>+   emitCodeNoArg DELETE_SUBSCR+compileDelete (AST.Paren {..}) = compileDelete paren_expr+compileDelete (expr@(BinaryOp { operator = Dot {}, right_op_arg = Var {..}})) = do+   compile $ left_op_arg expr+   index <- lookupNameVar $ ident_string $ var_ident+   emitCodeArg DELETE_ATTR index+compileDelete (SlicedExpr {..}) = do+   compile slicee+   compileSlices slices+   emitCodeNoArg DELETE_SUBSCR  +compileDelete other = error $ "delete of unexpected expression:\n" ++ prettyText other++compileWith :: StatementSpan -> Compile ()+compileWith stmt@(With {..}) = +   case with_context of+      [(context, maybeAs)] -> do+         blockLabel <- newLabel+         finallyLabel <- newLabel+         compile context+         emitCodeArg SETUP_WITH finallyLabel+         labelNextInstruction blockLabel+         withFrameBlock FrameBlockFinallyTry $ do+            case maybeAs of+               -- Discard result from context.__enter__()+               Nothing -> emitCodeNoArg POP_TOP+               Just expr -> compileAssignTo expr+            mapM_ compile with_body+            emitCodeNoArg POP_BLOCK+         _ <- compileConstantEmit Blip.None+         labelNextInstruction finallyLabel+         withFrameBlock FrameBlockFinallyEnd $ do+            emitCodeNoArg WITH_CLEANUP+            emitCodeNoArg END_FINALLY+      _other -> error $ "compileWith applied to non desugared with statement: " ++ prettyText stmt +compileWith other = error $ "compileWith applied to non with statement: " ++ prettyText other++-- Check for a docstring in the first statement of a function body.+-- The first constant in the corresponding code object is inspected+-- by the interpreter for the docstring. If there is no docstring+-- then the first constant must be None+compileFunDocString :: [StatementSpan] -> Compile ()+compileFunDocString (firstStmt:_stmts)+   | StmtExpr {..} <- firstStmt,+     Strings {} <- stmt_expr+        = compileConstant (constantToPyObject stmt_expr) >> return ()+   | otherwise = compileConstant Blip.None >> return ()+compileFunDocString [] = compileConstant Blip.None >> return ()++compileClassModuleDocString :: [StatementSpan] -> Compile ()+compileClassModuleDocString (firstStmt:_stmts)+   | StmtExpr {..} <- firstStmt,+     Strings {} <- stmt_expr+        -- XXX what if another __doc__ is in scope?+        = do compileConstantEmit $ constantToPyObject stmt_expr+             emitWriteVar "__doc__"+   | otherwise = return ()+compileClassModuleDocString [] = return ()++-- Compile a conditional guard+compileGuard :: Word16 -> (ExprSpan, [StatementSpan]) -> Compile ()+compileGuard restLabel (expr, stmts) = do+   compile expr+   falseLabel <- newLabel+   emitCodeArg POP_JUMP_IF_FALSE falseLabel+   mapM_ compile stmts+   emitCodeArg JUMP_FORWARD restLabel+   labelNextInstruction falseLabel ++-- Desugar the comprehension into a zero-arity function (body) with+-- a (possibly nested) for loop, then call the function.+compileComprehension+   :: Identifier +   -> [StatementSpan]+   -> (a -> StatementSpan) +   -> [StatementSpan]+   -> ComprehensionSpan a+   -> Compile ()+compileComprehension name initStmt updater returnStmt comprehension = do+   let desugaredComp = desugarComprehension initStmt updater returnStmt comprehension +       comprehensionSpan = comprehension_annot comprehension+   funObj <- nestedBlock+                FunctionContext+                comprehensionSpan +                (compile $ Body desugaredComp)+   compileClosure name funObj 0+   (_name, localScope) <- getLocalScope $ spanToScopeIdentifier comprehensionSpan+   let parameterNames = parameterTypes_pos $ localScope_params localScope +   mapM_ emitReadVar parameterNames+   emitCodeArg CALL_FUNCTION $ fromIntegral $ length parameterNames++-- Convert a constant expression into the equivalent object. This+-- only works for expressions which have a counterpart in the object+-- representation used in .pyc files.+constantToPyObject :: ExprSpan -> PyObject+constantToPyObject (AST.Int {..})+   | int_value > (fromIntegral max32BitSignedInt) ||+     int_value < (fromIntegral min32BitSignedInt)+      =  Blip.Long int_value+   | otherwise = Blip.Int $ fromIntegral int_value+   where+   max32BitSignedInt :: Int32+   max32BitSignedInt = maxBound +   min32BitSignedInt :: Int32+   min32BitSignedInt = minBound +constantToPyObject (AST.Float {..}) = Blip.Float $ float_value +-- XXX we could optimise the case where we have 'float + imaginary j',+-- to generate a Complex number directly, rather than by doing+-- the addition operation.+constantToPyObject (AST.Imaginary {..}) =+   Blip.Complex { real = 0.0, imaginary = imaginary_value }+constantToPyObject (AST.Bool { bool_value = True }) = Blip.TrueObj+constantToPyObject (AST.Bool { bool_value = False }) = Blip.FalseObj+constantToPyObject (AST.None {}) = Blip.None+constantToPyObject (AST.Ellipsis {}) = Blip.Ellipsis+-- assumes all the tuple elements are constant+constantToPyObject (AST.Tuple {..}) =+   Blip.Tuple { elements = map constantToPyObject tuple_exprs }+constantToPyObject (AST.Strings {..}) =+   Blip.Unicode { unicode = concat $ map normaliseString strings_strings }+constantToPyObject (AST.ByteStrings {..}) =+  -- error $ show $ map normaliseString byte_string_strings+  Blip.String { string = fromString $ concat $ map normaliseString byte_string_strings }+constantToPyObject other =+   error $ "constantToPyObject applied to an unexpected expression: " ++ prettyText other++-- The strings in the AST retain their original quote marks which+-- need to be removed, we have to remove single or triple quotes.+-- We assume the parser has correctly matched the quotes.+-- Escaped characters such as \n \t are parsed as multiple characters+-- and need to be converted back into single characters.+normaliseString :: String -> String+normaliseString ('r':'b':rest) = removeQuotes rest+normaliseString ('b':'r':rest) = removeQuotes rest+normaliseString ('b':rest) = unescapeString $ removeQuotes rest+normaliseString ('r':rest) = removeQuotes rest+normaliseString other = unescapeString $ removeQuotes other ++removeQuotes :: String -> String+removeQuotes ('\'':'\'':'\'':rest) = take (length rest - 3) rest+removeQuotes ('"':'"':'"':rest) = take (length rest - 3) rest+removeQuotes ('\'':rest) = init rest+removeQuotes ('"':rest) = init rest+removeQuotes other = error $ "bad literal string: " ++ other++data CallArgs =+   CallArgs+   { callArgs_pos :: !Word16+   , callArgs_keyword :: !Word16+   , callArgs_varPos :: !Bool+   , callArgs_varKeyword :: !Bool+   }++initCallArgs :: CallArgs+initCallArgs =+   CallArgs+   { callArgs_pos = 0+   , callArgs_keyword = 0+   , callArgs_varPos = False+   , callArgs_varKeyword = False+   }++-- Compile the arguments to a call and+-- decide which particular CALL_FUNCTION bytecode to emit.+-- numExtraArgs counts any additional arguments the function+-- might have been applied to, which is necessary for classes+-- which get extra arguments beyond the ones mentioned in the+-- program source.+compileCall :: Word16 -> [ArgumentSpan] -> Compile ()+compileCall numExtraArgs args = do+   CallArgs {..} <- compileCallArgs args +   let opArg = (callArgs_pos + numExtraArgs) .|. callArgs_keyword `shiftL` 8+   case (callArgs_varPos, callArgs_varKeyword) of+      (False, False) -> emitCodeArg CALL_FUNCTION opArg +      (True, False) -> emitCodeArg CALL_FUNCTION_VAR opArg +      (False, True) -> emitCodeArg CALL_FUNCTION_KW opArg +      (True, True) -> emitCodeArg CALL_FUNCTION_VAR_KW opArg ++-- Compile the arguments to a function call and return the number+-- of positional arguments, and the number of keyword arguments.+compileCallArgs :: [ArgumentSpan] -> Compile CallArgs+compileCallArgs = foldM compileArg initCallArgs +   where+   compileArg :: CallArgs  -> ArgumentSpan -> Compile CallArgs +   compileArg callArgs@(CallArgs {..}) (ArgExpr {..}) = do+      compile arg_expr+      return $ callArgs { callArgs_pos = callArgs_pos + 1 }+   compileArg callArgs@(CallArgs {..}) (ArgKeyword {..}) = do+      compileConstantEmit $ Unicode $ ident_string arg_keyword+      compile arg_expr+      return $ callArgs { callArgs_keyword = callArgs_keyword + 1 }+   compileArg callArgs@(CallArgs {..}) (ArgVarArgsPos {..}) = do+      compile arg_expr+      return $ callArgs { callArgs_varPos = True }+   compileArg callArgs@(CallArgs {..}) (ArgVarArgsKeyword {..}) = do+      compile arg_expr+      return $ callArgs { callArgs_varKeyword = True }++-- XXX need to handle extended slices, slice expressions and ellipsis+compileSlices :: [SliceSpan] -> Compile ()+compileSlices [SliceProper {..}] = do+   case slice_lower of+      Nothing -> compileConstantEmit Blip.None+      Just expr -> compile expr+   case slice_upper of+      Nothing -> compileConstantEmit Blip.None+      Just expr -> compile expr+   case slice_stride of+      Nothing -> emitCodeArg BUILD_SLICE 2+      -- Not sure about this, maybe it is None+      Just Nothing -> emitCodeArg BUILD_SLICE 2+      Just (Just expr) -> do+         compile expr+         emitCodeArg BUILD_SLICE 3+compileSlices other = error $ "unsupported slice: " ++ show other++-- Return the opcode for a given assignment operator.+assignOpCode :: AssignOpSpan -> Opcode+assignOpCode assign = +   case assign of+      PlusAssign {} -> INPLACE_ADD+      MinusAssign {} -> INPLACE_SUBTRACT+      MultAssign {} -> INPLACE_MULTIPLY+      DivAssign {} -> INPLACE_TRUE_DIVIDE+      ModAssign {} -> INPLACE_MODULO+      PowAssign {} -> INPLACE_POWER+      BinAndAssign {} -> INPLACE_AND+      BinOrAssign {} -> INPLACE_OR+      BinXorAssign {} -> INPLACE_XOR+      LeftShiftAssign {} -> INPLACE_LSHIFT+      RightShiftAssign {} -> INPLACE_RSHIFT+      FloorDivAssign {} -> INPLACE_FLOOR_DIVIDE++isDot :: OpSpan -> Bool+isDot (Dot {}) = True+isDot _other = False++isBoolean :: OpSpan -> Bool+isBoolean (And {}) = True+isBoolean (Or {}) = True+isBoolean _other = False++isComparison :: OpSpan -> Bool+isComparison (LessThan {}) = True+isComparison (GreaterThan {}) = True+isComparison (Equality {}) = True+isComparison (GreaterThanEquals {}) = True+isComparison (LessThanEquals {}) = True+isComparison (NotEquals  {}) = True+isComparison (In {}) = True+isComparison (NotIn {}) = True+isComparison (IsNot {}) = True+isComparison (Is {}) = True+isComparison _other = False++compileDot :: ExprSpan -> Compile ()+compileDot (BinaryOp {..}) = do+   compile left_op_arg+   case right_op_arg of+      Var {..} -> do+         -- the right argument should be treated like name variable+         varInfo <- lookupNameVar $ ident_string var_ident+         emitCodeArg LOAD_ATTR varInfo +      other -> error $ "right argument of dot operator not a variable:\n" ++ prettyText other+compileDot other =+   error $ "compileDot applied to an unexpected expression: " ++ prettyText other++compileBoolOpExpr :: ExprSpan -> Compile ()+compileBoolOpExpr (BinaryOp {..}) = do+   endLabel <- newLabel+   compile left_op_arg+   case operator of+      And {..} -> emitCodeArg JUMP_IF_FALSE_OR_POP endLabel+      Or {..} ->  emitCodeArg JUMP_IF_TRUE_OR_POP endLabel+      other -> error $ "Unexpected boolean operator:\n" ++ prettyText other+   compile right_op_arg+   labelNextInstruction endLabel+compileBoolOpExpr other =+   error $ "compileBoolOpExpr applied to an unexpected expression: " ++ prettyText other++compileOp :: OpSpan -> Compile ()+compileOp operator =+   emitCodeNoArg $ case operator of+      BinaryOr {} -> BINARY_OR+      Xor {} -> BINARY_XOR+      BinaryAnd {} -> BINARY_AND+      ShiftLeft {} -> BINARY_LSHIFT+      ShiftRight {} -> BINARY_RSHIFT+      Exponent {} -> BINARY_POWER+      Multiply {} -> BINARY_MULTIPLY+      Plus {} -> BINARY_ADD+      Minus {} -> BINARY_SUBTRACT+      Divide {} -> BINARY_TRUE_DIVIDE+      FloorDivide {} -> BINARY_FLOOR_DIVIDE+      Modulo {} -> BINARY_MODULO+      _other -> error $ "Unexpected operator:\n" ++ prettyText operator++compileUnaryOp :: OpSpan -> Compile ()+compileUnaryOp operator =+   emitCodeNoArg $ case operator of+      Minus {} -> UNARY_NEGATIVE+      Plus {} -> UNARY_POSITIVE+      Not {} -> UNARY_NOT+      Invert {} -> UNARY_INVERT+      other ->  error $ "Unexpected unary operator: " ++ prettyText other++{-+from object.h++#define Py_LT 0+#define Py_LE 1+#define Py_EQ 2+#define Py_NE 3+#define Py_GT 4+#define Py_GE 5++and from opcode.h ++enum cmp_op {PyCmp_LT=Py_LT, PyCmp_LE=Py_LE, PyCmp_EQ=Py_EQ, PyCmp_NE=Py_NE, PyCmp_GT=Py_GT, PyCmp_GE=Py_GE,+             PyCmp_IN, PyCmp_NOT_IN, PyCmp_IS, PyCmp_IS_NOT, PyCmp_EXC_MATCH, PyCmp_BAD};+-}++{- Operator chaining:++   The parser treats comparison operators as left associative.++   So: w < x < y < z is parsed as++   (((w < x) < y) < z)++   We want to compile this to:++         [w]+         [x]+         DUP_TOP   # make a copy of the result of x+         ROT_THREE # put the copy of [x] to the bottom+         <+         JUMP_IF_FALSE_OR_POP cleanup+         [y]+         DUP_TOP   # make a copy of [y]+         ROT_THREE # put the copy of [y] to the bottom+         <+         JUMP_IF_FALSE_OR_POP cleanup+         [z]+         <+         JUMP_FORWARD end+   cleanup:+         ROT_TWO  # put the result of the last comparison on the bottom +                  # and put the duplicated [y] on the top+         POP_TOP  # remove the duplicated [y] from the top+   end:+         # whatever code follows+-}++compileCompareOpExpr :: ExprSpan -> Compile ()+compileCompareOpExpr expr@(BinaryOp {}) =+   compileChain numOps chain+   where+   chain :: [ChainItem]+   chain = flattenComparisonChain [] expr+   numOps :: Int+   numOps = length chain `div` 2++   compileChain :: Int -> [ChainItem] -> Compile ()+   compileChain numOps (Comparator e1 : internal@(Operator op : Comparator e2 : _rest)) = do+      compile e1+      if numOps == 1+         then do+            compile e2+            emitCodeArg COMPARE_OP $ comparisonOpCode op+         else do+            cleanup <- newLabel+            (lastOp, lastArg) <- compileChainInternal cleanup internal +            compile lastArg+            emitCodeArg COMPARE_OP $ comparisonOpCode lastOp+            end <- newLabel+            emitCodeArg JUMP_FORWARD end+            labelNextInstruction cleanup+            emitCodeNoArg ROT_TWO+            emitCodeNoArg POP_TOP+            labelNextInstruction end+   compileChain _numOps _items = error $ "bad operator chain: " ++ prettyText expr+   compileChainInternal :: Word16 -> [ChainItem] -> Compile (OpSpan, ExprSpan)+   compileChainInternal _cleanup [Operator op, Comparator exp] = return (op, exp)+   compileChainInternal cleanup (Operator op : Comparator e : rest) = do+      compile e+      emitCodeNoArg DUP_TOP+      emitCodeNoArg ROT_THREE+      emitCodeArg COMPARE_OP $ comparisonOpCode op+      emitCodeArg JUMP_IF_FALSE_OR_POP cleanup+      compileChainInternal cleanup rest+   compileChainInternal _cleanup _other = error $ "bad comparison chain: " ++ prettyText expr +        +   comparisonOpCode :: OpSpan -> Word16+   comparisonOpCode (LessThan {}) = 0 +   comparisonOpCode (LessThanEquals {}) = 1+   comparisonOpCode (Equality {}) = 2 +   comparisonOpCode (NotEquals {}) = 3 +   comparisonOpCode (GreaterThan {}) = 4 +   comparisonOpCode (GreaterThanEquals {}) = 5 +   comparisonOpCode (In {}) = 6+   comparisonOpCode (NotIn {}) = 7+   comparisonOpCode (Is {}) = 8+   comparisonOpCode (IsNot {}) = 9+   -- XXX we don't appear to have an exact match operator in the AST+   comparisonOpCode operator = error $ "Unexpected comparison operator:\n" ++ prettyText operator+compileCompareOpExpr other = error $ "Unexpected comparison operator:\n" ++ prettyText other ++data ChainItem = Comparator ExprSpan | Operator OpSpan++flattenComparisonChain :: [ChainItem] -> ExprSpan -> [ChainItem] +flattenComparisonChain acc opExpr@(BinaryOp {..}) +   | isComparison operator+        = flattenComparisonChain newAcc left_op_arg+   | otherwise = [Comparator opExpr] ++ acc +   where+   newAcc = [Operator operator, Comparator right_op_arg] ++ acc+flattenComparisonChain acc other = [Comparator other] ++ acc+ +-- Emit an instruction that returns the None contant.+returnNone :: Compile ()+returnNone = compileConstantEmit Blip.None >> emitCodeNoArg RETURN_VALUE++-- Print out the variable scope of the module if requested on the command line.+maybeDumpScope :: Compile ()+maybeDumpScope = +   ifDump DumpScope $ do+      nestedScope <- getNestedScope+      liftIO $ putStrLn $ renderScope nestedScope++-- Print out the AST of the module if requested on the command line.+maybeDumpAST :: ModuleSpan -> Compile ()+maybeDumpAST ast = do+   ifDump DumpAST $ do+      liftIO $ putStrLn "Abstract Syntax Tree:"+      liftIO $ putStrLn $ show ast++{- +   From Cpython: Objects/lnotab_notes.txt++Code objects store a field named co_lnotab.  This is an array of unsigned bytes+disguised as a Python string. It is used to map bytecode offsets to source code+line #s for tracebacks and to identify line number boundaries for line tracing.++The array is conceptually a compressed list of+    (bytecode offset increment, line number increment)+pairs.  The details are important and delicate, best illustrated by example:++    byte code offset    source code line number+        0                   1+        6                   2+       50                   7+      350                 307+      361                 308++Instead of storing these numbers literally, we compress the list by storing only+the increments from one row to the next.  Conceptually, the stored list might+look like:++    0, 1,  6, 1,  44, 5,  300, 300,  11, 1++The above doesn't really work, but it's a start. Note that an unsigned byte+can't hold negative values, or values larger than 255, and the above example+contains two such values. So we make two tweaks:  +++ (a) there's a deep assumption that byte code offsets and their corresponding+ line #s both increase monotonically, and+ (b) if at least one column jumps by more than 255 from one row to the next,+ more than one pair is written to the table. In case #b, there's no way to know+ from looking at the table later how many were written.  That's the delicate+ part.  A user of co_lnotab desiring to find the source line number+ corresponding to a bytecode address A should do something like this++    lineno = addr = 0+    for addr_incr, line_incr in co_lnotab:+        addr += addr_incr+        if addr > A:+            return lineno+        lineno += line_incr++(In C, this is implemented by PyCode_Addr2Line().)  In order for this to work,+when the addr field increments by more than 255, the line # increment in each+pair generated must be 0 until the remaining addr increment is < 256.  So, in+the example above, assemble_lnotab in compile.c should not (as was actually done+until 2.2) expand 300, 300 to+    255, 255, 45, 45,+but to+    255, 0, 45, 255, 0, 45.+-}++-- Returns the bytestring representation of the compressed line number table+compileLineNumberTable :: Word32 -> Compile PyObject+compileLineNumberTable firstLineNumber = do+   offsetToLine <- reverse `fmap` getBlockState state_lineNumberTable+   let compressedTable = compress (0, firstLineNumber) offsetToLine +       bs = B.pack $ concat +               [ [fromIntegral offset, fromIntegral line] | +                    (offset, line) <- compressedTable ]+   return Blip.String { string = bs }+   where+   compress :: (Word16, Word32) -> [(Word16, Word32)] -> [(Word16, Word32)]+   compress _prev [] = []+   compress (prevOffset, prevLine) (next@(nextOffset, nextLine):rest)+      -- make sure all increments are non-negative+      -- skipping any entries which are less than the predecessor+      | nextLine < prevLine || nextOffset < prevOffset =+           compress (prevOffset, prevLine) rest+      | otherwise = chunkDeltas (offsetDelta, lineDelta) ++ compress next rest+      where +      offsetDelta = nextOffset - prevOffset+      lineDelta = nextLine - prevLine++-- both offsetDelta and lineDelta must be non-negative+chunkDeltas :: (Word16, Word32) -> [(Word16, Word32)]+chunkDeltas (offsetDelta, lineDelta)+   | offsetDelta < 256 =+      if lineDelta < 256+         then [(offsetDelta, lineDelta)]+         else (offsetDelta, 255) : chunkDeltas (0, lineDelta - 255)+   -- we must wait until offsetDelta is less than 256 before reducing lineDelta+   | otherwise = (255, 0) : chunkDeltas (offsetDelta - 255, lineDelta)

@@ -0,0 +1,159 @@+{-# LANGUAGE RecordWildCards #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Desugar +-- Copyright   : (c) 2013 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Desugar Python syntax.+--+-- For example, comprehensions are dsugared into functions with for loops+-- in their bodies.+-- +-- 'with' statements containing multiple context managers are turned into+-- nested 'with' statements with a single context manager each.+--+-----------------------------------------------------------------------------++module Desugar (desugarComprehension, resultName, desugarWith) where++import Prelude hiding (mapM)+import Utils (mkIdent)+import Language.Python.Common.AST as AST+   ( StatementSpan, Statement (..), ExprSpan, Comprehension (..)+   , ComprehensionSpan, CompFor (..), CompForSpan, CompIf (..), CompIfSpan+   , CompIter (..), CompIterSpan, IdentSpan ) +import Language.Python.Common.SrcLocation (SrcSpan (..))+import Language.Python.Common (prettyText)++{-++Desugaring of comprehensions.++Comprehensions are desugared into functions containing for loops.+We use a function because the local variables for a for loop are not+in scope outside the loop (unlike Python's actual for loops). Putting+the loop inside the function gives us the desired scope behaviour.++For example:++    [ x + 1 for x in y if x > 2 ]++becomes:++    def f():+        $result = []+        for x in y:+            if x > 2:+                $result.append(x)+        return $result+    f()++In practice we don't need to generate a name for our function, because+we can just make a function byte code object and then call it directly.++A problem with the above scheme occurs when we have list comprehensions+in the body of a class, which refer to other variables local to the class:++    class C():+        a = [1,2,3]+        b = [ x + 1 for x in a ]++The "obvious" way to desugar that is:++    class C():+        a = [1,2,3]+        def f():+            $result = []+            for x in a:+                $result.append(x)+            return $result+        b = f()++The problem is that the variable 'a' is free in the definition of f.+The scope rules of classes do not allow 'a' to be in scope inside+functions defined in the class (this is different than normal+nested functions). We'd have to refer to the variable as 'C.a'.++We could use the class name to qualify the scope of such free variables.+But another, perhaps simpler way is to provide them as arguments to +the new function:++    class C():+        a = [1,2,3]+        def f(a):+            $result = []+            for x in a:+                $result.append(x)+            return $result+        b = f(a)++-}++-- Special free variable which cannot appear in the source of the program+-- and is guaranteed to be unique in the comprehension.+-- Nested comprehensions get desugared into nested functions so there+-- is no danger of a name clash.+resultName :: IdentSpan +resultName = mkIdent "$result"++desugarComprehension+   :: [StatementSpan]      -- Initialiser of the stmt (e.g. $result = [])+   -> (a -> StatementSpan) -- Update the accumulator (e.g. $result.append(x)) +   -> [StatementSpan]      -- Return the accumulator (e.g. return $result)+   -> ComprehensionSpan a  -- Comprehension to desugar+   -> [StatementSpan]      -- Body of the desugared function+desugarComprehension initStmt updater returnStmt (Comprehension {..}) =+   initStmt ++ [forLoop] ++ returnStmt+   where+   updateStmt = updater comprehension_expr+   forLoop = desugarCompFor updateStmt comprehension_for++desugarCompFor :: StatementSpan -> CompForSpan -> StatementSpan+desugarCompFor updateStmt (CompFor {..}) =+   For { for_targets = comp_for_exprs+       , for_generator = comp_in_expr+       , for_body = [forBody]+       , for_else = []+       , stmt_annot = SpanEmpty }+   where+   forBody :: StatementSpan+   forBody = case comp_for_iter of+                Nothing -> updateStmt+                Just iter -> desugarCompIter updateStmt iter ++desugarCompIter :: StatementSpan -> CompIterSpan -> StatementSpan+desugarCompIter updateStmt (IterFor {..}) =+   desugarCompFor updateStmt comp_iter_for+desugarCompIter updateStmt (IterIf {..}) =+   desugarCompIf updateStmt comp_iter_if++desugarCompIf :: StatementSpan -> CompIfSpan -> StatementSpan+desugarCompIf updateStmt (CompIf {..}) =+   Conditional { cond_guards = guards+               , cond_else = []+               , stmt_annot = SpanEmpty }+   where+   guards :: [(ExprSpan, [StatementSpan])]+   guards = [(comp_if, [conditionBody])]+   conditionBody =+      case comp_if_iter of+         Nothing -> updateStmt+         Just iter -> desugarCompIter updateStmt iter++desugarWith :: StatementSpan -> StatementSpan+desugarWith stmt@(With {..}) =+   case with_context of+      [] -> error $ "with containing no context manager: " ++ prettyText stmt+      [_] -> stmt+      (context1:context2:rest) ->+         With { with_context = [context1]+              , with_body =+                   [ desugarWith $ With { with_context = context2:rest+                                        , with_body = with_body+                                        , stmt_annot = stmt_annot } ]+              , stmt_annot = stmt_annot }+desugarWith other = error $ "desigarWith applied to non with statement: " ++ prettyText other

@@ -0,0 +1,31 @@+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Monad+-- Copyright   : (c) 2012, 2013 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Custom monad support for the compiler.+--+-----------------------------------------------------------------------------++module Monad (Compile (..), runCompileMonad)  where++import Types (CompileState (..))+import Control.Monad.State.Strict as State hiding (State)+-- import Control.Monad.State.Class (MonadState (..))+import Control.Applicative (Applicative (..))++newtype Compile a+   = Compile (StateT CompileState IO a)+   deriving (Monad, Functor, MonadIO, Applicative)++instance MonadState CompileState Compile where+   get = Compile get+   put s = Compile $ put s++runCompileMonad :: Compile a -> CompileState -> IO a+runCompileMonad (Compile comp) = evalStateT comp

@@ -0,0 +1,18 @@+-----------------------------------------------------------------------------+-- |+-- Module      : ProgName+-- Copyright   : (c) 2012, 2013 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Define the name of the compiler program, for consistent use in the rest+-- of the code, such as error messages.+--+-----------------------------------------------------------------------------++module ProgName (progName) where++progName :: String+progName = "blip"

@@ -0,0 +1,517 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RecordWildCards, PatternGuards, ExistentialQuantification #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Scope+-- Copyright   : (c) 2012, 2013 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- A variable can be:+--    explicit global+--    implicit global+--    local+--    free+--    cellvar +--+-- Global variables are either:+--    - defined (assigned) at the top level of a module+--    OR+--    - declared global in a nested scope+--+-- Local variables are (with respect to the current scope) either:+--    - Assigned in the current local scope AND not declared global or non-local.+--    OR+--    - Parameters to a function definition.+--+-- Free variables are (with respect to the current scope):+--    - Local to an enclosing scope AND either:+--        - Declared non-local in the current scope.+--        OR+--        - Read from but not assigned-to in the current local scope. +--+-- Cellvars are:+--    - Local to the current scope.+--    AND+--    - Free variables of a scope which is nested from the current scope.+--+-- Cellvars are used to implement closures such that modifications to the+-- variable binding itself are visible in the closure. They are implemented+-- as a pointer to a heap allocated cell, which itself points to a Python+-- object. The extra level of indirection allows the cell to be updated to+-- point to something else.+-- +-----------------------------------------------------------------------------++module Scope+   (topScope, renderScope)+   where++import Types+   ( Identifier, VarSet, LocalScope (..)+   , NestedScope (..), ScopeIdentifier, ParameterTypes (..) )+import Data.Set as Set+   ( empty, singleton, fromList, union, difference+   , intersection, toList, size )+import Data.Map as Map (empty, insert, toList, union)+import Data.List (foldl', intersperse)+import Language.Python.Common.AST as AST+   ( Statement (..), StatementSpan, Ident (..), Expr (..), ExprSpan+   , Argument (..), ArgumentSpan, RaiseExpr (..), RaiseExprSpan+   , Slice (..), SliceSpan, ModuleSpan, Module (..), ParameterSpan+   , Parameter (..), Op (..), Comprehension (..), ComprehensionSpan+   , CompIter (..), CompIterSpan, CompFor (..), CompForSpan, CompIf (..)+   , CompIfSpan, Handler (..), HandlerSpan, ExceptClause (..), ExceptClauseSpan  )+import Data.Monoid (Monoid (..))+import Control.Monad (mapAndUnzipM)+import Control.Monad.Reader (ReaderT, local, ask, runReaderT)+import Text.PrettyPrint.HughesPJ as Pretty+   ( Doc, ($$), nest, text, vcat, hsep, ($+$), (<+>), empty+   , render, parens, comma, int, hcat )+import Blip.Pretty (Pretty (..))+import State (emptyVarSet, emptyParameterTypes)+import Utils ( identsFromParameters, spanToScopeIdentifier+             , fromIdentString, maybeToList )++type ScopeM a = ReaderT VarSet IO a++instance Pretty ScopeIdentifier where+   pretty (row1, col1, row2, col2) =+      parens $ hcat $ intersperse comma $ map int [row1, col1, row2, col2]++instance Pretty NestedScope where+   pretty (NestedScope scope) =+      vcat $ map prettyLocalScope identsScopes+      where+      identsScopes = Map.toList scope+      prettyLocalScope :: (ScopeIdentifier, (String, LocalScope)) -> Doc+      prettyLocalScope (span, (identifier, defScope)) =+         text identifier <+> pretty span <+> text "->" $$ +         nest 5 (pretty defScope)++instance Pretty LocalScope where+   pretty (LocalScope {..}) =+      text "params:" <+> (nest 5 $ pretty localScope_params) $$+      prettyVarSet "locals:" localScope_locals $$+      prettyVarSet "freevars:" localScope_freeVars $$+      prettyVarSet "cellvars:" localScope_cellVars $$+      prettyVarSet "globals:" localScope_explicitGlobals++instance Pretty ParameterTypes where+   pretty (ParameterTypes {..}) =+      prettyVarList "positional:" parameterTypes_pos $$+      prettyVarList "varArgPos:" (maybeToList parameterTypes_varPos) $$+      prettyVarList "varArgKeyword:" (maybeToList parameterTypes_varKeyword)++prettyVarList :: String -> [Identifier] -> Doc+prettyVarList label list +   | length list == 0 = Pretty.empty+   | otherwise =+        text label <+> (hsep $ map text list)++prettyVarSet :: String -> VarSet -> Doc+prettyVarSet label varSet+   | Set.size varSet == 0 = Pretty.empty+   | otherwise =+        text label <+>+        (hsep $ map text $ Set.toList varSet)++renderScope :: NestedScope -> String+renderScope = render . prettyScope++prettyScope :: NestedScope -> Doc+prettyScope nestedScope =+   text "nested scope:" $+$+      (nest 5 $ pretty nestedScope)++-- class, function, lambda, or comprehension+data Definition+   = DefStmt StatementSpan -- class, or def+   | DefLambda ExprSpan -- lambda+   | forall e . VarUsage e => DefComprehension (ComprehensionSpan e) -- comprehension++data Usage =+   Usage+   { usage_assigned :: !VarSet     -- variables assigned to (written to) in this scope+   , usage_nonlocals :: !VarSet    -- variables declared nonlocal in this scope+   , usage_globals :: !VarSet      -- variables declared global in this scope+   , usage_referenced :: !VarSet   -- variables referred to (read from) in this scope+   , usage_definitions :: ![Definition] -- locally defined lambdas, classes, functions, comprehensions+   }++emptyNestedScope :: NestedScope+emptyNestedScope = NestedScope Map.empty++-- returns the 'local' scope of the top-level of the module and+-- the nested scope of the module (anything not at the top level)+topScope :: ModuleSpan -> IO (LocalScope, NestedScope)+topScope (Module suite) = do+   -- XXX should check that nothing was declared global at the top level+   let Usage {..} = varUsage suite+       moduleLocals =+          LocalScope+          { localScope_params = emptyParameterTypes+          , localScope_locals = usage_assigned+          , localScope_freeVars = Set.empty+          , localScope_cellVars = Set.empty+          , localScope_explicitGlobals = Set.empty }+   (nested, _freeVars) <- runReaderT (foldNestedScopes usage_definitions) emptyVarSet+   return (moduleLocals, nested)++insertNestedScope :: ScopeIdentifier -> (String, LocalScope) -> NestedScope -> NestedScope+insertNestedScope key value (NestedScope scope) = +   NestedScope $ Map.insert key value scope ++joinNestedScopes :: NestedScope -> NestedScope -> NestedScope+joinNestedScopes (NestedScope scope1) (NestedScope scope2)+   = NestedScope $ Map.union scope1 scope2++joinVarSets :: VarSet -> VarSet -> VarSet+joinVarSets = Set.union++foldNestedScopes :: [Definition] -> ScopeM (NestedScope, VarSet)+foldNestedScopes defs = do+   (scopes, vars) <- mapAndUnzipM buildNestedScope defs+   let joinedScopes = foldl' joinNestedScopes emptyNestedScope scopes+       joinedVars = foldl' joinVarSets emptyVarSet vars+   seq joinedScopes $ seq joinedVars $ return (joinedScopes, joinedVars)++buildNestedScope :: Definition -> ScopeM (NestedScope, VarSet)+buildNestedScope (DefStmt (Fun {..})) = do+   let usage = varUsage fun_body `mappend`+               varUsage fun_result_annotation+       parameterTypes = parseParameterTypes fun_args+   functionNestedScope usage parameterTypes+      (spanToScopeIdentifier stmt_annot) $ fromIdentString fun_name+buildNestedScope (DefLambda (Lambda {..})) = do+   let usage = varUsage lambda_body+       parameterTypes = parseParameterTypes lambda_args+   functionNestedScope usage parameterTypes+      (spanToScopeIdentifier expr_annot) "<lambda>" ++buildNestedScope (DefComprehension (Comprehension {..})) = do+   -- we introduce a new local variable called $result when compiling+   -- comprehensions, when they are desugared into functions+   let resultVarSet = Set.singleton "$result"+       usage = mempty { usage_assigned = resultVarSet+                      , usage_referenced = resultVarSet } `mappend`+               varUsage comprehension_expr `mappend`+               varUsage comprehension_for+   -- Comprehensions are turned into functions whose parameters are the+   -- variables which are free in the comprehension. This is equal+   -- to the variables which are referenced but not assigned.+       parameters = usage_referenced usage `Set.difference` usage_assigned usage+       parameterTypes = emptyParameterTypes { parameterTypes_pos = Set.toList parameters } +   functionNestedScope usage parameterTypes+      (spanToScopeIdentifier comprehension_annot) "<comprehension>" ++{-+   Classes can have freeVars, but they don't have cellVars.++   We have a problem where a class can have a free variable with the same+   name as a "locally" defined variable. ++	def f():+	   y = 3+	   class C():+	      y = 5+	      def g():+		 nonlocal y+		 print(y)++   The g() method of the C() class prints the value 3, because its free+   variable y is bound in the body of f, not in the class definition.++   The bases of a class are actually in the enclosing scope of the class+   definition.++   We record both instances of the variable, and are careful to disambiguate+   when the variables are looked-up in the scope during compilation.+-}++buildNestedScope (DefStmt (Class {..})) = do+   let Usage {..} = varUsage class_body +       locals = usage_assigned+   (thisNestedScope, nestedFreeVars) <- foldNestedScopes usage_definitions+   enclosingScope <- ask+   let directFreeVars +          = ((usage_referenced `Set.difference` locals) `Set.union`+              usage_nonlocals) `Set.intersection` enclosingScope+       freeVars = directFreeVars `Set.union` nestedFreeVars+   let thisLocalScope =+          LocalScope+          { localScope_params = emptyParameterTypes+          , localScope_locals = locals+          , localScope_freeVars = freeVars +          , localScope_cellVars = Set.empty+          , localScope_explicitGlobals = usage_globals }+   let newScope =+          insertNestedScope (spanToScopeIdentifier stmt_annot)+             (fromIdentString class_name, thisLocalScope)+             thisNestedScope+   return (newScope, freeVars)++buildNestedScope _def =+   error $ "buildNestedScope called on unexpected definition"++functionNestedScope :: Usage +                    -> ParameterTypes +                    -> ScopeIdentifier +                    -> String +                    -> ScopeM (NestedScope, VarSet)+functionNestedScope (Usage {..}) parameters scopeIdentifier name = do+   let locals = (usage_assigned `Set.difference` +                 usage_globals `Set.difference`+                 usage_nonlocals) `Set.union` +                 (Set.fromList $ identsFromParameters parameters)+   (thisNestedScope, nestedFreeVars) <-+      local (Set.union locals) $ foldNestedScopes usage_definitions+   enclosingScope <- ask+   let -- get all the variables which are free in the top level of+       -- this current nested scope+       -- variables which are free in nested scopes and bound in the current scope+       cellVars = locals `Set.intersection` nestedFreeVars+       -- variables which are referenced in the current scope but not local,+       -- or declared nonlocal and are bound in an enclosing scope +       -- (hence free in the current scope).+       directFreeVars +          = ((usage_referenced `Set.difference` locals) `Set.union`+              usage_nonlocals) `Set.intersection` enclosingScope+       -- free variables from nested scopes which are not bound in the+       -- current scope, and thus are free in the current scope+       indirectFreeVars = nestedFreeVars `Set.difference` cellVars+       freeVars = directFreeVars `Set.union` indirectFreeVars+       thisLocalScope =+          LocalScope+          { localScope_params = parameters +          , localScope_locals = locals+          , localScope_freeVars = freeVars +          , localScope_cellVars = cellVars+          , localScope_explicitGlobals = usage_globals }+   let newScope =+          insertNestedScope scopeIdentifier (name, thisLocalScope) thisNestedScope +   return (newScope, freeVars)++-- separate the positional parameters from the positional varargs and the+-- keyword varargs+parseParameterTypes :: [ParameterSpan] -> ParameterTypes+parseParameterTypes = parseAcc [] Nothing Nothing+   where+   parseAcc :: [Identifier] -> Maybe Identifier -> Maybe Identifier -> [ParameterSpan] -> ParameterTypes+   parseAcc pos varPos varKeyword [] =+      ParameterTypes { parameterTypes_pos = reverse pos+                     , parameterTypes_varPos = varPos+                     , parameterTypes_varKeyword = varKeyword }+   parseAcc pos varPos varKeyword (param:rest) =+      case param of+         Param {..} -> parseAcc (fromIdentString param_name : pos) varPos varKeyword rest +         VarArgsPos {..} -> parseAcc pos (Just $ fromIdentString param_name) varKeyword rest+         VarArgsKeyword {..} -> parseAcc pos varPos (Just $ fromIdentString param_name) rest+         _other -> parseAcc pos varPos varKeyword rest++instance Monoid Usage where+   mempty = Usage+               { usage_assigned = Set.empty+               , usage_nonlocals = Set.empty+               , usage_globals = Set.empty+               , usage_referenced = Set.empty+               , usage_definitions = [] }+   mappend x y+      = Usage+        { usage_assigned = usage_assigned x `mappend` usage_assigned y+        , usage_nonlocals = usage_nonlocals x `mappend` usage_nonlocals y+        , usage_referenced = usage_referenced x `mappend` usage_referenced y+        , usage_globals = usage_globals x `mappend` usage_globals y+        , usage_definitions = usage_definitions x `mappend` usage_definitions y }++instance Monoid ParameterTypes where+   mempty =+      ParameterTypes+      { parameterTypes_pos = []+      , parameterTypes_varPos = Nothing+      , parameterTypes_varKeyword = Nothing+      }++   mappend (ParameterTypes pos1 varPos1 varKeyword1)+           (ParameterTypes pos2 varPos2 varKeyword2)+      = ParameterTypes (pos1 `mappend` pos2)+                       (varPos1 `mappend` varPos2)+                       (varKeyword1 `mappend` varKeyword2)++-- determine the set of variables which are either assigned to or explicitly+-- declared global or nonlocal in the current scope.+class VarUsage t where+   varUsage :: t -> Usage++instance VarUsage t => VarUsage [t] where+   varUsage = mconcat . Prelude.map varUsage++instance (VarUsage t1, VarUsage t2) => VarUsage (t1, t2) where+   varUsage (x, y) = varUsage x `mappend` varUsage y++instance VarUsage a => VarUsage (Maybe a) where+   varUsage Nothing = mempty+   varUsage (Just x) = varUsage x++instance VarUsage StatementSpan where+   varUsage (While {..})+      = varUsage while_cond `mappend`+        varUsage while_body `mappend`+        varUsage while_else+   varUsage (For {..})+      = varUsage (AssignTargets $ for_targets) `mappend` +        varUsage for_generator `mappend`+        varUsage for_body `mappend` +        varUsage for_else+   -- Any varUsage made inside a function body are not collected.+   -- The function name _is_ collected, because it is assigned in the current scope,+   -- likewise for the class name.+   varUsage stmt@(Fun {..})+      = mempty { usage_assigned = singleVarSet fun_name+               , usage_definitions = [DefStmt stmt] }+   -- the bases of the Class are referenced within the scope that defines the class+   -- as opposed to being referenced in the body of the class+   varUsage stmt@(Class {..})+      = mempty { usage_assigned = singleVarSet class_name+               , usage_definitions = [DefStmt stmt] } `mappend`+        varUsage class_args+   varUsage (Conditional {..})+      = varUsage cond_guards `mappend` varUsage cond_else+   varUsage (Assign {..})+      = varUsage (AssignTargets assign_to) `mappend` varUsage assign_expr+   varUsage (AugmentedAssign {..})+      = varUsage [aug_assign_to] `mappend` varUsage aug_assign_expr+   varUsage (Decorated {..})+       = varUsage decorated_def+   varUsage (Try {..})+       = varUsage try_body `mappend` varUsage  try_excepts `mappend`+         varUsage try_else `mappend`  varUsage try_finally+   varUsage (With {..})+      = varUsage with_context `mappend`+        varUsage with_body+   varUsage (Global {..})+      = mempty { usage_globals = Set.fromList $ Prelude.map fromIdentString global_vars }+   varUsage (NonLocal {..})+      = mempty { usage_nonlocals = Set.fromList $ Prelude.map fromIdentString nonLocal_vars }+   varUsage (StmtExpr {..}) = varUsage stmt_expr+   varUsage (Assert {..}) = varUsage assert_exprs+   varUsage (Return {..}) = varUsage return_expr+   varUsage (Raise {..}) = varUsage raise_expr+   varUsage (Delete {..}) = varUsage del_exprs+   varUsage _other = mempty++instance VarUsage HandlerSpan where+   varUsage (Handler {..}) = varUsage handler_clause `mappend` varUsage handler_suite++instance VarUsage ExceptClauseSpan where+   varUsage (ExceptClause {..}) =+      case except_clause of+         Nothing -> mempty+         Just (except, maybeAs) ->+            case maybeAs of+               Nothing -> varUsage except+               Just asName -> varUsage except `mappend` (varUsage $ AssignTargets [asName])++instance VarUsage RaiseExprSpan where+   varUsage (RaiseV3 maybeExpr) = varUsage maybeExpr+   -- the parser should never generate the following, but we need+   -- code to make non-exhaustive pattern warnings go away.+   varUsage _other = error $ "varUsage on Python version 2 style raise statement"++instance VarUsage ExprSpan where+   varUsage (Var {..}) =+      mempty { usage_referenced = singleVarSet var_ident }+   varUsage (Call {..}) =+      varUsage call_fun `mappend` varUsage call_args +   varUsage (Subscript {..}) =+      varUsage subscriptee `mappend`+      varUsage subscript_expr+   varUsage (SlicedExpr {..}) =+      varUsage slicee `mappend` varUsage slices+   varUsage (CondExpr {..}) =+      varUsage ce_true_branch `mappend`+      varUsage ce_condition `mappend`+      varUsage ce_false_branch+   -- if it is a dot operator then the right argument must be a global name+   -- but it is not defined in this module so we can ignore it+   varUsage (BinaryOp {..})+      | Dot {} <- operator = varUsage left_op_arg +      | otherwise = varUsage left_op_arg `mappend` varUsage right_op_arg+   varUsage (UnaryOp {..}) = varUsage op_arg+   varUsage expr@(Lambda {..}) = mempty { usage_definitions = [DefLambda expr] }+   varUsage (Tuple {..}) = varUsage tuple_exprs+   varUsage (Yield {..}) = varUsage yield_expr +   varUsage (Generator {..}) =+      mempty { usage_definitions = [DefComprehension gen_comprehension] }+   varUsage (ListComp {..}) =+      mempty { usage_definitions = [DefComprehension list_comprehension] }+   varUsage (List {..}) = varUsage list_exprs+   varUsage (Dictionary {..}) = varUsage dict_mappings+   varUsage (DictComp {..}) = +      mempty { usage_definitions = [DefComprehension dict_comprehension] }+   varUsage (Set {..}) = varUsage set_exprs+   varUsage (SetComp {..}) =+      mempty { usage_definitions = [DefComprehension set_comprehension] } +   varUsage (Starred {..}) = varUsage starred_expr+   varUsage (Paren {..}) = varUsage paren_expr+   varUsage _other = mempty++instance VarUsage ArgumentSpan where+   varUsage (ArgExpr {..}) = varUsage arg_expr+   varUsage (ArgVarArgsPos {..}) = varUsage arg_expr+   varUsage (ArgVarArgsKeyword {..}) = varUsage arg_expr+   varUsage (ArgKeyword {..}) = varUsage arg_expr++instance VarUsage SliceSpan where+   varUsage (SliceProper {..}) =+      varUsage slice_lower `mappend`+      varUsage slice_upper `mappend`+      varUsage slice_stride+   varUsage (SliceExpr {..}) = varUsage slice_expr+   varUsage (SliceEllipsis {}) = mempty++instance VarUsage a => VarUsage (ComprehensionSpan a) where+   varUsage (Comprehension {..}) = +      varUsage comprehension_expr `mappend`+      varUsage comprehension_for++instance VarUsage CompForSpan where+   varUsage (CompFor {..}) = +      varUsage (AssignTargets comp_for_exprs) `mappend` +      varUsage comp_in_expr `mappend`+      varUsage comp_for_iter++instance VarUsage CompIterSpan where+   varUsage (IterFor {..}) = varUsage comp_iter_for+   varUsage (IterIf {..}) = varUsage comp_iter_if++instance VarUsage CompIfSpan where+   varUsage (CompIf {..}) = +      varUsage comp_if `mappend`+      varUsage comp_if_iter++newtype AssignTargets = AssignTargets [ExprSpan]++-- Collect all the variables which are assigned to in a list of expressions (patterns).+-- XXX we should support starred assign targets.+instance VarUsage AssignTargets where+   varUsage (AssignTargets exprs) = foldl' addUsage mempty exprs+      where+      addUsage :: Usage -> ExprSpan -> Usage +      addUsage usage expr = targetUsage expr `mappend` usage+      targetUsage :: ExprSpan -> Usage+      targetUsage (Var {..}) = mempty { usage_assigned = singleVarSet var_ident }+      targetUsage (List {..}) = varUsage $ AssignTargets list_exprs +      targetUsage (Tuple {..}) = varUsage $ AssignTargets tuple_exprs+      targetUsage (Paren {..}) = targetUsage paren_expr+      -- all variables mentioned in a subscript, attribute lookup+      -- and sliced expr are read from, not written to+      targetUsage expr@(Subscript {..}) = varUsage expr+      targetUsage expr@(BinaryOp{..}) = varUsage expr+      targetUsage expr@(SlicedExpr{..}) = varUsage expr+      targetUsage other = error $ "Unsupported assignTarget: " ++ show other++singleVarSet :: AST.Ident a -> VarSet+singleVarSet = Set.singleton . fromIdentString

@@ -0,0 +1,320 @@+{-# LANGUAGE RecordWildCards #-}+-----------------------------------------------------------------------------+-- |+-- Module      : StackDepth+-- Copyright   : (c) 2012, 2013 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Compute an upper bound on the stack usage of a block of bytecode. +--  It is safe to make the stack too big (but+-- it would waste memory), but if it is too small then the interpreter will+-- probably crash (or worse, keep running in an undefined state).+--+-----------------------------------------------------------------------------++module StackDepth (maxStackDepth) where+ +import Types (AnnotatedCode (..))+import Utils (isJumpBytecode, isRelativeJump, isConditionalJump)+import Blip.Bytecode (Bytecode (..), BytecodeArg (..), Opcode (..), bytecodeSize)+import Data.Word (Word32, Word16)+import Control.Monad.RWS.Strict (RWS, runRWS, ask, local, gets, modify, when)+import qualified Data.Map as Map+import qualified Data.Set as Set (insert, member, Set, empty)+import Data.Bits ((.&.), shiftR)++type StackDepth = Word32+type InstructionIndex = Word16+type InstructionSeen = Set.Set InstructionIndex+-- Mapping from byte address (jump target) to sequence of bytecode+-- from that address onwards.+type BytecodeMap = Map.Map InstructionIndex [AnnotatedCode]+type StackDepthCache = Map.Map InstructionIndex StackDepth+type CalcStackDepth = RWS InstructionSeen () StackDepthState++maxStackDepth :: [AnnotatedCode] -> StackDepth+maxStackDepth code = +   stackDepth_maxDepth finalState+   where+   (_, finalState, _) = runRWS (maxStackDepthM 0 code)+                               Set.empty $ initStackDepthState $+                               makeBytecodeMap code++makeBytecodeMap :: [AnnotatedCode] -> BytecodeMap+makeBytecodeMap = makeBytecodeMapAcc Map.empty+   where+   makeBytecodeMapAcc :: BytecodeMap -> [AnnotatedCode] -> BytecodeMap+   makeBytecodeMapAcc map [] = map+   makeBytecodeMapAcc map code@(instruction@(AnnotatedCode {..}) : rest)+      | isLabelled instruction = do+          let newMap = Map.insert annotatedCode_index code map+          makeBytecodeMapAcc newMap rest+      | otherwise = makeBytecodeMapAcc map rest++data StackDepthState =+   StackDepthState+   { stackDepth_bytecodeMap :: BytecodeMap+   , stackDepth_maxDepth :: !StackDepth+   , stackDepth_cache :: StackDepthCache +   }++initStackDepthState :: BytecodeMap -> StackDepthState+initStackDepthState bytecodeMap =+   StackDepthState+   { stackDepth_bytecodeMap = bytecodeMap+   , stackDepth_maxDepth = 0 +   , stackDepth_cache = Map.empty }+++isLabelled :: AnnotatedCode -> Bool+isLabelled (AnnotatedCode {..}) = not $ null annotatedCode_labels++isLoopBack :: InstructionIndex -> CalcStackDepth Bool+isLoopBack index = do+   seen <- ask+   return (index `Set.member` seen)++-- record that we've visited this jump target at this depth+-- in case we visit it again in any path. There is no point+-- traversing further if the previous visit was at an equal+-- or greater depth.++visitedDeeper :: InstructionIndex -> StackDepth -> CalcStackDepth Bool+visitedDeeper index newDepth = do+   stackDepthCache <- gets stackDepth_cache +   case Map.lookup index stackDepthCache of+       -- not been here before at any depth+       Nothing -> return False+       Just oldDepth -> return (oldDepth >= newDepth)++recordDepth :: InstructionIndex -> StackDepth -> CalcStackDepth ()+recordDepth index depth = do+   stackDepthCache <- gets stackDepth_cache+   let newCache = Map.insert index depth stackDepthCache+   modify $ \s -> s { stackDepth_cache = newCache }++maxStackDepthM :: StackDepth -> [AnnotatedCode] -> CalcStackDepth ()+maxStackDepthM _depth [] = return ()+maxStackDepthM depth code@(instruction@(AnnotatedCode {..}) : _rest) = do+   -- check if this instruction is a jump target+   if isLabelled instruction+      then do+         seenBeforeOnPath <- isLoopBack annotatedCode_index +         seenDeeper <- visitedDeeper annotatedCode_index depth+         if seenBeforeOnPath || seenDeeper+            -- we've seen this instruction before on this path, or+            -- we've visisted it on any path at this depth or+            -- deeper, no point in going further down this path.+            then return ()+            else local (Set.insert annotatedCode_index) $ do+                    recordDepth annotatedCode_index depth+                    maxStackDepthFurther depth code+      else+         maxStackDepthFurther depth code+   where+   maxStackDepthFurther :: StackDepth -> [AnnotatedCode] -> CalcStackDepth ()+   maxStackDepthFurther depth (instruction@(AnnotatedCode {..}) : rest) = do+       let newDepth = depth + codeStackEffect annotatedCode_bytecode+       updateMaxDepth newDepth+       when (isJumpBytecode annotatedCode_bytecode) $+           -- follow the path of the jump+           maxStackDepthJump newDepth instruction+       -- follow the remaining instructions+       -- unless the current instruction is an unconditional jump+       when (isConditionalBytecode annotatedCode_bytecode) $+          maxStackDepthM newDepth rest+   maxStackDepthFurther _depth [] =+      error $ "maxStackDepthFurther called on empty sequence of code"++isConditionalBytecode :: Bytecode -> Bool+isConditionalBytecode (Bytecode {..}) = isConditionalJump opcode++{-+   from CPython, compile.c:++        if (instr->i_opcode == FOR_ITER) {+                target_depth = depth-2;+            } else if (instr->i_opcode == SETUP_FINALLY ||+                       instr->i_opcode == SETUP_EXCEPT) {+                target_depth = depth+3;+                if (target_depth > maxdepth)+                    maxdepth = target_depth;+            }+-}++maxStackDepthJump :: StackDepth -> AnnotatedCode -> CalcStackDepth ()+maxStackDepthJump depth instruction@(AnnotatedCode {..}) = do+   let targetDepth =+          case opcode annotatedCode_bytecode of+             FOR_ITER -> depth - 2+             SETUP_FINALLY -> depth + 3+             SETUP_EXCEPT -> depth + 3+             _other -> depth+   updateMaxDepth targetDepth +   code <- getJumpToCode instruction+   maxStackDepthM targetDepth code ++getJumpToCode :: AnnotatedCode -> CalcStackDepth [AnnotatedCode]+getJumpToCode instruction@(AnnotatedCode {..}) = do+   let jumpTarget = +          if isRelativeJump $ opcode annotatedCode_bytecode +             then relativeTarget instruction+             else absoluteTarget instruction+   bytecodeMap <- gets stackDepth_bytecodeMap+   case Map.lookup jumpTarget bytecodeMap of+       Nothing -> error $ "Jump to uknown target: " ++ show instruction+       Just code -> return code++relativeTarget :: AnnotatedCode -> InstructionIndex+relativeTarget instruction@(AnnotatedCode {..}) =+   target + (annotatedCode_index + instructionSize)+   where+   instructionSize = fromIntegral $ bytecodeSize annotatedCode_bytecode+   target = getJumpTarget instruction++absoluteTarget :: AnnotatedCode -> InstructionIndex+absoluteTarget instruction@(AnnotatedCode {..}) +   = getJumpTarget instruction++getJumpTarget :: AnnotatedCode -> InstructionIndex+getJumpTarget instruction@(AnnotatedCode {..}) =+   case args annotatedCode_bytecode of+      Nothing -> error $ "Jump instruction without argument: " ++ show instruction+      Just (Arg16 label) -> label++updateMaxDepth :: StackDepth -> CalcStackDepth ()+updateMaxDepth depth = do+   currentMaxDepth <- gets stackDepth_maxDepth+   when (depth > currentMaxDepth) $ +      modify $ \s -> s { stackDepth_maxDepth = depth }++-- Compute the effect of each opcode on the depth of the stack.+-- This is used to compute an upper bound on the depth of the stack+-- for each code object. It is safe to over-estimate the depth of the+-- effect, but it is unsafe to underestimate it. Over-estimation will+-- potentially result in the stack being bigger than needed, which would+-- waste memory but otherwise be safe. Under-estimation will likely result+-- in the stack being too small and a serious fatal error in the interpreter, such+-- as segmentation fault (or reading/writing some other part of memory).+-- Some opcodes have different effect on depth depending on other factors, this function+-- convservatively takes the largest possible value.+-- This function is supposed to be identical in behaviour to opcode_stack_effect+-- in Python/compile.c.++codeStackEffect :: Bytecode -> StackDepth+codeStackEffect bytecode@(Bytecode {..}) = +   case opcode of+      POP_TOP -> -1+      ROT_TWO -> 0+      ROT_THREE -> 0+      DUP_TOP -> 1+      DUP_TOP_TWO -> 2+      UNARY_POSITIVE -> 0+      UNARY_NEGATIVE -> 0+      UNARY_NOT -> 0+      UNARY_INVERT -> 0+      SET_ADD -> -1+      LIST_APPEND -> -1+      MAP_ADD -> -2+      BINARY_POWER -> -1+      BINARY_MULTIPLY -> -1+      BINARY_MODULO -> -1+      BINARY_ADD -> -1+      BINARY_SUBTRACT -> -1+      BINARY_SUBSCR -> -1+      BINARY_FLOOR_DIVIDE -> -1+      BINARY_TRUE_DIVIDE -> -1+      INPLACE_FLOOR_DIVIDE -> -1+      INPLACE_TRUE_DIVIDE -> -1+      INPLACE_ADD -> -1+      INPLACE_SUBTRACT -> -1+      INPLACE_MULTIPLY -> -1+      INPLACE_MODULO -> -1+      STORE_SUBSCR -> -3+      STORE_MAP -> -2+      DELETE_SUBSCR -> -2+      BINARY_LSHIFT -> -1+      BINARY_RSHIFT -> -1+      BINARY_AND -> -1+      BINARY_XOR -> -1+      BINARY_OR -> -1+      INPLACE_POWER -> -1+      GET_ITER -> 0+      PRINT_EXPR -> -1+      LOAD_BUILD_CLASS -> 1+      INPLACE_LSHIFT -> -1+      INPLACE_RSHIFT -> -1+      INPLACE_AND -> -1+      INPLACE_XOR -> -1+      INPLACE_OR -> -1+      BREAK_LOOP -> 0+      SETUP_WITH -> 7+      WITH_CLEANUP -> -1 -- Sometimes more+      STORE_LOCALS -> -1+      RETURN_VALUE -> -1+      IMPORT_STAR -> -1+      YIELD_VALUE -> 0+      YIELD_FROM -> -1+      POP_BLOCK -> 0+      POP_EXCEPT -> 0  -- -3 except if bad bytecode+      END_FINALLY -> -1 -- or -2 or -3 if exception occurred+      STORE_NAME -> -1+      DELETE_NAME -> 0+      UNPACK_SEQUENCE -> withArg $ \oparg -> oparg - 1+      UNPACK_EX -> withArg $ \oparg -> (oparg .&. 0xFF) + (oparg `shiftR` 8)+      FOR_ITER -> 1 -- or -1, at end of iterator+      STORE_ATTR -> -2+      DELETE_ATTR -> -1+      STORE_GLOBAL -> -1+      DELETE_GLOBAL -> 0+      LOAD_CONST -> 1+      LOAD_NAME -> 1+      BUILD_TUPLE -> withArg $ \oparg -> 1 - oparg+      BUILD_LIST -> withArg $ \oparg -> 1 - oparg+      BUILD_SET -> withArg $ \oparg -> 1 - oparg+      BUILD_MAP -> 1+      LOAD_ATTR -> 0+      COMPARE_OP -> -1+      IMPORT_NAME -> -1+      IMPORT_FROM -> 1+      JUMP_FORWARD -> 0+      JUMP_IF_TRUE_OR_POP -> 0 -- -1 if jump not taken+      JUMP_IF_FALSE_OR_POP -> 0 -- ditto+      JUMP_ABSOLUTE -> 0+      POP_JUMP_IF_FALSE -> -1+      POP_JUMP_IF_TRUE -> -1+      LOAD_GLOBAL -> 1+      CONTINUE_LOOP -> 0+      SETUP_LOOP -> 0+      SETUP_EXCEPT -> 6+      SETUP_FINALLY -> 6 -- can push 3 values for the new exception+                         -- plus 3 others for the previous exception state+      LOAD_FAST -> 1+      STORE_FAST -> -1+      DELETE_FAST -> 0+      RAISE_VARARGS -> withArg $ \oparg -> -1 * oparg+      CALL_FUNCTION -> withArg $ \oparg -> -1 * nargs oparg+      CALL_FUNCTION_VAR -> withArg $ \oparg -> (-1 * nargs oparg) - 1+      CALL_FUNCTION_KW -> withArg $ \oparg -> (-1 * nargs oparg) - 1 +      CALL_FUNCTION_VAR_KW -> withArg $ \oparg -> (-1 * nargs oparg) - 2+      MAKE_FUNCTION -> withArg $ \oparg -> -1 - (nargs oparg) - ((oparg `shiftR` 16) .&. 0xffff)+      MAKE_CLOSURE -> withArg $ \oparg -> -2 - (nargs oparg) - ((oparg `shiftR` 16) .&. 0xffff)+      BUILD_SLICE -> withArg $ \oparg -> if oparg == 3 then -2 else -1+      LOAD_CLOSURE -> 1+      LOAD_DEREF -> 1+      STORE_DEREF -> -1+      DELETE_DEREF -> 0+      _other -> error $ "unexpected opcode in codeStackEffect: " ++ show bytecode+   where+   -- #define NARGS(o) (((o) % 256) + 2*(((o) / 256) % 256)) +   nargs :: Word32 -> Word32+   nargs o = (o `mod` 256) + (2 * ((o `div` 256) `mod` 256))+   withArg :: (Word32 -> Word32) -> Word32+   withArg f+      = case args of+           Nothing -> error $ "codeStackEffect: " ++ (show opcode) ++ " missing argument"+           Just (Arg16 word16) -> f $ fromIntegral word16+           -- other -> error $ "codeStackEffect unexpected opcode argument: " ++ show other

@@ -0,0 +1,543 @@+{-# LANGUAGE RecordWildCards #-}++-----------------------------------------------------------------------------+-- |+-- Module      : State+-- Copyright   : (c) 2012, 2013 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Management of state for the compiler. There is global state which+-- persists through the whole compilation (such as command line flags), and+-- there is block state, which is local for the compilation of a block+-- of code.+--+-----------------------------------------------------------------------------+module State+   ( setBlockState, getBlockState, initBlockState, initState, modifyBlockState+   , emitCode, emitCodeNoArg, emitCodeArg, compileConstant+   , getFileName, newLabel, compileConstantEmit, labelNextInstruction+   , getObjectName, setObjectName, getLabelMap+   , getNestedScope, ifDump, emptyVarSet, emptyLocalScope+   , getLocalScope, indexedVarSetKeys, lookupNameVar+   , emitReadVar, emitWriteVar, emitDeleteVar, lookupClosureVar, setFlag+   , pushFrameBlock, popFrameBlock, peekFrameBlock, withFrameBlock +   , setFastLocals, setArgCount, emptyParameterTypes, setLineNumber+   , setFirstLineNumber )+   where++import Monad (Compile (..))+import Types+   ( Identifier, CompileConfig (..), VarIndex, IndexedVarSet+   , ConstantID, CompileState (..), BlockState (..)+   , AnnotatedCode (..), LabelMap, Dumpable, VarSet, NestedScope (..)+   , LocalScope (..), VarInfo (..), ScopeIdentifier+   , FrameBlockInfo (..), Context (..), ParameterTypes (..) )+import Blip.Bytecode+   (Bytecode (..), Opcode (..), BytecodeArg (..), bytecodeSize)+import Blip.Marshal (PyObject (..), CodeObjectFlagMask, co_varargs, co_varkeywords)+import Data.Word (Word16, Word32)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Control.Monad.State.Strict as State hiding (State)+import Data.List (sort)+import Data.Bits ((.|.))+import Utils (identsFromParameters, countPosParameters, getSpanLine)+import Language.Python.Common.SrcLocation (SrcSpan (..))++emptyVarSet :: VarSet+emptyVarSet = Set.empty++emptyParameterTypes :: ParameterTypes+emptyParameterTypes =+   ParameterTypes { parameterTypes_pos = []+                  , parameterTypes_varPos = Nothing+                  , parameterTypes_varKeyword = Nothing+                  }++emptyLocalScope :: LocalScope+emptyLocalScope =+   LocalScope+   { localScope_params = emptyParameterTypes +   , localScope_locals = emptyVarSet+   , localScope_freeVars = emptyVarSet+   , localScope_cellVars = emptyVarSet+   , localScope_explicitGlobals = emptyVarSet+   }++initBlockState :: Context -> LocalScope -> BlockState+initBlockState context (LocalScope {..}) = BlockState+   { state_label = 0+   , state_instructions = []+   , state_labelNextInstruction = [] +   , state_constants = [] +   , state_constantCache = Map.empty+   , state_nextConstantID = 0+   , state_names = []+   , state_nameCache = Map.empty+   , state_nextNameID = 0+   , state_objectName = ""+   , state_instruction_index = 0+   , state_labelMap = Map.empty+   , state_locals = localScope_locals+   , state_fastLocals =+        if context == FunctionContext+           then makeLocalsIndexedSet (identsFromParameters localScope_params)+                   localScope_locals +           else Map.empty+   -- the indices for cellvars and freevars are used as offsets into an array+   -- within the code object. The cellvars come first, followed by the+   -- freevars. These indices are used by the LOAD_DEREF and STORE_DEREF+   -- bytecode instructions.+   -- cellvars are indexed from 0 upwards+   , state_cellVars = indexedVarSet 0 $ localScope_cellVars +   -- freevars are indexed from (length cellvars) +   , state_freeVars = indexedVarSet+                         (fromIntegral $ Set.size localScope_cellVars) +                         localScope_freeVars +   , state_explicitGlobals = localScope_explicitGlobals+   , state_argcount = fromIntegral $ countPosParameters localScope_params+   , state_flags = varArgsFlags localScope_params 0+   , state_frameBlockStack = []+   , state_context = context+   , state_lineNumber = 0+   , state_lineNumberTable = []+   , state_firstLineNumber = 0+   }++varArgsFlags :: ParameterTypes -> Word32 -> Word32+varArgsFlags (ParameterTypes {..}) flags =+   flags .|. posVarArgsMask .|. keywordVarArgsMask+   where+   posVarArgsMask :: CodeObjectFlagMask+   posVarArgsMask = +      maybe 0 (const co_varargs) parameterTypes_varPos+   keywordVarArgsMask :: CodeObjectFlagMask+   keywordVarArgsMask =+      maybe 0 (const co_varkeywords) parameterTypes_varKeyword ++-- Local variables are indexed starting with parameters first, in the order+-- that they appear in the function head, followed by the other+-- locally defined variables, which can appear in any order.+makeLocalsIndexedSet :: [Identifier] -> VarSet -> IndexedVarSet+makeLocalsIndexedSet params locals =+   Map.fromList $ zip (params ++ Set.toList localsNotParams) [0..]+   where+   localsNotParams = locals `Set.difference` Set.fromList params++indexedVarSet :: VarIndex -> VarSet -> IndexedVarSet+indexedVarSet from set =+   Map.fromList $ sort $ zip (Set.toList set) [from..]++-- Return the keys of an IndexedVarSet in ascending order of the indices+indexedVarSetKeys :: IndexedVarSet -> [Identifier]+indexedVarSetKeys varset =+   map snd $ sort [ (index, name) | (name, index) <- Map.assocs varset ]++incInstructionIndex :: Bytecode -> Compile Word16+incInstructionIndex bytecode = do+   currentIndex <- getBlockState state_instruction_index+   let nextIndex = currentIndex + (fromIntegral $ bytecodeSize bytecode)+   modifyBlockState $ \s -> s { state_instruction_index = nextIndex }+   return currentIndex++setFastLocals :: [Identifier] -> Compile ()+setFastLocals idents = do+   let localsVarSet = Set.fromList idents+   modifyBlockState $ \s -> s { state_fastLocals = indexedVarSet 0 localsVarSet }++setArgCount :: Word32 -> Compile ()+setArgCount n = modifyBlockState $ \s -> s { state_argcount = n }++initState :: Context       -- module, class or function?+          -> LocalScope    -- local scope of the top-level of the module+          -> NestedScope   -- nested scope of the rest of the module (not at the top-level)+          -> CompileConfig -- configuration options+          -> FilePath      -- file path of the Python source+          -> CompileState+initState context localScope nestedScope config pyFilename = CompileState+   { state_config = config+   , state_blockState = initBlockState context localScope+   , state_filename = pyFilename+   , state_nestedScope = nestedScope+   }++ifDump :: Dumpable -> Compile () -> Compile ()+ifDump dumpable action = do+   state <- get+   if dumpable `Set.member` (compileConfig_dumps $ state_config state)+      then action+      else return () ++-- get the nested scope for the current block+getNestedScope :: Compile NestedScope+getNestedScope = gets state_nestedScope++getLocalScope :: ScopeIdentifier -> Compile (String, LocalScope)+getLocalScope scopeIdent = do+   NestedScope nestedScope <- getNestedScope+   case Map.lookup scopeIdent nestedScope of+      Just scope -> return scope+      -- this case should never happen+      Nothing -> error $ "no scope found for: " ++ show scopeIdent++getFileName :: Compile FilePath+getFileName = gets state_filename++getObjectName :: Compile String+getObjectName = getBlockState state_objectName++setObjectName :: String -> Compile ()+setObjectName str = modifyBlockState $ \s -> s { state_objectName = str }++setBlockState :: BlockState -> Compile ()+setBlockState blockState = do+   oldState <- get+   put $ oldState { state_blockState = blockState }++getBlockState :: (BlockState -> a) -> Compile a +getBlockState f = gets (f . state_blockState)++modifyBlockState :: (BlockState -> BlockState) -> Compile ()+modifyBlockState f = do+   state <- getBlockState id+   setBlockState $! f state++newLabel :: Compile Word16+newLabel = do+   currentLabel <- getBlockState state_label+   let newLabel = currentLabel + 1+   modifyBlockState $ \s -> s { state_label = newLabel }+   return currentLabel++-- prefix this new label onto the existing ones+labelNextInstruction :: Word16 -> Compile ()+labelNextInstruction newLabel = do+   currentLabels <- getBlockState state_labelNextInstruction+   modifyBlockState $ \ s -> s { state_labelNextInstruction = newLabel : currentLabels }++{-+          | Free  | Cell  | Local | Explicit Global | Implicit Global+---------------------------------------------------------------------+Class     | Deref | X     | Name  | Global          | Name          +Module    | X     | X     | Name  | X               | Name+Funcition | Deref | Deref | Fast  | Global          | Global++-}++data VarOpcodeType = Deref | Name | Global | Fast++emitReadVar :: Identifier -> Compile ()+emitReadVar ident = do+   (opcodeType, index) <- getVarOpcodeType ident+   case opcodeType of+      Deref -> emitCodeArg LOAD_DEREF index+      Name -> emitCodeArg LOAD_NAME index+      Global -> emitCodeArg LOAD_GLOBAL index+      Fast -> emitCodeArg LOAD_FAST index++emitWriteVar :: Identifier -> Compile ()+emitWriteVar ident = do+   (opcodeType, index) <- getVarOpcodeType ident+   case opcodeType of+      Deref -> emitCodeArg STORE_DEREF index+      Name -> emitCodeArg STORE_NAME index+      Global -> emitCodeArg STORE_GLOBAL index+      Fast -> emitCodeArg STORE_FAST index++emitDeleteVar :: Identifier -> Compile ()+emitDeleteVar ident = do+   (opcodeType, index) <- getVarOpcodeType ident+   case opcodeType of+      Deref -> emitCodeArg DELETE_DEREF index+      Name -> emitCodeArg DELETE_NAME index+      Global -> emitCodeArg DELETE_GLOBAL index+      Fast -> emitCodeArg DELETE_FAST index++getVarOpcodeType :: Identifier -> Compile (VarOpcodeType, VarIndex)+getVarOpcodeType ident = do+   context <- getBlockState state_context+   varInfo <- lookupVar ident+   getVarInContext context varInfo+   where+   getVarInContext :: Context -> VarInfo -> Compile (VarOpcodeType, VarIndex)+   getVarInContext ClassContext info =+      case info of+         FreeVar index -> return (Deref, index)+         LocalVar -> do+            index <- lookupNameVar ident+            return (Name, index)+         ExplicitGlobal -> do+            index <- lookupNameVar ident+            return (Global, index)+         ImplicitGlobal -> do+            index <- lookupNameVar ident+            return (Name, index)+         CellVar _index -> error $ "class with a cell variable: " ++ ident+   getVarInContext ModuleContext info =+      case info of+         LocalVar -> do+            index <- lookupNameVar ident+            return (Name, index)+         ImplicitGlobal -> do+            index <- lookupNameVar ident+            return (Name, index)+         FreeVar _index ->+            error $ "module with a free variable: " ++ ident+         CellVar _index ->+            error $ "module with a cell variable: " ++ ident+         ExplicitGlobal ->+            error $ "module with an explicit global variable: " ++ ident+   getVarInContext FunctionContext info =+      case info of+         FreeVar index -> return (Deref, index)+         CellVar index -> return (Deref, index)+         LocalVar -> do+            fastLocals <- getBlockState state_fastLocals +            case Map.lookup ident fastLocals of+               Just index -> return (Fast, index)+               Nothing -> error $ "local function variable not in fast locals: " ++ ident+         ExplicitGlobal -> do+            index <- lookupNameVar ident+            return (Global, index)+         ImplicitGlobal -> do+            index <- lookupNameVar ident+            return (Global, index)++emitCodeArg :: Opcode -> Word16 -> Compile ()+emitCodeArg opCode arg = emitCode $ Bytecode opCode (Just $ Arg16 arg)++emitCodeNoArg :: Opcode -> Compile ()+emitCodeNoArg opCode = emitCode $ Bytecode opCode Nothing++emitCode :: Bytecode -> Compile ()+emitCode instruction = do+   -- Attach a label to the instruction if necesary.+   labels <- getBlockState state_labelNextInstruction+   -- Ensure current labels are used only once.+   modifyBlockState $ \s -> s { state_labelNextInstruction = [] }+   instructionIndex <- incInstructionIndex instruction+   -- add a mapping from instruction offset to source code line number+   updateLineNumberTable instructionIndex+   -- Map each label to its instruction index+   forM_ labels $ \label -> updateLabelMap label instructionIndex+   let annotatedInstruction =+          AnnotatedCode { annotatedCode_bytecode = instruction+                        , annotatedCode_labels = labels+                        , annotatedCode_index = instructionIndex } +   oldInstructions <- getBlockState state_instructions+   modifyBlockState $+      \s -> s { state_instructions = annotatedInstruction : oldInstructions }++getLabelMap :: Compile LabelMap+getLabelMap = getBlockState state_labelMap++updateLabelMap :: Word16 -> Word16 -> Compile ()+updateLabelMap label index = do+   oldLabelMap <- getBlockState state_labelMap+   let newLabelMap = Map.insert label index oldLabelMap+   modifyBlockState $ \s -> s { state_labelMap = newLabelMap }++updateLineNumberTable :: Word16 -> Compile ()+updateLineNumberTable offset = do+   lineNumber <- getBlockState state_lineNumber+   oldTable <- getBlockState state_lineNumberTable+   let updateTable =+          modifyBlockState $ \s -> s { state_lineNumberTable = (offset, lineNumber) : oldTable }+   case oldTable of+      [] -> updateTable +      (_prevOffset, prevLineNumber):_rest+         -- don't update the table if the current line number is not less+         -- than the previously stored line number+         | prevLineNumber >= lineNumber -> return ()+         | otherwise -> updateTable++compileConstant :: PyObject -> Compile ConstantID+-- Code objects are not cached to avoid complex equality comparisons+compileConstant obj@(Code {}) = do+   oldConstants <- getBlockState state_constants+   constantID <- getBlockState state_nextConstantID +   modifyBlockState $+      \s -> s { state_constants = obj : oldConstants+              , state_nextConstantID = constantID + 1 }+   return constantID+compileConstant obj = do+   blockState <- getBlockState id+   let constantCache = state_constantCache blockState+   case Map.lookup obj constantCache of+      -- We haven't seen this (non-code) constant before+      Nothing -> do+         let constantID = state_nextConstantID blockState+             newConstantCache = Map.insert obj constantID constantCache +             oldConstants = state_constants blockState+         setBlockState $ blockState+            { state_nextConstantID = constantID + 1+            , state_constantCache = newConstantCache+            , state_constants = obj : oldConstants }+         return constantID+      Just constantID -> return constantID++compileConstantEmit :: PyObject -> Compile ()+compileConstantEmit obj = do+   constantID <- compileConstant obj+   emitCodeArg LOAD_CONST constantID++{-++check if var is:++  cellvar+  localvar+  freevar+  explicit global+  implicit global ++We check local vars first before free vars because classes can+have a variable with the same name being local and also free.+If a local version of the variable is defined, that is the+one we want to see (not the free variable). If we need to+see the free variable, then we can look it up specially.++If we can't find it defined anywhere then we presume it+to be an implicit global variable.++-}++lookupVar :: Identifier -> Compile VarInfo+lookupVar identifier = do+   -- cell+   cellvars <- getBlockState state_cellVars+   case Map.lookup identifier cellvars of+      Just index -> return $ CellVar index+      Nothing -> do+         -- local+         locals <- getBlockState state_locals+         if identifier `Set.member` locals+            then return LocalVar+            else do+               -- free+               freevars <- getBlockState state_freeVars+               case Map.lookup identifier freevars of+                  Just index -> return $ FreeVar index+                  Nothing -> do+                     -- explicit global+                     explicitGlobals <- getBlockState state_explicitGlobals+                     if identifier `Set.member` explicitGlobals+                        then return ExplicitGlobal+                        -- implicit global +                        else return ImplicitGlobal++{- lookup a variable in cell vars or free vars only.+   We avoid looking in other places because, for example,+   classes can have free variables with the same name as+   locally defined variables, and we don't want to get them+   confused.+-}++lookupClosureVar :: Identifier -> Compile (Maybe VarInfo)+lookupClosureVar identifier = do+   cellvars <- getBlockState state_cellVars+   case Map.lookup identifier cellvars of+      Just index -> return $ Just $ CellVar index+      Nothing -> do+         freevars <- getBlockState state_freeVars+         case Map.lookup identifier freevars of+            Just index -> return $ Just $ FreeVar index+            Nothing -> return Nothing++-- look up a variable in the "names" vector. Add it if it is not there.+-- return the index of the variable in the vector.+lookupNameVar :: Identifier -> Compile VarIndex+lookupNameVar ident = do+   blockState <- getBlockState id+   let nameCache = state_nameCache blockState+   case Map.lookup ident nameCache of+      -- We haven't seen this name before+      Nothing -> do+         let index = state_nextNameID blockState+             newNameCache = Map.insert ident index nameCache+             oldNames = state_names blockState +         setBlockState $+            blockState { state_nextNameID = index + 1+                       , state_nameCache = newNameCache +                       , state_names = ident : oldNames }+         return index +      Just index -> return index ++-- set a flag in the code object by applying a mask +setFlag :: CodeObjectFlagMask -> Compile ()+setFlag mask = do+    oldFlags <- getBlockState state_flags +    let newFlags = oldFlags .|. mask+    modifyBlockState $ \state -> state { state_flags = newFlags }++pushFrameBlock :: FrameBlockInfo -> Compile ()+pushFrameBlock info = do+   oldFrameStack <- getBlockState state_frameBlockStack+   let newFrameStack = info : oldFrameStack+   modifyBlockState $ \state -> state { state_frameBlockStack = newFrameStack }++popFrameBlock :: Compile FrameBlockInfo+popFrameBlock = do+   oldFrameStack <- getBlockState state_frameBlockStack+   case oldFrameStack of+      [] -> error "attempt to pop from an empty frame block stack"+      top:rest -> do+         modifyBlockState $ \state -> state { state_frameBlockStack = rest }+         return top++peekFrameBlock :: Compile (Maybe FrameBlockInfo)+peekFrameBlock = do+   oldFrameStack <- getBlockState state_frameBlockStack+   case oldFrameStack of+      [] -> return Nothing+      top:_rest -> return $ Just top++withFrameBlock :: FrameBlockInfo -> Compile a -> Compile a+withFrameBlock pushedInfo comp = do +    pushFrameBlock pushedInfo+    result <- comp+    poppedInfo <- popFrameBlock+    if pushedInfo /= poppedInfo+       then error $ "pushed frame block not equal to popped frame block"+       else return result++{- ++   From Python/compile.c++   The line number is reset in the following cases:+   - when entering a new scope+   - on each statement+   - on each expression that start a new line+   - before the "except" clause+   - before the "for" and "while" expressions++   Our own remarks:++   - the CPython compiler does not seem to follow the above comment+     for "for" and "while" statements (not expressions).+   - I'm not sure why they do something special for the "except" clause+     and why not the "else" and "finally"?+-}++setLineNumber :: SrcSpan -> Compile ()+setLineNumber span =+   case getSpanLine span of+      Nothing -> return ()+      Just line -> do+         let lineWord32 = fromIntegral line+         oldLineNumber <- getBlockState state_lineNumber+         -- We ensure that line numbers are monotonically increasing.+         if lineWord32 > oldLineNumber+            then modifyBlockState $ \s -> s { state_lineNumber = lineWord32 }+            else return ()++setFirstLineNumber :: SrcSpan -> Compile ()+setFirstLineNumber span = +   case getSpanLine span of+      Nothing -> return ()+      Just line ->+         modifyBlockState $ \state -> state { state_firstLineNumber = fromIntegral line }

@@ -0,0 +1,143 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Types+-- Copyright   : (c) 2012, 2013 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Type definitions which are used in multiple modules.+--+-----------------------------------------------------------------------------+module Types +   ( Identifier, CompileConfig (..), VarIndex, IndexedVarSet+   , ConstantID, ConstantCache, CompileState (..), BlockState (..)+   , AnnotatedCode (..), LabelMap, Dumpable (..), VarSet+   , LocalScope (..), NestedScope (..), VarInfo (..)+   , ScopeIdentifier, FrameBlockInfo (..), Context (..), ParameterTypes (..)+   ) where++import Data.Set (Set)+import Blip.Bytecode (Bytecode (..))+import Blip.Marshal (PyObject (..))+import Data.Word (Word32, Word16)+import qualified Data.Map as Map++-- The context in which a variable is used affects the bytecode+-- related to that use.+data Context+   = ModuleContext+   | ClassContext+   | FunctionContext+   deriving (Eq, Ord, Show)++-- information about how a variable is bound plus its offset into+-- the appropriate structure+data VarInfo+   = LocalVar+   | CellVar VarIndex +   | FreeVar VarIndex +   | ExplicitGlobal+   | ImplicitGlobal++type VarSet = Set Identifier++-- XXX need to handle keyword only paramters+data ParameterTypes+   = ParameterTypes+     { parameterTypes_pos :: ![Identifier]+     , parameterTypes_varPos :: !(Maybe Identifier)+     , parameterTypes_varKeyword :: !(Maybe Identifier)+     }+   deriving (Eq, Show)++data LocalScope+   = LocalScope+     { localScope_params :: !ParameterTypes+     , localScope_locals :: !VarSet+     , localScope_freeVars :: !VarSet+     , localScope_cellVars :: !VarSet+     , localScope_explicitGlobals :: !VarSet+     }+     deriving Show++-- start and end coordinates of span (row, col, row, col)+type ScopeIdentifier = (Int, Int, Int, Int)++-- mapping from source location to pair of (scope name, local scope)+newtype NestedScope =+   NestedScope (Map.Map ScopeIdentifier (String, LocalScope))+   deriving Show++data Dumpable = DumpScope | DumpAST+   deriving (Eq, Ord, Show)++data AnnotatedCode+   = AnnotatedCode +     { annotatedCode_bytecode :: Bytecode+     , annotatedCode_labels :: ![Word16]   -- instruction can be labelled zero or more times+     , annotatedCode_index :: !Word16 }    -- byte offset of the instruction within this sequence of bytecode+   deriving Show++type Identifier = String -- a variable name++data CompileConfig =+   CompileConfig+   { compileConfig_magic :: Word32+   , compileConfig_dumps :: Set Dumpable+   }+   deriving (Eq, Show)++type ConstantID = Word16+type ConstantCache = Map.Map PyObject ConstantID ++data CompileState = CompileState+   { state_config :: CompileConfig+   , state_blockState :: BlockState+   , state_filename :: FilePath+   , state_nestedScope :: NestedScope+   }++-- Map from Label to Instruction offset.+-- The same instruction can be labelled multiple times,+-- but each label is attached to exactly one instruction.+type LabelMap = Map.Map Word16 Word16++type VarIndex = Word16+type IndexedVarSet = Map.Map Identifier VarIndex++data BlockState = BlockState +   { state_label :: !Word16+   , state_instructions :: [AnnotatedCode]+   , state_labelNextInstruction :: [Word16] -- zero or more labels for the next instruction+   , state_constants :: [PyObject] +   , state_constantCache :: ConstantCache+   , state_nextConstantID :: !ConstantID+   , state_names :: [Identifier]+   , state_nameCache :: IndexedVarSet+   , state_nextNameID :: !VarIndex+   , state_objectName :: String+   , state_instruction_index :: !Word16+   , state_labelMap :: LabelMap+   , state_locals :: VarSet+   , state_fastLocals :: IndexedVarSet+   , state_freeVars :: IndexedVarSet+   , state_cellVars :: IndexedVarSet+   , state_explicitGlobals :: VarSet+   , state_argcount :: !Word32+   , state_flags :: !Word32+   , state_frameBlockStack :: [FrameBlockInfo]+   , state_context :: !Context+   , state_lineNumber :: !Word32+   , state_lineNumberTable :: ![(Word16, Word32)] -- mapping from bytecode offset to source line number+   , state_firstLineNumber :: !Word32+   }+   deriving (Show)++data FrameBlockInfo+   = FrameBlockLoop !Word16+   | FrameBlockExcept +   | FrameBlockFinallyTry +   | FrameBlockFinallyEnd+   deriving (Eq, Show)

@@ -0,0 +1,208 @@+{-# LANGUAGE RecordWildCards #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Utils+-- Copyright   : (c) 2012, 2013 Bernie Pope+-- License     : BSD-style+-- Maintainer  : florbitous@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Utility functions which are used in multiple modules, or don't belong+-- anywhere else.+--+-----------------------------------------------------------------------------+module Utils+   ( isJump, isRelativeJump, isAbsoluteJump, isJumpBytecode, isPureExpr+   , isPyObjectExpr, isUnconditionalJump, isConditionalJump, mkVar, mkReturn+   , mkIdent, mkAssign, mkAssignVar, mkList, mkMethodCall, mkStmtExpr, mkSet+   , mkDict , mkSubscript, mkYield, identsFromParameters+   , spanToScopeIdentifier, fromIdentString, countPosParameters+   , maybeToList, getSpanLine )+   where ++import Blip.Bytecode (Opcode (..), Bytecode (..))+import Language.Python.Common.AST as AST+   ( ExprSpan, Expr (..), Statement (..), StatementSpan, Ident (..)+   , IdentSpan, Op (..), OpSpan, Argument (..), ArgumentSpan )+import Language.Python.Common.SrcLocation (SrcSpan (..))+import Types (Identifier, ScopeIdentifier, ParameterTypes (..))++getSpanLine :: SrcSpan -> Maybe Int+getSpanLine (SpanCoLinear {..}) = Just span_row+getSpanLine (SpanMultiLine {..}) = Just span_start_row+getSpanLine (SpanPoint {..}) = Just span_row+getSpanLine SpanEmpty = Nothing++maybeToList :: Maybe a -> [a]+maybeToList Nothing = []+maybeToList (Just x) = [x]++fromIdentString :: AST.Ident a -> Identifier+fromIdentString (Ident {..}) = ident_string++spanToScopeIdentifier :: SrcSpan -> ScopeIdentifier+spanToScopeIdentifier (SpanCoLinear {..})+   = (span_row, span_start_column, span_row, span_end_column)+spanToScopeIdentifier (SpanMultiLine {..})+   = (span_start_row, span_start_column, span_end_row, span_end_column)+spanToScopeIdentifier (SpanPoint {..})+   = (span_row, span_column, span_row, span_column)+spanToScopeIdentifier SpanEmpty+   = error "empty source span for scope identifier"++identsFromParameters :: ParameterTypes -> [Identifier]+identsFromParameters (ParameterTypes {..}) =+   parameterTypes_pos ++ maybeToList parameterTypes_varPos +++   maybeToList parameterTypes_varKeyword+{-+identsFromParameters :: [ParameterSpan] -> [Identifier]+identsFromParameters = concatMap getIdent+   where+   getIdent :: ParameterSpan -> [Identifier]+   getIdent (Param {..}) = [fromIdentString $ param_name]+   getIdent (VarArgsPos {..}) = [fromIdentString $ param_name]+   getIdent (VarArgsKeyword {..}) = [fromIdentString $ param_name]+   getIdent _other = []+-}++countPosParameters :: ParameterTypes -> Int+countPosParameters (ParameterTypes {..}) = length parameterTypes_pos+{-+countPosParameters :: [ParameterSpan] -> Int+countPosParameters = length . filter isPosParameter+   where+   isPosParameter :: ParameterSpan -> Bool+   isPosParameter (Param {}) = True+   isPosParameter _other = False +-}++-- True if an expression can be represented directly as a PyObject constant.+isPyObjectExpr :: ExprSpan -> Bool+isPyObjectExpr (AST.Int {}) = True+-- XXX not sure about longint+-- isPyObjectExpr (AST.LongInt {}) = True  +isPyObjectExpr (AST.Float {}) = True+-- XXX not sure about imaginary+-- isPyObjectExpr (AST.Imaginary {}) = True+isPyObjectExpr (AST.Bool {}) = True+isPyObjectExpr (AST.None {}) = True+isPyObjectExpr (AST.ByteStrings {}) = True+isPyObjectExpr (AST.Strings {}) = True+isPyObjectExpr (AST.UnicodeStrings {}) = True+isPyObjectExpr (AST.Tuple { tuple_exprs = exprs }) = all isPyObjectExpr exprs+isPyObjectExpr _other = False++-- True if evaluating an expression has no observable side effect+-- Raising an exception is a side-effect, so variables are not pure.+isPureExpr :: ExprSpan -> Bool+isPureExpr (AST.Int {}) = True+isPureExpr (AST.LongInt {}) = True+isPureExpr (AST.Float {}) = True+isPureExpr (AST.Imaginary {}) = True+isPureExpr (AST.Bool {}) = True+isPureExpr (AST.None {}) = True+isPureExpr (AST.ByteStrings {}) = True+isPureExpr (AST.Strings {}) = True+isPureExpr (AST.UnicodeStrings {}) = True+isPureExpr (AST.Tuple { tuple_exprs = exprs }) = all isPureExpr exprs+isPureExpr (AST.List { list_exprs = exprs }) = all isPureExpr exprs+isPureExpr (AST.Set { set_exprs = exprs }) = all isPureExpr exprs+isPureExpr (AST.Paren { paren_expr = expr }) = isPureExpr expr+isPureExpr (AST.Dictionary { dict_mappings = mappings }) =+   all (\(e1, e2) -> isPureExpr e1 && isPureExpr e2) mappings+-- XXX what about Lambda?+isPureExpr _other = False++isJumpBytecode :: Bytecode -> Bool+isJumpBytecode (Bytecode {..}) = isJump opcode++-- test if an opcode is a jump instruction+isJump :: Opcode -> Bool+isJump x = isRelativeJump x || isAbsoluteJump x++isRelativeJump :: Opcode -> Bool+isRelativeJump JUMP_FORWARD = True+isRelativeJump SETUP_LOOP = True+isRelativeJump FOR_ITER = True+isRelativeJump SETUP_FINALLY = True+isRelativeJump SETUP_EXCEPT = True+isRelativeJump SETUP_WITH = True+isRelativeJump _ = False++isAbsoluteJump :: Opcode -> Bool+isAbsoluteJump POP_JUMP_IF_FALSE = True+isAbsoluteJump POP_JUMP_IF_TRUE = True+isAbsoluteJump JUMP_ABSOLUTE = True+isAbsoluteJump CONTINUE_LOOP = True+isAbsoluteJump JUMP_IF_FALSE_OR_POP = True+isAbsoluteJump JUMP_IF_TRUE_OR_POP = True+isAbsoluteJump _ = False++isUnconditionalJump :: Opcode -> Bool+isUnconditionalJump JUMP_FORWARD = True+isUnconditionalJump JUMP_ABSOLUTE = True+isUnconditionalJump _other = False++isConditionalJump :: Opcode -> Bool+isConditionalJump = not . isUnconditionalJump++mkIdent :: String -> IdentSpan+mkIdent str = Ident { ident_string = str, ident_annot = SpanEmpty }++mkReturn :: ExprSpan -> StatementSpan+mkReturn expr = Return { return_expr = Just expr, stmt_annot = SpanEmpty }++mkYield :: ExprSpan -> ExprSpan+mkYield expr = Yield { yield_expr = Just expr, expr_annot = SpanEmpty }++mkVar :: IdentSpan -> ExprSpan+mkVar ident = Var { var_ident = ident, expr_annot = SpanEmpty }++mkAssignVar :: IdentSpan -> ExprSpan -> StatementSpan+mkAssignVar ident expr = mkAssign (mkVar ident) expr++mkAssign :: ExprSpan -> ExprSpan -> StatementSpan+mkAssign lhs rhs =+   Assign { assign_to = [lhs]+          , assign_expr = rhs +          , stmt_annot = SpanEmpty }++mkList :: [ExprSpan] -> ExprSpan+mkList exprs = List { list_exprs = exprs, expr_annot = SpanEmpty }++mkSet :: [ExprSpan] -> ExprSpan+mkSet exprs = Set { set_exprs = exprs, expr_annot = SpanEmpty }++mkDict :: [(ExprSpan, ExprSpan)] -> ExprSpan+mkDict exprs = Dictionary { dict_mappings = exprs, expr_annot = SpanEmpty }++mkMethodCall :: ExprSpan -> String -> ExprSpan -> ExprSpan+mkMethodCall object methodName argument =+   mkCall (mkAttributeLookup object methodName) [argument]++mkAttributeLookup :: ExprSpan -> String -> ExprSpan+mkAttributeLookup object methodName =+   BinaryOp { operator = dot+            , left_op_arg = object+            , right_op_arg = mkVar (mkIdent methodName)+            , expr_annot = SpanEmpty }++dot :: OpSpan+dot = Dot { op_annot = SpanEmpty }++mkCall :: ExprSpan -> [ExprSpan] -> ExprSpan +mkCall fun args = +   Call { call_fun = fun+        , call_args = map mkArgument args+        , expr_annot = SpanEmpty }++mkArgument :: ExprSpan -> ArgumentSpan+mkArgument expr = ArgExpr { arg_expr = expr, arg_annot = SpanEmpty }++mkStmtExpr :: ExprSpan -> StatementSpan+mkStmtExpr expr = StmtExpr { stmt_expr = expr, stmt_annot = SpanEmpty }++mkSubscript :: ExprSpan -> ExprSpan -> ExprSpan+mkSubscript object index =+   Subscript { subscriptee = object, subscript_expr = index, expr_annot = SpanEmpty }