module DotNet.Compile (ilCompile) where
import DotNet.IL as IL
import Flags
import IntState hiding (getIntState)
import StateMonad
import Control.Monad.State
import qualified Data.Map as Map
import Util.Extra(Pos, noPos)
import Id(Id)
import qualified Data.Set as Set
import PosCode as P
import StrPos
import Maybe(fromJust, isNothing, isJust)
import ForeignCode(ImpExp(..))
import TokenId
import SysDeps(PackedString, packString, unpackPS)
import NT
import Data.Char
import Data.List(intersperse)
--------------------------------------------------------------
-- state and types
--------------------------------------------------------------
-- the internal compiler state
-- flags,state - saved external items
-- labels - the list of free labels
--
-- env - where each variable can be found
-- fails - a list of fail handlers (still used?)
-- evals - the set of variables that we know to be evaluated
data CState = S { -- global state parameters
cState :: IntState,
-- local state parameters
cCurrId :: Id,
cEnv :: Map.Map Id Where,
cLabels :: Label,
cLocals :: Int,
cLocalEnv :: [TypeSignature] }
type STCompiler a = State CState a
type InsCode = [ILInstruction] -> [ILInstruction]
type Compiler a = STCompiler (InsCode,a)
{- whether we should be compiling strictly or lazily -}
data SMode = PrimStrict PrimOp | Strict | Lazy
deriving Eq
{- where we can find a variable -}
data Where = This
| Local Int Bool
| Field Where TypeSignature String
deriving Show
data BranchAfter = Return
| Continue
| ContinueTo Label
| Goto Label
------------------------------------------------------------------------------------------------
-- compiler
------------------------------------------------------------------------------------------------
ilCompile :: Flags -> IntState -> [(Id,PosLambda)] -> [Id] -> ([ILDecl],IntState)
ilCompile flags state funs cons = ([Namespace (getModuleId state) ds], cState st')
where
st = S state (toEnum 0) Map.empty 0 0 []
(ds,st') = runState (compile funs cons) st
compile :: [(Id,PosLambda)] -> [Id] -> STCompiler [ILDecl]
compile funs cons = do cs <- mapM cCon cons
fs <- mapM cFun funs
return $ concat cs ++ concat fs
cCon :: Id -> STCompiler [ILDecl]
cCon d = do
state <- readState cState
let dataInfo = (fromJust . lookupIS state) d
mapM (mkCon state) (constrsI dataInfo)
where
mkCon state c = do
(ns,lname,class_sig) <- getIdLocalSignature c
let arity = arityIS state c
caf_decls <- mkCAFDecls class_sig arity
(field_decls,args,stcode) <- mkCode class_sig 1 arity
let class_decl =
Class lname sigClosure ( field_decls
++ caf_decls
++ [ILClassConstr ILPublic ILInstance args []
( LDARG 0
: CALL VoidSignature sigClosure ".ctor" []
: stcode
)]
)
return $! if null ns then class_decl else Namespace ns [class_decl]
mkCAFDecls class_sig arity
| arity == 0 = return [ ILClassField ILPublic ILStatic sigClosure "indirection"
, ILClassConstr ILPrivate ILStatic [] []
( NEWOBJ class_sig []
: STSFLD sigClosure class_sig "indirection"
: RET
: []
)
]
| otherwise = return []
mkCode class_sig i n
| i > n = return ([], [], [RET])
| otherwise = do
(fields,args,stcode) <- mkCode class_sig (i+1) n
let name = 'c':show i
return ( (ILClassField ILPublic ILInstance sigClosure name)
: fields
, (ILMethodArg sigClosure name)
: args
, LDARG 0
: LDARG i
: STFLD sigClosure class_sig name
: stcode
)
cFun :: (Id, PosLambda) -> STCompiler [ILDecl]
cFun (i, PosLambda pos int env args exp) = do
setCurrentId i
(ns,lname,class_sig) <- getIdLocalSignature i
let args' = map snd args
field_decls <- mkFieldDecls class_sig args' 1
caf_decls <- mkCAFDecls class_sig args'
thunk_decls <- mkThunkDecls class_sig args'
let class_decl = Class lname sigBaseClass (field_decls ++ caf_decls ++ thunk_decls)
return $! if null ns then [class_decl] else [Namespace ns [class_decl]]
where
sigBaseClass
| length args == 0 = sigCAFClosure
| otherwise = sigThunkClosure
mkCAFDecls class_sig args
| length args == 0 = return [ ILClassField ILPublic ILStatic sigClosure "indirection"
, ILClassConstr ILPrivate ILStatic [] []
( NEWOBJ class_sig []
: STSFLD sigClosure class_sig "indirection"
: RET
: []
)
]
| otherwise = return []
mkThunkDecls class_sig args = do
(ilargs,stcode) <- toArgsSTCode args 1
(state, code) <- innerMonad (cBody exp >>= \(cs,()) -> return (cs []))
return [ ILClassConstr ILPublic ILInstance ilargs []
( LDARG 0
: CALL VoidSignature sigBaseClass ".ctor" []
: stcode
)
, ILClassMethod ILPublic ILVirtual sigClosure "Eval" [] (reverse (cLocalEnv state)) code
]
where
toArgsSTCode [] n = return ([], [RET])
toArgsSTCode (arg:args) n = do
let name = 'c':show n
(ilargs,stcode) <- toArgsSTCode args $! n+1
return ( (ILMethodArg sigClosure name)
: ilargs
, LDARG 0
: LDARG n
: STFLD sigClosure class_sig name
: stcode
)
cBody exp =
newLabel =>>= \lab ->
ins (LDARG 0) =>>
(if length args == 0
then ins (LDSFLD sigClosure class_sig "indirection") =>>
ins (BEQ lab) =>>
ins (LDSFLD sigClosure class_sig "indirection") =>>
ins (TAIL) =>>
insEval Strict =>>
ins (RET) =>>
ins (LABEL lab) =>>
ins (LDSFLD sigClosure sigBlackHoleClosure "indirection") =>>
ins (STSFLD sigClosure class_sig "indirection")
else ins (DUP) =>>
ins (LDFLD sigClosure sigThunkClosure "indirection") =>>
ins (BRFALSE lab) =>>
ins (LDFLD sigClosure sigThunkClosure "indirection") =>>
ins (TAIL) =>>
insEval Strict =>>
ins (RET) =>>
ins (LABEL lab) =>>
ins (LDSFLD sigClosure sigBlackHoleClosure "indirection") =>>
ins (STFLD sigClosure sigThunkClosure "indirection") =>>
ins (LDARG 0)) =>>
newLabel =>>= \fail ->
cExpr Strict fail Return exp =>>= \canFail ->
(if canFail
then ins (LABEL fail) =>>
ins (NEWOBJ sigPaternMatchException []) =>>
ins (THROW)
else nop)
mkFieldDecls class_sig [] n = return []
mkFieldDecls class_sig (arg:args) n = do
let name = 'c':show n
bindField arg This class_sig name
fields <- mkFieldDecls class_sig args $! n+1
return ((ILClassField ILPrivate ILInstance sigClosure name):fields)
cFun (i, PosPrimitive pos id) = do
setCurrentId i
state <- readState cState
(ns,lname,class_sig) <- getIdLocalSignature i
let arity = arityIS state i
(field_decls, ilargs,stcode,evcode) = toArgsSTCode class_sig arity 1
sigBaseClass
| arity == 0 = sigCAFClosure
| otherwise = sigThunkClosure
thunk_decls =
[ ILClassConstr ILPublic ILInstance ilargs []
( LDARG 0
: CALL VoidSignature sigThunkClosure ".ctor" []
: stcode
)
, ILClassMethod ILPublic ILVirtual sigClosure "Eval" [] []
( evcode ++
[ CALLCLASS sigClosure sigPrimitives lname (mkClosureArgs arity)
, RET
])
]
caf_decls = mkCAFDecls class_sig arity
class_decl = Class lname sigBaseClass (field_decls ++ caf_decls ++ thunk_decls)
return $! if null ns then [class_decl] else [Namespace ns [class_decl]]
where
mkCAFDecls class_sig arity
| arity == 0 = [ ILClassField ILPublic ILStatic sigClosure "indirection"
, ILClassConstr ILPrivate ILStatic [] []
( NEWOBJ class_sig []
: STSFLD sigClosure class_sig "indirection"
: RET
: []
)
]
| otherwise = []
toArgsSTCode class_sig arity n
| n > arity = ([], [], [RET], [])
| otherwise =
let name = 'c':show n
(fldecls, ilargs,stcode,evcode) = toArgsSTCode class_sig arity $! n+1
in ( ILClassField ILPrivate ILInstance sigClosure name
: fldecls
, ILMethodArg sigClosure name
: ilargs
, LDARG 0
: LDARG n
: STFLD sigClosure class_sig name
: stcode
, LDARG 0
: LDFLD sigClosure class_sig name
: CALLVIRT sigClosure sigClosure "Eval" []
: evcode
)
cFun (i, PosForeign pos id arity name cc Imported) =
do state <- readState cState
let (unique,state1) = uniqueIS state
arity = arityIS state i
(InfoVar un tok ex fix nt ar) = fromJust $ lookupIS state i
tok' = mkExt tok
info' = InfoVar unique tok' ex fix nt ar
name' = if name == "" then getUnqualified tok else name
state2 = addIS unique info' state1
writeState_ $ \ s -> s { cState = state2 }
return $ [External unique pos arity name' cc nt ]
--------------------------------------------------------------
-- monadic plumbing
--
-- the underlying state of the compiler, recording stack depth, environment
-- etc. is monadic, ontop of this combinators are provided to plug together
-- the outputted code, which are also monad like in nature.
--
-- needless to say the internal details of how this works are complicated,
-- however, conceptually it's quite easy.
--
-- p =>> q
--
-- runs the monad for compiler p, then the one for compiler q and then
-- joins the instructions generated together.
--
-- p =>>= \ x -> q
--
-- does the same as the above but this time it's assumed p is returning something
-- besides just the code that is generated, which is then used as a local variable
-- in defining q.
--
-- for example:
-- newLabel =>>= \ j ->
-- ins (BR j)
--
-- calls the monad to generate a new internal label, and joins its code (i.e. none)
-- with the code for a BR to address provided by newLabel.
--------------------------------------------------------------
(=>>=) :: Compiler a -> (a -> Compiler b) -> Compiler b
c =>>= d = do (cs,a) <- c
(ds,b) <- d a
return (cs . ds, b)
(=>>) :: Compiler () -> Compiler a -> Compiler a
c =>> d = c =>>= \ () -> d
mapC :: (a -> Compiler b) -> [a] -> Compiler [b]
mapC f [] = simply []
mapC f (c:cs) = f c =>>= \ b ->
mapC f cs =>>= \ bs ->
simply (b:bs)
mapC_ :: (a -> Compiler ()) -> [a] -> Compiler ()
mapC_ f cs = mapC f cs =>>= \ _ -> simply ()
simply :: a -> Compiler a
simply a = return (id, a)
liftC :: STCompiler a -> Compiler a
liftC s = do a <- s
simply a
block :: InsCode -> Compiler ()
block is = return (is, ())
--------------------------------------------------------------
-- state manipulation functions
--------------------------------------------------------------
{- bind an identifier to a stack location -}
bindField :: Id -> Where -> TypeSignature -> ILName -> Compiler ()
bindField i wh sig name = liftC $ writeState_ $ \s -> s { cEnv = Map.insert i (Field wh sig name) (cEnv s) }
{- bind an identifier to a stack location -}
bindLocal :: Maybe Id -> Bool -> TypeSignature -> Compiler Int
bindLocal mb_i isEval sig = liftC $ writeState $ \s ->
let s' = s { cEnv = case mb_i of
Just i -> Map.insert i (Local (cLocals s) isEval) (cEnv s)
Nothing -> cEnv s
, cLocals = cLocals s+1
, cLocalEnv = sig : cLocalEnv s
}
in (s', cLocals s)
{- find out where an identifier is stored -}
whereIs :: Id -> Compiler (Maybe Where)
whereIs i = liftC $ readState $ \s -> Map.lookup i (cEnv s)
{- allocate a new compiler label and return it -}
newLabel :: Compiler Label
newLabel = liftC $ writeState $ \s -> let ls = cLabels s
in (s{cLabels = ls+1}, ls)
-- take a compiler and compile it in its own environment,
-- saving and restoring the appropriate local state elements
-- give the depth on return.
branch :: Compiler a -> Compiler a
branch c =
liftC get =>>= \ state ->
let (r,state1) = runState c state in
liftC (put state1{cEnv = cEnv state}) =>>
return r
-- get the internal state
getIntState :: Compiler IntState
getIntState = liftC $ readState cState
------------------------------------------------------------------------------------------------
-- expression compiler
------------------------------------------------------------------------------------------------
cExpr :: SMode -> Label -> BranchAfter -> PosExp -> Compiler Bool
cExpr m fail after (PosInt p i) =
ins (LDC_I4 i) =>>
insBox m OpWord =>>
cBranchAfter False Lazy after
cExpr m fail after (PosChar p c) =
ins (LDC_I4 c) =>>
insBox m OpWord =>>
cBranchAfter False Lazy after
cExpr m fail after (PosFloat p f) =
ins (LDC_R4 f) =>>
insBox m OpFloat =>>
cBranchAfter False Lazy after
cExpr m fail after (PosDouble p f) =
ins (LDC_R8 f) =>>
insBox m OpDouble =>>
cBranchAfter False Lazy after
cExpr m fail after (PosInteger p i) =
ins (LDSTR (show i)) =>>
ins (NEWOBJ sigIntegerClosure [ClassSignature "mscorlib" "System.String"]) =>>
cBranchAfter False Lazy after
cExpr m fail after (PosString p s) =
ins (LDSTR s) =>>
ins (NEWOBJ sigStringClosure [ClassSignature "mscorlib" "System.String"]) =>>
cBranchAfter False Lazy after
cExpr m fail after (PosCon p c) =
pushVar Lazy after c
cExpr m fail after (PosVar p v) =
pushVar m after v
cExpr m fail after (PosExpLet False p bs e) =
mapC (\(i,PosLambda p _ _ [] e) -> bindLocal (Just i) False sigClosure =>>= \loc ->
cExpr Lazy fail Continue e =>>= \canFail ->
ins (STLOC loc) =>>
simply canFail) bs =>>= \fs ->
cExpr m fail after e =>>= \canFail ->
simply (canFail || or fs)
cExpr m fail after (PosExpLet True p bs e) =
mapC_ (\(i,_) -> bindLocal (Just i) False sigClosure =>>= \loc ->
ins (NEWOBJ sigThunkClosure []) =>>
ins (STLOC loc)) bs =>>
mapC (\(i,PosLambda p _ _ [] e) -> cExpr Lazy fail Continue e =>>= \canFail1 ->
pushVar Lazy Continue i =>>= \canFail2 ->
ins (STFLD sigClosure sigThunkClosure "indirection") =>>
simply (canFail1 || canFail2)) bs =>>= \fs ->
cExpr m fail after e =>>= \canFail ->
simply (canFail || or fs)
cExpr m fail after (PosExpThunk p ap [a]) =
cExpr m fail after a
cExpr m fail after (PosExpThunk p ap [PosPrim _ SEQ _, x, y]) =
cExpr Strict fail Continue x =>>= \canFail1 ->
ins POP =>>
cExpr m fail after y =>>= \canFail2 ->
simply (canFail1 || canFail2)
cExpr m fail after (PosExpThunk p ap (f@(PosExpIf _ _ _ _ _):as)) =
cExpr Lazy fail Continue f =>>= \canFail ->
mapC (cExpr Strict fail Continue) as =>>= \fs ->
ins (CALLVIRT sigClosure sigClosure "Apply" (mkClosureArgs (length as))) =>>
cBranchAfter (canFail || or fs) Strict after
cExpr m fail after (PosExpThunk p ap (f:as)) =
cCall m fail after f as
cExpr m fail after (PosExpApp p as) =
cExpr m fail after (PosExpThunk p False as)
cExpr m fail after (PosExpFatBar _ e PosExpFail)=
branch (cExpr m fail after e)
cExpr m fail after (PosExpFatBar esc e f) =
newLabel =>>= \ fail' ->
cBranch after $ \after1 after2 ->
branch (cExpr m fail' after1 e) =>>= \canFail ->
(if canFail
then ins (LABEL fail') =>>
ins (POP) =>>
branch (cExpr m fail after2 f)
else simply False)
cExpr m fail after (PosExpFail) =
ins (BR fail) =>>
simply True
cExpr Strict fail after (PosExpIf p g c t f) =
newLabel =>>= \l1 ->
cBranch after $ \after1 after2 ->
cExpr (PrimStrict OpWord) fail Continue c =>>= \canFail1 ->
ins (BRFALSE l1) =>>
branch (cExpr Strict fail after1 t) =>>= \canFail2 ->
ins (LABEL l1) =>>
branch (cExpr Strict fail after2 f) =>>= \canFail3 ->
simply (canFail1 || canFail2 || canFail3)
cExpr Strict fail after (PosExpCase p c as) =
cExpr (if isIntCase as then PrimStrict OpWord else Strict) fail Continue c =>>= \canFail ->
cBranch after (cCase as) =>>
simply True
where
cCase [] after1 after2 = nop
cCase (alt:alts) after1 after2 =
(if null alts
then simply fail
else newLabel) =>>= \lab ->
branch (
ins (DUP) =>>
(case alt of
PosAltInt _ i _ e -> ins (LDC_I4 i) =>>
ins (BNE lab) =>>
simply e
PosAltCon p t vs e -> liftC (getIdSignature t) =>>= \sig ->
bindLocal (getExprVar c) True sig =>>= \loc ->
mapC_ (\(vs,n) -> bindField (snd vs) (Local loc True) sig ('c':show n)) (zip vs [1..]) =>>
ins (ISINST sig) =>>
ins (STLOC loc) =>>
ins (LDLOC loc) =>>
ins (BRFALSE lab) =>>
simply e) =>>= \e ->
ins (POP) =>>
(if null alts
then cExpr Strict lab after2 e =>>= \canFail ->
nop
else cExpr Strict lab after1 e =>>= \canFail ->
ins (LABEL lab))) =>>
cCase alts after1 after2
cExpr m fail after e =
getIntState =>>= \ is ->
error $ "cExpr: no code for '"++strPExp (strIS is) "" e ++"'"
{- compile a call to a function, with some number of arguments given -}
cCall :: SMode -> Label -> BranchAfter -> PosExp -> [PosExp] -> Compiler Bool
cCall m fail after (PosPrim p c i) as =
case c of
P.ADD op -> cPrimOp (ins IL.ADD) op
P.SUB op -> cPrimOp (ins IL.SUB) op
P.MUL op -> cPrimOp (ins IL.MUL) op
P.QUOT -> cPrimOp (ins IL.DIV) OpWord
P.REM -> cPrimOp (ins IL.REM) OpWord
P.SLASH op -> cPrimOp (ins IL.DIV) op
P.CMP_EQ op -> cPrimOp (ins IL.CEQ) op
P.CMP_NE op -> cPrimOp (ins IL.CEQ =>> ins IL.NOT) op
P.CMP_LE op -> cPrimOp (ins IL.CGT =>> ins IL.NOT) op
P.CMP_LT op -> cPrimOp (ins IL.CLT) op
P.CMP_GE op -> cPrimOp (ins IL.CLT =>> ins IL.NOT) op
P.CMP_GT op -> cPrimOp (ins IL.CGT) op
P.NEG op -> cPrimOp (ins IL.NEG) op
P.ORD -> mapC (cExpr Strict fail Continue) as =>>= \fs ->
ins (CALL sigClosure sigClosure "FromEnum" (mkClosureArgs 1)) =>>
cBranchAfter (or fs) Lazy after
P.STRING -> mapC (cExpr Strict fail Continue) as =>>= \fs ->
cBranchAfter (or fs) m after
where
cPrimOp f op =
mapC (cExpr (PrimStrict op) fail Continue) as =>>= \fs ->
f =>> insBox m op =>>
cBranchAfter (or fs) Lazy after
cCall m fail after (PosCon p c) as =
mapC (cExpr Lazy fail Continue) as =>>= \fs ->
liftC (getIdSignature c) =>>= \sig ->
ins (NEWOBJ sig (mkClosureArgs (length as))) =>>
cBranchAfter (or fs) Lazy after
cCall m fail after (PosVar p v) as =
isGlobal v =>>= \ glob ->
(if glob then getIntState =>>= \ is ->
let got = length as
expect = arityIS is v
extra = got - expect
(expected_as, extra_as) = splitAt expect as
in
-- saturated or super-saturated case
liftC (getIdSignature v) =>>= \sig ->
if got >= expect
then mapC (cExpr Lazy fail Continue) expected_as =>>= \fs ->
(if expect > 0 then ins (NEWOBJ sig (mkClosureArgs expect))
else ins (LDSFLD sigClosure sig "indirection")
) =>>
mapC (cExpr Lazy fail Continue) extra_as =>>= \fs ->
-- apply extra arguments if needed
(if extra > 0 then ins (CALLVIRT sigClosure sigClosure "Apply" (mkClosureArgs extra))
else nop
) =>>
-- eval the result if needed
cBranchAfter (or fs) m after
else ins (LDTOKEN_METHOD VoidSignature sig ".ctor" (mkClosureArgs expect)) =>>
mapC (cExpr Lazy fail Continue) as =>>= \fs ->
ins (NEWOBJ sigPAPClosure (ValueSignature "mscorlib" "System.RuntimeMethodHandle" : mkClosureArgs got)) =>>
cBranchAfter (or fs) Lazy after
else pushVar Lazy Continue v =>>= \canFail ->
mapC (cExpr Lazy fail Continue) as =>>= \fs ->
ins (CALLVIRT sigClosure sigClosure "Apply" (mkClosureArgs (length as))) =>>
cBranchAfter (canFail || or fs) m after)
cCall m fail after f@(PosExpThunk p ap es) as =
cExpr Lazy fail Continue f =>>= \canFail ->
mapC (cExpr Lazy fail Continue) as =>>= \fs ->
ins (CALLVIRT sigClosure sigClosure "Apply" (mkClosureArgs (length as))) =>>
cBranchAfter (canFail || or fs) m after
cCall m fail after e got =
getIntState =>>= \ is ->
error $ "cCall: no code for '"++strPExp (strIS is) "" e++"'"
cBranchAfter canFail m (Return ) = getIntState =>>= \ is ->
liftC getCurrentId =>>= \i ->
let ar = arityIS is i in
(if ar == 0
then liftC (getIdSignature i) =>>= \sig ->
ins (STSFLD sigClosure sig "indirection") =>>
ins (LDSFLD sigClosure sig "indirection")
else ins (STFLD sigClosure sigThunkClosure "indirection") =>>
ins (LDARG 0) =>>
ins (LDFLD sigClosure sigThunkClosure "indirection")) =>>
(if m /= Lazy
then ins (TAIL)
else nop) =>>
insEval m =>> ins (RET) =>> simply canFail
cBranchAfter canFail m (Continue ) = insEval m =>> simply canFail
cBranchAfter canFail m (ContinueTo l) = insEval m =>> simply canFail
cBranchAfter canFail m (Goto l) = insEval m =>> ins (BR l) =>> simply canFail
cBranch (Continue ) f = newLabel =>>= \l ->
f (Goto l) (ContinueTo l) =>>= \r ->
ins (LABEL l) =>>
simply r
cBranch (ContinueTo l) f = f (Goto l) (ContinueTo l)
cBranch after f = f after after
-----------------------------------------------------------------------------------
-- helper functions
-----------------------------------------------------------------------------------
{- for a list of alternatives: returns whether this is an int-case -}
isIntCase :: [PosAlt] -> Bool
isIntCase as@(PosAltInt {} : _) = True
isIntCase as@(PosAltCon {} : _) = False
getExprVar (PosCon _ c) = Just c
getExprVar (PosVar _ v) = Just v
getExprVar _ = Nothing
-----------------------------------------------------------------------------------
-- instruction generation functions
-----------------------------------------------------------------------------------
{- issue a non instruction -}
nop :: Compiler ()
nop = simply ()
{- issue a full instruction -}
ins :: ILInstruction -> Compiler ()
ins i = return ((i :) , ())
{- issue an eval instruction if needed -}
insEval :: SMode -> Compiler ()
insEval (PrimStrict OpWord) = ins (CALL Int32Signature sigClosure "EvalInt" [])
insEval (PrimStrict OpDouble) = ins (CALL DoubleSignature sigClosure "EvalFloat" [])
insEval (PrimStrict OpFloat) = ins (CALL FloatSignature sigClosure "EvalDouble" [])
insEval Strict = ins (CALLVIRT sigClosure sigClosure "Eval" [])
insEval Lazy = nop
insBox (PrimStrict op1) op = nop
insBox _ op =
case op of
OpWord -> ins (NEWOBJ sigIntClosure [Int32Signature])
OpDouble -> ins (NEWOBJ sigDoubleClosure [DoubleSignature])
OpFloat -> ins (NEWOBJ sigFloatClosure [FloatSignature])
{- returns whether the given identifier is global or not -}
isGlobal :: Id -> Compiler Bool
isGlobal i =
whereIs i =>>= \ w ->
let b = isNothing w in
simply b
{- push a variable on the stack -}
pushVar :: SMode -> BranchAfter -> Id -> Compiler Bool
pushVar m after i =
whereIs i =>>= \mb_wh ->
case mb_wh of
Just wh -> pushWhere m after wh
Nothing -> getIntState =>>= \ is ->
liftC (getIdSignature i) =>>= \sig ->
let ar = arityIS is i in
if ar == 0
then ins (LDSFLD sigClosure sig "indirection") =>>
cBranchAfter False m after
else ins (LDTOKEN_METHOD VoidSignature sig ".ctor" (mkClosureArgs ar)) =>>
ins (NEWOBJ sigPAPClosure [ValueSignature "mscorlib" "System.RuntimeMethodHandle"]) =>>
cBranchAfter False Lazy after
where
pushWhere m after (This) = ins (LDARG 0) =>>
cBranchAfter False Lazy after
pushWhere m after (Local n True) = ins (LDLOC n) =>>
cBranchAfter False Lazy after
pushWhere m after (Local n False) = ins (LDLOC n) =>>
cBranchAfter False m after
pushWhere m after (Field wh sig n) = pushWhere m Continue wh =>>= \canFail ->
ins (LDFLD sigClosure sig n) =>>
cBranchAfter canFail m after
getIdSignature :: Id -> STCompiler TypeSignature
getIdSignature v = do
state <- readState cState
case lookupIS state v of
Just info -> let ns = splitNS info
name = case ns of
[n] -> (getModuleId state ++ "." ++ n)
ns -> (concat (intersperse "." ns))
package
| tidI info == name_System_IO_Handle = "Haskell.Runtime"
| otherwise = ""
in return (ClassSignature package name)
Nothing -> localVarError
name_System_IO_Handle = Qualified (packString "System.IO") (packString "Handle")
getIdLocalSignature :: Id -> STCompiler (String, ILName, TypeSignature)
getIdLocalSignature v = do
state <- readState cState
case lookupIS state v of
Just info -> let ns = splitNS info
modid = getModuleId state
in case ns of
[n] -> return ("", n, ClassSignature "" (getModuleId state ++ "." ++ n))
(n:ns) -> if n == modid
then let ns_name = concat (intersperse "." (init ns))
name = concat (intersperse "." (n:ns))
in return (ns_name, last ns, ClassSignature "" name)
else localVarError
Nothing -> localVarError
setCurrentId :: Id -> STCompiler ()
setCurrentId i = writeState_ $ \s -> s { cCurrId = i }
getCurrentId :: STCompiler Id
getCurrentId = readState cCurrId
localVarError = error "Not a locally defined name"
splitNS :: Info -> [String]
splitNS info = split (tidI info)
where
split (TupleId n) = [unpack rpsPrelude, 'Z':show n]
split (Visible n) = [encodeName n]
split (Qualified m n) = [unpack m, encodeName n]
split (Qualified2 m c t) = [unpack m] ++ split c ++ split t
split (Qualified3 m c t i) = [unpack m] ++ split c ++ split t ++ split i
encodeName :: PackedString -> String
encodeName ps =
case encode (unpackPS ps) base of
[] -> []
(c:cs) -> toUpper c : cs
where
base | isConstr info = "Closure"
| otherwise = "Thunk"
encode [] xs = xs
encode ('-':cs) xs = encode cs ('Z':'a':xs)
encode ('+':cs) xs = encode cs ('Z':'b':xs)
encode ('*':cs) xs = encode cs ('Z':'c':xs)
encode ('=':cs) xs = encode cs ('Z':'d':xs)
encode ('>':cs) xs = encode cs ('Z':'e':xs)
encode ('<':cs) xs = encode cs ('Z':'f':xs)
encode ('[':cs) xs = encode cs ('Z':'g':xs)
encode (']':cs) xs = encode cs ('Z':'h':xs)
encode ('.':cs) xs = encode cs ('Z':'i':xs)
encode (':':cs) xs = encode cs ('Z':'j':xs)
encode ('&':cs) xs = encode cs ('Z':'k':xs)
encode ('/':cs) xs = encode cs ('Z':'l':xs)
encode ('\'':cs)xs = encode cs ('Z':'m':xs)
encode ('|':cs) xs = encode cs ('Z':'n':xs)
encode ('$':cs) xs = encode cs ('Z':'o':xs)
encode ('!':cs) xs = encode cs ('Z':'p':xs)
encode ('^':cs) xs = encode cs ('Z':'q':xs)
encode ('%':cs) xs = encode cs ('Z':'r':xs)
encode ('Z':cs) xs = encode cs ('Z':'z':xs)
encode ( c:cs) xs = encode cs ( c:xs)
unpack = reverse . unpackPS
mkClosureArgs n = replicate n sigClosure
sigClosure = ClassSignature "Haskell.Runtime" "Haskell.Runtime.Closure"
sigStringClosure = ClassSignature "" "Haskell.Runtime.StringClosure"
sigIntClosure = ClassSignature "Haskell.Runtime" "Haskell.Runtime.IntClosure"
sigFloatClosure = ClassSignature "Haskell.Runtime" "Haskell.Runtime.FloatClosure"
sigDoubleClosure = ClassSignature "Haskell.Runtime" "Haskell.Runtime.DoubleClosure"
sigIntegerClosure = ClassSignature "Haskell.Runtime" "Haskell.Runtime.IntegerClosure"
sigThunkClosure = ClassSignature "Haskell.Runtime" "Haskell.Runtime.ThunkClosure"
sigPAPClosure = ClassSignature "Haskell.Runtime" "Haskell.Runtime.PAPClosure"
sigCAFClosure = ClassSignature "Haskell.Runtime" "Haskell.Runtime.CAFClosure"
sigBlackHoleClosure = ClassSignature "Haskell.Runtime" "Haskell.Runtime.BlackHoleClosure"
sigPrimitives = ClassSignature "Haskell.Runtime" "Haskell.Runtime.Primitives"
sigPaternMatchException = ClassSignature "Haskell.Runtime" "Haskell.Runtime.PatternMatchException"
|
