diff --git a/Changes b/Changes new file mode 100644 --- /dev/null +++ b/Changes @@ -0,0 +1,3 @@ +[Changes for 0.0.1 - 2008-06-21] + +* Initial Hackage release. diff --git a/HsParrot.cabal b/HsParrot.cabal new file mode 100644 --- /dev/null +++ b/HsParrot.cabal @@ -0,0 +1,30 @@ +Name: HsParrot +Version: 0.0.1 +Category: Language, Pugs +Synopsis: Haskell integration with Parrot virtual machine +Description: Haskell integration with Parrot virtual machine + +-- License is really "MIT", but Cabal doesn't have that constant yet +License: BSD3 +License-File: LICENSE +Author: Audrey Tang +Maintainer: audreyt@audreyt.org +Copyright: Audrey Tang, 2008 + +Exposed-modules: Language.PIR +Other-modules: Language.PIR.Emit + +Build-Depends: pugs-DrIFT, + base, haskell98, bytestring>=0.9.0.1, pretty, HsSyck +Build-Type: Simple +Tested-With: GHC==6.8.2, GHC==6.8.3 + +Extensions: TypeSynonymInstances, OverlappingInstances, + ExistentialQuantification, MultiParamTypeClasses, + DeriveDataTypeable, FlexibleInstances, Rank2Types, + PatternGuards + +ghc-options: -F -pgmF pugs-DrIFT -optF-pgmF +data-files: Changes +hs-source-dirs: src + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,18 @@ +Copyright 2005, 2006, 2008 by Audrey Tang, Gaal Yahas + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to +deal in the Software without restriction, including without limitation the +rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +sell copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/src/Language/PIR.hs b/src/Language/PIR.hs new file mode 100644 --- /dev/null +++ b/src/Language/PIR.hs @@ -0,0 +1,983 @@ +{-| + Parrot PIR syntax tree. + +> All that is gold does not glitter, +> Not all those who wander are lost; +> The old that is strong does not wither, +> Deep roots are not reached by the frost. +-} + +module Language.PIR ( + module Language.PIR, + module Language.PIR.Emit, +) where +import Data.Char +import Data.List +import Data.Typeable +import DrIFT.YAML +import Text.PrettyPrint +import Language.PIR.Emit + +import Data.Yaml.Syck +import Control.Monad +{-! global : YAML !-} + +{-| PIR code consists of declarations. -} +type PIR = [Decl] + +data Decl + = DeclSub + { dsName :: !SubName + , dsFlags :: ![SubFlag] + , dsBody :: ![Stmt] + } -- ^ Subroutine declaration + | DeclNS + { dnPackage :: !PkgName + , dnBody :: ![Decl] + } -- ^ Namespace declaration + | DeclInc + { diFile :: !FilePath + } -- ^ @.include@ directive + | DeclHLL + { dhLang :: !String + , dhGroup :: !String + } -- ^ @HLL@ directive + deriving (Show, Eq, Typeable) + +data Stmt + = StmtComment !String -- ^ Comment + | StmtLine !FilePath !Int -- ^ @#line@ directive + | StmtPad ![(VarName, Expression)] ![Stmt] -- ^ Lexical Pad + | StmtRaw !Doc -- ^ Backdoor into raw @Doc@ + | StmtIns !Ins -- ^ Generic instructions + | StmtSub !SubName ![Stmt] -- ^ Inner subroutine + deriving (Show, Eq, Typeable) + +data Ins + = InsLocal !RegType !VarName -- ^ @.local@ directive + | InsNew !LValue !ObjType -- ^ @new@ opcode + | InsBind !LValue !Expression -- ^ @set@ opcode + | InsAssign !LValue !Expression -- ^ @assign@ opcode + | InsPrim !(Maybe LValue) !PrimName ![Expression] -- ^ Other opcodes + | InsFun ![Sig] !Expression ![Expression]-- ^ Function call + | InsTailFun !Expression ![Expression] -- ^ Tail call + | InsLabel !LabelName -- ^ Label + | InsComment !String !(Maybe Ins) -- ^ Comment + | InsExp !Expression -- ^ Generic expressions + | InsConst !LValue !ObjType !Expression -- ^ Constant + deriving (Show, Eq, Typeable) + +data Expression + = ExpLV !LValue -- ^ Variables + | ExpLit !Literal -- ^ Literals + deriving (Show, Eq, Typeable) + +data LValue + = VAR !VarName -- ^ A variable declared by @.local@ + | PMC !Int -- ^ PMC register /n/ + | STR !Int -- ^ String register /n/ + | INT !Int -- ^ Integer register /n/ + | NUM !Int -- ^ Number register /n/ + | KEYED !LValue !Expression + deriving (Show, Eq, Typeable) + +data Literal + = LitStr !String -- ^ A literal string + | LitInt !Integer -- ^ A literal integer + | LitNum !Double -- ^ A literal number + deriving (Show, Eq, Typeable) + +{-| Tags a PIR subroutine definition with @\@MAIN@, @\@LOAD@, @\@ANON@, + @\@METHOD@, or @\@MULTI@. -} +data SubFlag = SubMAIN | SubLOAD | SubANON | SubMETHOD | SubMULTI ![ObjType] | SubOUTER !SubName + deriving (Show, Eq, Typeable) + +data RegType + = RegInt -- ^ @I@ (Integer) register + | RegNum -- ^ @N@ (Number) register + | RegStr -- ^ @S@ (String) register + | RegPMC -- ^ @P@ (PMC) register + deriving (Show, Eq, Typeable) + +{-| A PMC type, which, for example, can be given as an argument to the @new@ + opcode (e.g. @new .PerlScalar@). -} +data ObjType + = PerlScalar | PerlArray | PerlHash + | PerlInt | PerlPair | PerlRef | PerlEnv + | Sub | Closure | Continuation + | BareType String + deriving (Show, Eq, Typeable) + +type LabelName = String +type SubName = String +type VarName = String +type PrimName = String +type PkgName = String +type CallConv = String + +{-| Emits PIR code for declarations (namespace, include, or sub declarations). -} +instance Emit Decl where + emit (DeclNS name decls) = vcat + [ emit ".namespace" <+> brackets (quotes $ emit name) + , emit decls + , emit ".namespace" <+> brackets (quotes $ emit "main") + ] + emit (DeclInc name) = emit ".include" <+> (quotes $ emit name) + emit (DeclHLL lang group) = emit ".HLL" <+> commaSep (map (quotes . text) [lang, group]) + -- Perform λ-lifting here + emit (DeclSub name styps stmts) + = (emit ".sub" <+> doubleQuotes (emit $ quoted name) <+> commaSep styps) + $+$ nested (emitStmts stmts) + $+$ emit ".end" + $+$ emit [DeclSub name' [SubANON, SubOUTER name] body' | StmtSub name' body' <- stmts ] + +emitStmts :: [Stmt] -> Doc +emitStmts stmts = vcat (emitLex:emitBody stmts) + where + emitBody [] = [] + emitBody [(StmtIns (InsFun _ name args))] = [emit $ StmtIns (InsTailFun name args)] + emitBody (x:xs) = emit x : emitBody xs + emitLex = vcat (map emitVar $ nub (concat [ pad | StmtPad pad _ <- stmts ])) + emitVar :: (VarName, Expression) -> Doc + emitVar (var, exp@(ExpLV (VAR name))) + = emit (InsLocal RegPMC name) + $+$ emit ".lex" <+> commaSep [emit (lit var), emit exp] + emitVar _ = empty + +{-| Emits PIR code for a 'SubFlag' (e.g. @:main@, @:anon@, etc.). -} +instance Emit SubFlag where + emit (SubOUTER x) = colon <> text "outer" <> parens (doubleQuotes $ emit x) + emit x = (emit . (':':) . map toLower . drop 3 . show) x + +curPad :: Int +curPad = -1 + +instance Emit Stmt where + emit (StmtComment []) = empty + emit (StmtComment str) = vcat [ emit "###" <+> emit line | line <- lines str ] + emit (StmtLine file line) = text "#line" <+> doubleQuotes (emit file) <+> emit line + emit (StmtIns ins) = emit ins + emit (StmtPad pad _) = vcat $ + map (\(var, exp) -> emit ("store_lex" .- [lit var, exp])) pad + {- + [ emit "new_pad" <+> int curPad + ] ++ + -} + emit (StmtRaw doc) = doc + emit StmtSub{} = empty + +instance Emit RegType where + emit = emit . map toLower . drop 3 . show + +instance Emit Ins where + emit (InsLocal rtyp name) = emit ".local" <+> emit rtyp <+> emit name + emit (InsNew ident otyp) = eqSep ident "new" [otyp] + emit (InsAssign ident@(KEYED _ _) lit) = eqSep ident "" [lit] -- XXX questionable + emit (InsAssign ident lit) = eqSep ident "assign" [lit] + emit (InsBind ident@(KEYED _ _) lit) = eqSep ident "" [lit] -- XXX questionable + emit (InsBind ident lit) = eqSep ident "set" [lit] + emit (InsPrim (Just ret) name args) = eqSep ret name args +-- emit (InsPrim Nothing "store_lex" (_:args)) = +-- -- XXX - horrible hack! perl 4! +-- emit (InsPrim Nothing "store_global" args) + emit (InsPrim Nothing name args) = emit name <+> commaSep args + emit (InsFun rets (ExpLit (LitStr name)) args) = emitFunName "invokecc" name args rets + emit (InsFun rets fun args) = emitFun "invokecc" fun args rets + emit (InsTailFun (ExpLit (LitStr name)) args) = emitFunName "tailcall" name args [] + emit (InsTailFun fun args) = emitFun "tailcall" fun args [] + emit (InsExp _) = empty + emit (InsConst ident rtyp lit) = + emit ".const" <+> emit rtyp <+> emit ident <+> equals <+> emit lit + emit (InsLabel label) = nest (-2) (emit label <> colon) + emit (InsComment comment ins) = emit (StmtComment comment) $+$ emit ins + +emitRets :: [Sig] -> Doc +emitRets [] = empty +emitRets rets = emit ("get_results" .- sigList rets) + +emitFun :: (Emit b, Emit c) => CallConv -> b -> [c] -> [Sig] -> Doc +emitFun callconv fun args rets = emitArgs args + $+$ emitRets rets + $+$ emit callconv <+> emit fun + +emitArgs :: (Emit a) => [a] -> Doc +emitArgs args = emit "set_args" <+> commaSep (sig:map emit args) + where + sig = quotes $ parens (commaSep (replicate (length args) maybeFlatten)) + +emitFunName :: Emit b => CallConv -> String -> [b] -> [Sig] -> Doc +emitFunName callconv name args rets = eqSep (funPMC :: LValue) "find_name" [LitStr name] + $+$ emitFun callconv (funPMC :: LValue) args rets + +noArgs :: [Expression] +noArgs = [] + +{-| Emits PIR code for an 'ObjType' (e.g. @.PerlScalar@). -} +instance Emit ObjType where + emit PerlScalar = emit ".PerlUndef" -- XXX special case + emit PerlPair = emit ".Pair" -- XXX special case + emit PerlRef = emit ".Ref" -- XXX special case + emit (BareType x) = text $ ('.':x) + emit x = emit . ('.':) . show $ x + +instance Emit Expression where + emit (ExpLV lhs) = emit lhs + emit (ExpLit lit) = emit lit + +instance Emit LValue where + emit (VAR name) = emit name + emit (PMC num) = emit "$P" <> emit num + emit (STR str) = emit "$S" <> emit str + emit (INT str) = emit "$I" <> emit str + emit (NUM str) = emit "$N" <> emit str + emit (KEYED pmc idx) = emit pmc <> brackets (emit idx) + +{-| Emits a literal (a 'LitStr', 'LitInt', or 'LitNum'), and escapes if + necessary. -} +instance Emit Literal where + emit (LitStr str) = text . show $ quoted str + emit (LitInt int) = integer int + emit (LitNum num) = double num + +expKeyed :: LValue -> Expression -> Expression +expKeyed = (ExpLV .) . KEYED + +quoted :: String -> String +quoted = concatMap quote + where + quote :: Char -> String + quote '\\' = "\\\\" + quote x = [x] + +infixl 4 <-- +infixl 9 --> +infixl 4 .- +infixl 4 <-& +infixl 4 .& + +{-| @.include@ directive. -} +include :: PkgName -> Decl +{-| @.HLL@ directive. -} +hll :: String -> String -> Decl +{-| Short for 'InsBind' (binding). -} +(<:=) :: LValue -> Expression -> Ins +{-| Short for 'InsAssign'. -} +(<==) :: LValue -> Expression -> Ins +{-| Calls an opcode which returns a value. -} +(<--) :: LValue -> PrimName -> [Expression] -> Ins +{-| Calls an opcode, ignoring any return values. -} +(.-) :: PrimName -> [Expression] -> Ins +{-| Calls an user-defined sub which returns a list of values. -} +(<-&) :: [Sig] -> Expression -> [Expression] -> Ins +{-| Calls an user-defined sub, ignoring any return values. -} +(.&) :: Expression -> [Expression] -> Ins + +include = DeclInc +hll = DeclHLL + +(<:=) = InsBind +(<==) = InsAssign +(<--) = InsPrim . Just +(.-) = InsPrim Nothing +(<-&) = InsFun +(.&) = InsFun [] + +{-| Literal zero -} +lit0 :: Expression +lit0 = lit (0 :: Int) + +{-| @$P0@ register -} +nullPMC :: (RegClass a) => a +nullPMC = reg $ PMC 0 + +{-| @$P1@ register -} +funPMC :: (RegClass a) => a +funPMC = reg $ PMC 1 + +{-| @$P2@ register -} +rv :: (RegClass a) => a +rv = reg $ PMC 2 + +{-| @$P10@ register -} +arg0 :: (RegClass a) => a +arg0 = reg $ PMC 10 + +{-| @$P11@ register -} +arg1 :: (RegClass a) => a +arg1 = reg $ PMC 11 + +{-| @$P12@ register -} +arg2 :: (RegClass a) => a +arg2 = reg $ PMC 12 + +{-| @$P13@ register -} +arg3 :: (RegClass a) => a +arg3 = reg $ PMC 13 + +{-| @$P8@ register -} +tempPMC :: (RegClass a) => a +tempPMC = reg $ PMC 8 + +{-| @$P9@ register -} +tempPMC2 :: (RegClass a) => a +tempPMC2 = reg $ PMC 9 + +{-| @$S8@ register -} +tempSTR :: (RegClass a) => a +tempSTR = reg $ STR 8 + +{-| @$S9@ register -} +tempSTR2 :: (RegClass a) => a +tempSTR2 = reg $ STR 9 + +{-| @$S10@ register -} +tempSTR3 :: (RegClass a) => a +tempSTR3 = reg $ STR 10 + +{-| @$I8@ register -} +tempINT :: (RegClass a) => a +tempINT = reg $ INT 8 + +{-| @$I9@ register -} +tempINT2 :: (RegClass a) => a +tempINT2 = reg $ INT 9 + +{-| @$I10@ register -} +tempINT3 :: (RegClass a) => a +tempINT3 = reg $ INT 10 + +{-| @$I11@ register -} +tempINT4 :: (RegClass a) => a +tempINT4 = reg $ INT 11 + +{-| @$N8@ register -} +tempNUM :: (RegClass a) => a +tempNUM = reg $ NUM 8 + +{-| @$N9@ register -} +tempNUM2 :: (RegClass a) => a +tempNUM2 = reg $ NUM 9 + +class RegClass y where + reg :: LValue -> y + +instance RegClass LValue where + reg = id + +instance RegClass Expression where + reg = ExpLV + +instance RegClass Sig where + reg = MkSig [] . ExpLV + +class LiteralClass x where + -- type LitOf x + lit :: x -> Expression + +instance LiteralClass [[ArgFlag]] where + lit = lit . parens . commaSep . map emit + +instance LiteralClass [ArgFlag] where + lit = lit . emit + +instance LiteralClass ObjType where + lit = ExpLV . VAR . render . emit + +instance LiteralClass Doc where + lit = lit . render + +instance LiteralClass String where + lit = ExpLit . LitStr + +instance LiteralClass Int where + lit = ExpLit . LitInt . toInteger + +instance LiteralClass Bool where + lit False = ExpLit $ LitInt 0 + lit True = ExpLit $ LitInt 1 + +instance LiteralClass Double where + lit = ExpLit . LitNum + +{-| Subroutine declaration. -} +sub :: SubName -- ^ Name of the subroutine + -> [Sig] -- ^ Signature + -> [Ins] -- ^ Subroutine body + -> Decl -- ^ The final subroutine declaration +sub name [] body = DeclSub name [] (map StmtIns body) +sub name sigs body = DeclSub name [] stmts + where + param = "get_params" .- sigList sigs + stmts = map StmtIns (param:body) + +sigList :: [Sig] -> [Expression] +sigList sigs = (flags:map sigIdent sigs) + where + flags = lit . render . parens . commaSep $ map sigFlags sigs + +instance Emit [ArgFlag] where + emit = emit . sum . map argVal + +data Sig = MkSig + { sigFlags :: [ArgFlag] + , sigIdent :: Expression + } + deriving (Show, Eq, Typeable) + +data ArgFlag + = MkArgFlatten | MkArgSlurpyArray + | MkArgMaybeFlatten | MkArgOptional + deriving (Show, Eq, Typeable) + +argVal :: ArgFlag -> Int +argVal MkArgFlatten = 0x20 +argVal MkArgSlurpyArray = 0x20 +argVal MkArgMaybeFlatten = 0x40 +argVal MkArgOptional = 0x80 + +maybeFlatten :: Doc +maybeFlatten = emit [MkArgMaybeFlatten] + +{-| Marks a parameter as slurpy. -} +slurpy :: Expression -> Sig +slurpy = MkSig [MkArgSlurpyArray] + +{-| Returns from a sub. -} +(-->) :: Decl -> [Expression] -> Decl +(DeclSub name styps stmts) --> rets = DeclSub name styps $ stmts ++ map StmtIns + [ "set_returns" .- retSigList rets + , "returncc" .- [] + ] +_ --> _ = error "Can't return from non-sub" + +retSigList :: [Expression] -> [Expression] +retSigList rets = (lit sig : rets) + where + sig = parens (commaSep (replicate (length rets) maybeFlatten)) + +{-| In the case a Perl 6 builtin corresponds exactly to a PIR opcode, you can + use 'vop1' to create an appropriate wrapper for an opcode expecting /one/ + argument. -} +vop1 :: SubName -- ^ Perl 6 name of the opcode to wrap + -> PrimName -- ^ PIR opcode + -> Decl -- ^ Final subroutine declaration +vop1 p6name opname = + sub p6name [arg0] + [ InsNew rv PerlScalar + , rv <-- opname $ [arg0] + ] --> [rv] +{-| In the case a Perl 6 builtin corresponds exactly to a PIR opcode, you can + use 'vop2' to create an appropriate wrapper for an opcode expecting /two/ + arguments. -} +vop2 :: SubName -- ^ Perl 6 name of the opcode to wrap + -> PrimName -- ^ PIR opcode + -> Decl -- ^ Final subroutine declaration +vop2 p6name opname = + sub p6name [arg0, arg1] + [ InsNew rv PerlScalar + , rv <-- opname $ [arg0, arg1] + ] --> [rv] + +{-| Creates a sub which accepts a thing which allows keyed access (for + example aggregates) and an index. -} +vop2keyed :: SubName -- ^ Perl 6 name of the sub to create + -> LValue -- ^ Intermediate register to convert the index to + -- (e.g. 'tempINT' or 'tempSTR') + -> Decl -- ^ Final subroutine declaration +vop2keyed p6name temp = + sub p6name [arg0, arg1] + [ temp <:= arg1 + , rv <:= expKeyed arg0 (ExpLV temp) + ] --> [rv] + +{-| Generic wrapper for unary opcodes. -} +--vop1x :: (RegClass a, RegClass b) => SubName -> PrimName -> a -> b -> Decl +vop1x :: SubName -- ^ Perl 6 name of the sub to create + -> PrimName -- ^ Opcode to wrap + -> (forall a. RegClass a => a) -- ^ Register to use for the return value + -- of the op + -> (forall b. RegClass b => b) -- ^ Register type to convert the + -- parameter to + -> Decl -- ^ Final subroutine declaration +vop1x p6name opname regr reg0 = + sub p6name [arg0] + [ InsNew rv PerlScalar + , reg0 <:= arg0 + , regr <-- opname $ [reg0] + , rv <== regr + ] --> [rv] + +{-| Generic wrapper for coercion\/context forcing (used by @&prefix:\<\+\>@, + @&prefix:\<\~\>@, etc.) -} +vop1coerce :: SubName -- ^ Perl 6 name of the sub to create + -> (forall a. RegClass a => a) -- ^ Register type to convert the + -- parameter to + -> Decl -- ^ Final subroutine declaration +vop1coerce p6name reg0 = + sub p6name [arg0] + [ InsNew rv PerlScalar + , reg0 <:= arg0 + , rv <:= reg0 + ] --> [rv] + +{-| Generic wrapper for two-ary opcodes. -} +vop2x :: SubName -- ^ Perl 6 name of the sub to create + -> PrimName -- ^ Opcode to wrap + -> (forall a. RegClass a => a) -- ^ Register to use for the return value + -- of the op + -> (forall b. RegClass b => b) -- ^ Register type to convert the + -- first parameter to + -> (forall c. RegClass c => c) -- ^ Register type to convert the + -- second parameter to + -> Decl -- ^ Final subroutine declaration +vop2x p6name opname regr reg0 reg1 = + sub p6name [arg0, arg1] + [ InsNew rv PerlScalar + , reg0 <:= arg0 + , reg1 <:= arg1 + , regr <-- opname $ [reg0,reg1] + , rv <== regr + ] --> [rv] + +{-| Wrapper for an opcode which accepts and returns an @I@ register. -} +vop1ii :: SubName -> PrimName -> Decl +vop1ii p6name opname = vop1x p6name opname tempINT tempINT +{-| Wrapper for an opcode which accepts and returns a @N@ register. -} +vop1nn :: SubName -> PrimName -> Decl +vop1nn p6name opname = vop1x p6name opname tempNUM tempNUM +{-| Wrapper for an opcode which accepts and returns a @S@ register. -} +vop1ss :: SubName -> PrimName -> Decl +vop1ss p6name opname = vop1x p6name opname tempSTR tempSTR +{-| Wrapper for an opcode which returns a @S@ register and accepts a @I@ register. -} +vop1si :: SubName -> PrimName -> Decl +vop1si p6name opname = vop1x p6name opname tempSTR tempINT +{-| Wrapper for an opcode which returns a @I@ register and accepts a @S@ register. -} +vop1is :: SubName -> PrimName -> Decl +vop1is p6name opname = vop1x p6name opname tempINT tempSTR +{-| Wrapper for an opcode which returns a @I@ register and accepts a @P@ register. -} +vop1ip :: SubName -> PrimName -> Decl +vop1ip p6name opname = vop1x p6name opname tempINT tempPMC + +{-| Wrapper for an opcode which accepts and returns @I@ registers. -} +vop2iii :: SubName -> PrimName -> Decl +vop2iii p6name opname = vop2x p6name opname tempINT tempINT tempINT2 +{-| Wrapper for an opcode which accepts and returns @N@ registers. -} +vop2nnn :: SubName -> PrimName -> Decl +vop2nnn p6name opname = vop2x p6name opname tempNUM tempNUM tempNUM2 +{-| Wrapper for an opcode which accepts two @S@ registers and returns a native + integer (@I@ register). -} +vop2iss :: SubName -> PrimName -> Decl +vop2iss p6name opname = vop2x p6name opname tempINT tempSTR tempSTR2 + +bare :: VarName -> Expression +bare = ExpLV . VAR + +collectCC :: [Ins] +collectCC = + [ "set_returns" .- retSigList [tempPMC] + , "returncc" .- [] + ] + +callThunkCC :: Expression -> [Ins] +callThunkCC fun = + [ "set_args" .- sigList [] + , "get_results" .- sigList [tempPMC] + , "invokecc" .- [fun] + ] + +{-| Creates appropriate @&statement_control:foo@ subroutines. -} +stmtControlLoop :: VarName -- ^ Perl 6 name of the new sub + -> PrimName -- ^ PIR opcode to use for branching + -> Decl -- ^ Final declaration of the sub +stmtControlLoop name comp = sub ("&statement_control:" ++ name) [arg0, arg1] $ + if isPost then ["goto" .- [bare redoL]] else [] ++ + [ InsLabel nextL + , [reg tempPMC] <-& arg0 $ [] + , comp .- [tempPMC, bare lastL] + , InsLabel redoL + , arg1 .& [] + , "goto" .- [bare nextL] + , InsLabel lastL + , "returncc" .- [] + ] + where + nextL = ("sc_" ++ name ++ "_next") + lastL = ("sc_" ++ name ++ "_last") + redoL = ("sc_" ++ name ++ "_redo") + isPost = "post" `isPrefixOf` name + +{-| Creates appropriate @&statement_control:foo@ subroutines. -} +stmtControlCond :: VarName -- ^ Perl 6 name of the new sub + -> PrimName -- ^ PIR opcode to use for branching + -> Decl -- ^ Final declaration of the sub +stmtControlCond name comp = + sub ("&statement_control:" ++ name) [arg0, arg1, arg2] body --> [tempPMC] + where + altL = ("sc_" ++ name ++ "_alt") + postL = ("sc_" ++ name ++ "_post") + body = concat + [ [ comp .- [arg0, bare altL] ] + , callThunkCC arg1 + , [ "goto" .- [bare postL] ] + , [ InsLabel altL ] + , callThunkCC arg2 + , [ InsLabel postL ] + , collectCC + ] + +{-| Creates appropriate @&infix:foo@ subs for logical operators (@||@, @&&@, + etc.). -} +op2Logical :: VarName -- ^ Perl 6 name of the sub to create + -> PrimName -- ^ PIR opcode to use (@if@, @unless@) + -> Decl -- ^ Final declaration of the sub +op2Logical name comp = sub ("&infix:" ++ name) [arg0, arg1] body --> [tempPMC] + where + altL = ("sc_" ++ escaped name ++ "_alt") + body = + [ comp .- [arg0, bare altL] + , "set_returns" .- retSigList [arg0] + , "returncc" .- [] + , InsLabel altL + ] ++ callThunkCC arg1 ++ collectCC + +{-| Escapes characters which have a special meaning in PIR. -} +escaped :: String -> String +escaped = concatMap esc + where + esc :: Char -> String + esc c | isAlphaNum c = [c] + esc c = ('_':show (ord c)) + +{-| The Prelude, defining primitives like @&say@, @&infix:+@, etc. -} +preludePIR :: Doc +preludePIR = emit $ + [ hll "Perl" "perl_group" + , include "iglobals.pasm" + , include "errors.pasm" + -- Control flowy + , sub "&return" [slurpy arg0] + [ InsNew tempPMC PerlArray + , (tempPMC `KEYED` lit False) <:= arg0 + , "throw" .- [tempPMC] + ] + , sub "&leave" [slurpy arg0] + [] --> [arg0] + , sub "&statement_control:for" [arg0, arg1] + [ tempPMC <-- "iter" $ [arg0] + , InsLabel "sc_for_next" + , "unless" .- [tempPMC, bare "sc_for_last"] + , tempPMC2 <-- "shift" $ [tempPMC] + , arg1 .& [tempPMC2] + , "goto" .- [bare "sc_for_next"] + , InsLabel "sc_for_last" + , "returncc" .- [] + ] + , sub "&statement_control:loop" [arg0, arg1, arg2, arg3] + [ InsLabel "sc_loop_next" + , [reg tempPMC] <-& arg1 $ [] + , "unless" .- [tempPMC, bare "sc_loop_last"] + , arg2 .& [] -- throw away the result of body... + , arg3 .& [] -- ...and the post-condition + , "goto" .- [bare "sc_loop_next"] + , InsLabel "sc_loop_last" + , "returncc" .- [] + ] + , stmtControlLoop "while" "unless" + , stmtControlLoop "until" "if" + , stmtControlCond "if" "unless" + , stmtControlCond "unless" "if" + , op2Logical "&&" "if" + , op2Logical "||" "unless" + , op2Logical "and" "if" + , op2Logical "or" "unless" + , sub "¬hing" [] [] + + -- IO + , sub "&print" [slurpy arg0] + [ tempSTR <-- "join" $ [lit "", arg0] + , "print" .- [tempSTR] + ] --> [lit True] + , sub "&say" [slurpy arg0] + [ tempSTR <-- "join" $ [lit "", arg0] + , "print" .- [tempSTR] + , "print" .- [lit "\n"] + ] --> [lit True] + , vop1is "&system" "spawnw" + + -- Operators + , sub "&infix:," [slurpy arg0] + [] --> [arg0] + , sub "&circumfix:[]" [slurpy arg0] + [ InsNew rv PerlScalar + , InsNew tempPMC PerlArray + , tempPMC <== arg0 + , tempPMC2 <-- "new" $ [lit PerlRef, tempPMC] + , rv <== tempPMC2 + ] --> [rv] + , sub "&prefix:++" [arg0] + [ "inc" .- [arg0] + ] --> [arg0] + , sub "&prefix:--" [arg0] + [ "dec" .- [arg0] + ] --> [arg0] + , sub "&postfix:++" [arg0] + [ InsNew rv PerlScalar + , rv <== arg0 + , "inc" .- [arg0] + ] --> [rv] + , sub "&postfix:--" [arg0] + [ InsNew rv PerlScalar + , rv <== arg0 + , "dec" .- [arg0] + ] --> [rv] + , sub "&prefix:-" [arg0] + [ InsNew rv PerlScalar + , rv <-- "neg" $ [arg0] + ] --> [rv] + , vop2 "&infix:+" "add" + , vop2 "&infix:-" "sub" + , vop2 "&infix:*" "mul" + , vop2 "&infix:/" "div" + , vop2 "&infix:%" "mod" + , vop2 "&infix:~" "concat" + , vop1 "&prefix:!" "not" + , vop1 "¬" "not" + , vop2iii "&infix:<" "islt" + , vop2iii "&infix:<=" "isle" + , vop2iii "&infix:>" "isgt" + , vop2iii "&infix:>=" "isge" + , vop2iii "&infix:==" "iseq" + , vop2iii "&infix:!=" "isne" + , vop2iss "&infix:lt" "islt" + , vop2iss "&infix:le" "isle" + , vop2iss "&infix:gt" "isgt" + , vop2iss "&infix:gt" "isge" + , vop2iss "&infix:eq" "iseq" + , vop2iss "&infix:ne" "isne" + , vop1 "&prefix:?^" "bnot" + , vop2keyed "&postcircumfix:{}" tempSTR + , vop2keyed "&postcircumfix:[]" tempINT + , vop1coerce "&prefix:+" tempNUM + , vop1coerce "&prefix:~" tempSTR + , vop1coerce "&int" tempINT + , sub "&true" [arg0] + [ InsNew rv PerlScalar + , rv <:= (ExpLit . LitInt) 1 + , "if" .- [arg0, bare "true_pmc_is_true"] + , rv <:= (ExpLit . LitInt) 0 + , InsLabel "true_pmc_is_true" + ] --> [rv] + + -- Strings + , vop1is "&chars" "length" + , vop1is "&bytes" "bytelength" + , sub "&prefix:\\" [arg0] + [ tempPMC <-- "new" $ [lit PerlRef, arg0] + ] --> [rv] + , sub "&infix:=>" [arg0, arg1] + [ InsNew rv PerlPair + , rv `KEYED` arg0 <:= arg1 + ] --> [rv] + , sub "&infix:.." [arg0, arg1] + [ tempINT <:= arg0 + , InsNew rv PerlArray + , InsLabel "range_next" + , "lt_num" .- [arg1, tempINT, bare "range_end"] + , "push" .- [rv, tempINT] + , "inc" .- [tempINT] + , "goto" .- [bare "range_next"] + , InsLabel "range_end" + ] --> [rv] + , sub "&substr" [arg0, arg1, arg2] + [ tempSTR <:= arg0 + , tempINT <:= arg1 + , tempINT2 <:= arg2 + , tempSTR2 <-- "substr" $ [tempSTR, tempINT, tempINT2] + , InsNew rv PerlScalar + , rv <:= tempSTR2 + ] --> [rv] + , vop1si "&chr" "chr" + , vop1is "&ord" "ord" + , vop2x "&infix:x" "repeat" tempSTR tempSTR tempINT + , vop1ss "&lc" "downcase" + , vop1ss "&uc" "upcase" + + -- Objects + , sub "&undef" [] + [ InsNew rv PerlScalar + ] --> [rv] + , sub "&undefine" [arg0] + [ InsNew tempPMC PerlScalar + , arg0 <== tempPMC + ] --> [arg0] + , vop1ip "&defined" "defined" +{- XXX saying hash +-- causes error:imcc:syntax error, unexpected IREG, expecting '(' + , sub "&id" [arg0] + [ InsNew rv PerlScalar + , tempINT <-- "hash" $ [arg0] + , rv <== tempINT + ] --> [rv] +-} + , vop1 "&clone" "clone" + + -- Aggregates + , sub "&pop" [arg0] + [ rv <-- "pop" $ [arg0] + ] --> [rv] + , sub "&push" [arg0, arg1] + [ "push" .- [arg0, arg1] + ] --> [lit True] + , sub "&delete" [arg0, arg1] + [ rv <:= expKeyed arg0 arg1 + , "delete" .- [expKeyed arg0 arg1] + ] --> [rv] + , sub "&exists" [arg0, arg1] + [ tempINT <-- "exists" $ [expKeyed arg0 arg1] + , InsNew rv PerlScalar + , rv <:= tempINT + ] --> [rv] + , sub "&join" [arg0, arg1] + [ InsNew rv PerlScalar + , tempSTR <:= arg0 + , tempSTR2 <-- "join" $ [tempSTR, arg1] + , rv <== tempSTR2 + ] --> [rv] + + , DeclNS "Perl6::Internals" + [ sub "&symbolic_deref" [arg0, slurpy arg1] + -- find_name($arg0 ~ join "::", @arg1) + [ tempSTR <-- "join" $ [lit "::", arg1] + , tempSTR2 <:= arg0 + , tempSTR <-- "concat" $ [tempSTR2, tempSTR] + -- XXX: Normalise tempSTR, i.e. "&infix:<+>" -> "&infix:+" + , rv <-- "find_name" $ [tempSTR] + ] --> [rv] + , sub "&exit" [arg0] + [ tempPMC <-- "find_global" $ [lit "main", lit "&*END"] + , "set_args" .- sigList [] + , "invokecc" .- [tempPMC] + , tempINT <:= arg0 + , "exit" .- [tempINT] + ] + , sub "&sleep" [arg0] + [ tempNUM <:= arg0 + , "sleep" .- [tempNUM] + ] + , sub "&compile_pir" [arg0] + [ tempSTR <:= arg0 + , tempPMC <-- "compreg" $ [lit "PIR"] + , tempPMC2 <-- "compile" $ [tempPMC, tempSTR] + ] --> [tempPMC2] + , sub "&eval_pir" [arg0] + [ tempPMC <-- "open" $ [lit "temp.pl", lit ">"] + , "print" .- [tempPMC, arg0] + , "close" .- [tempPMC] + , tempPMC <-- "open" $ [lit "pugs -CPIR temp.pl", lit "-|"] + , InsNew rv PerlScalar + , rv <:= lit "" + , InsLabel "eval_pir_read_pre_next" + , tempSTR <-- "readline" $ [tempPMC] + , "ne" .- [tempSTR, lit ".sub \"init\" :main :anon\n", bare "eval_pir_read_pre_next"] + , InsLabel "eval_pir_read_next" + , tempSTR <-- "readline" $ [tempPMC] + , "eq" .- [tempSTR, lit ".end\n", bare "eval_pir_done"] + , rv <-- "concat" $ [tempSTR] + , "if" .- [tempPMC, bare "eval_pir_read_next"] -- hopefully this is never false + , InsLabel "eval_pir_done" + , "close" .- [tempPMC] + ] --> [rv] + ] + + -- Supporting Math::Basic + , sub "&abs" [arg0] + [ InsNew rv PerlScalar + , rv <== arg0 + , "abs" .- [arg0] + ] --> [rv] + , vop1nn "&exp" "exp" + , vop1nn "&ln" "ln" + , vop1nn "&log2" "log2" + , vop1nn "&log10" "log10" + -- also need: rand()? sign()? srand() ? S29 + , vop1nn "&sqrt" "sqrt" + -- Supporting Math::Trig + , vop1 "&sin" "sin" + , vop1 "&cos" "cos" -- works as vop1. but not sin(). sigh. + , vop1 "&tan" "tan" + , vop1 "&sec" "sec" + , vop1 "&asin" "asin" + , vop1 "&acos" "acos" + , vop1 "&atan" "atan" + , vop1 "&asec" "asec" + , vop1 "&sinh" "sinh" + , vop1 "&cosh" "cosh" + , vop1 "&tanh" "tanh" + , vop1 "&sech" "sech" + -- also need: cosec, cotan, acosec, acotan, asinh, acosh, atanh, cosech, + -- cotanh, asech, acosech, acotanh. S29 + + -- Supporting unspeced: + , vop1nn "&ceil" "ceil" + , vop1nn "&floor" "floor" + , vop1ii "&fact" "fact" + , vop2iii "&gcd" "gcd" + , vop2iii "&lcm" "lcm" + , vop2nnn "&pow" "pow" + -- parrot has no times() + , sub "&time" [] + [ InsNew rv PerlScalar + , tempNUM <-- "time" $ [] + , rv <:= tempNUM + -- Parrot's time returns seconds since 1970, but Perl 6's time + -- returns seconds since 2000, so we've to compensate. + , "sub" .- [rv, ExpLit . LitNum $ 946684800] + ] --> [rv] + + --, namespace "Str" + , sub "&split" [arg0, arg1] + [ InsNew rv PerlScalar + , tempSTR <:= arg0 + , tempSTR2 <:= arg1 + -- special case split("\n",...) to get Test.pm working + , "ne" .- [tempSTR, lit "\n", bare "split_normally"] + , InsNew rv PerlArray + , tempINT <:= (ExpLit . LitInt $ 0) + , tempINT4 <-- "length" $ [tempSTR] + , InsLabel "split_loop" + , tempINT2 <-- "index" $ [tempSTR2, tempSTR, tempINT] + , "lt" .- [tempINT2, ExpLit . LitInt $ 0, bare "split_last"] + , tempINT3 <-- "sub" $ [tempINT2, tempINT] + , tempSTR3 <-- "substr" $ [tempSTR2, tempINT, tempINT3] + , tempINT <-- "add" $ [tempINT2, tempINT4] + , "push" .- [rv, tempSTR3] + , "goto" .- [bare "split_loop"] + , InsLabel "split_last" + , tempSTR3 <-- "substr" $ [tempSTR2, tempINT] + , "push" .- [rv, tempSTR3] + , "goto" .- [bare "split_done"] + , InsLabel "split_normally" + -- end of special case + , tempPMC <-- "split" $ [tempSTR, tempSTR2] + , rv <== tempPMC + , InsLabel "split_done" + ] --> [rv] + + , sub "&True" [] + [] --> [lit True] + , sub "&False" [] + [] --> [lit False] + + --, namespace "bool" -- Namespaces have bugs in both pugs and parrot. + , sub "&Bool::True" [] + [] --> [lit True] + , sub "&Bool::False" [] + [] --> [lit False] + ] + +instance YAML Doc where + asYAML = asYAML . render +instance Typeable Doc where + typeOf _ = typeOf () + +------------------------------------------------------------------------ diff --git a/src/Language/PIR/Emit.hs b/src/Language/PIR/Emit.hs new file mode 100644 --- /dev/null +++ b/src/Language/PIR/Emit.hs @@ -0,0 +1,37 @@ +module Language.PIR.Emit ( + Emit(..), + nested, eqSep, commaSep, +) where +import Text.PrettyPrint + +class (Show x) => Emit x where + emit :: x -> Doc + -- emit x = error ("Unrecognized construct: " ++ show x) + +instance Eq Doc where + x == y = (render x) == (render y) + +instance Emit String where + emit = text + +instance (Emit a) => Emit [a] where + emit = vcat . map emit + +instance (Emit a) => Emit (Maybe a) where + emit Nothing = empty + emit (Just x) = emit x + +instance Emit Doc where + emit = id + +instance Emit Int where + emit = int + +nested :: (Emit x) => x -> Doc +nested = nest 4 . emit + +eqSep :: (Emit a, Emit b, Emit c) => a -> b -> [c] -> Doc +eqSep lhs rhs args = emit lhs <+> equals <+> emit rhs <+> commaSep args + +commaSep :: (Emit x) => [x] -> Doc +commaSep = hsep . punctuate comma . map emit