HsParrot (empty) → 0.0.1
raw patch · 6 files changed
+1074/−0 lines, 6 filesdep +HsSyckdep +basedep +bytestringsetup-changed
Dependencies added: HsSyck, base, bytestring, haskell98, pretty, pugs-DrIFT
Files
- Changes +3/−0
- HsParrot.cabal +30/−0
- LICENSE +18/−0
- Setup.lhs +3/−0
- src/Language/PIR.hs +983/−0
- src/Language/PIR/Emit.hs +37/−0
+ Changes view
@@ -0,0 +1,3 @@+[Changes for 0.0.1 - 2008-06-21]++* Initial Hackage release.
+ HsParrot.cabal view
@@ -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+
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ src/Language/PIR.hs view
@@ -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 ()++------------------------------------------------------------------------
+ src/Language/PIR/Emit.hs view
@@ -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