diff --git a/blip.cabal b/blip.cabal --- a/blip.cabal +++ b/blip.cabal @@ -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 } diff --git a/src/Assemble.hs b/src/Assemble.hs new file mode 100644 --- /dev/null +++ b/src/Assemble.hs @@ -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 } diff --git a/src/Compile.hs b/src/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Compile.hs @@ -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 "" + 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 "" 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 "" 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 "" initStmt updater returnStmt dict_comprehension +compileExpr (Generator {..}) = do + let updater = \expr -> mkStmtExpr $ mkYield expr + compileComprehension "" [] 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 "" 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 + [] + [] POP_BLOCK + [] JUMP_FORWARD L0 + + [tb, val, exc] L1: DUP ) + [tb, val, exc, exc] ) + [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] (or POP if no V1) + [tb] POP + [] + POP_EXCEPT + JUMP_FORWARD L0 + + [tb, val, exc] L2: DUP + .............................etc....................... + + [tb, val, exc] Ln+1: END_FINALLY # re-raise exception + + [] L0: + + 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 -- + 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: +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 -- + 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 -- + 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..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) diff --git a/src/Desugar.hs b/src/Desugar.hs new file mode 100644 --- /dev/null +++ b/src/Desugar.hs @@ -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 diff --git a/src/Monad.hs b/src/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Monad.hs @@ -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 diff --git a/src/ProgName.hs b/src/ProgName.hs new file mode 100644 --- /dev/null +++ b/src/ProgName.hs @@ -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" diff --git a/src/Scope.hs b/src/Scope.hs new file mode 100644 --- /dev/null +++ b/src/Scope.hs @@ -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) "" + +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) "" + +{- + 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 diff --git a/src/StackDepth.hs b/src/StackDepth.hs new file mode 100644 --- /dev/null +++ b/src/StackDepth.hs @@ -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 diff --git a/src/State.hs b/src/State.hs new file mode 100644 --- /dev/null +++ b/src/State.hs @@ -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 } diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -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) diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -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 }