GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-11 20:22:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

a major revision of the bytecode generator and JIT compiler. the effect is that now we can compute with lambda functions and with true tail recursion

Browse Source
This commit is contained in:
kr.angelov
2014-09-11 15:39:39 +00:00
parent 18ee232497
commit 621d748bac
10 changed files with 433 additions and 276 deletions
Download Patch File Download Diff File Expand all files Collapse all files

56
src/runtime/haskell/PGF/Binary.hs
View File

@@ -136,32 +136,36 @@ instance Binary Equation where
get = liftM2 Equ get get
instance Binary Instr where
put (ENTER ) = putWord8 0
put (EVAL_ARG_VAR n) = putWord8 1 >> put n
put (EVAL_FREE_VAR n)= putWord8 2 >> put n
put (CASE id l ) = putWord8 3 >> put (id,l)
put (CASE_INT n l ) = putWord8 4 >> put (n,l)
put (CASE_STR s l ) = putWord8 5 >> put (s,l)
put (CASE_FLT d l ) = putWord8 6 >> put (d,l)
put (ALLOC n) = putWord8 7 >> put n
put (PUT_CONSTR id) = putWord8 8 >> put id
put (PUT_FUN id) = putWord8 9 >> put id
put (PUT_CLOSURE l) = putWord8 10 >> put l
put (PUT_INT n) = putWord8 11 >> put n
put (PUT_STR s) = putWord8 12 >> put s
put (PUT_FLT d) = putWord8 13 >> put d
put (SET_VALUE n) = putWord8 14 >> put n
put (SET_ARG_VAR n) = putWord8 15 >> put n
put (SET_FREE_VAR n) = putWord8 16 >> put n
put (SET_PAD ) = putWord8 17
put (PUSH_VALUE n) = putWord8 18 >> put n
put (PUSH_ARG_VAR n) = putWord8 19 >> put n
put (PUSH_FREE_VAR n)= putWord8 20 >> put n
put (TAIL_CALL id) = putWord8 21 >> put id
put (FAIL ) = putWord8 22
put (UPDATE ) = putWord8 23
put (RET n) = putWord8 24 >> put n
put (ENTER ) = putWord8 0
put (CASE id l ) = putWord8 8 >> put (id,l)
put (CASE_LIT (LInt n) l) = putWord8 16 >> put (n,l)
put (CASE_LIT (LStr s) l) = putWord8 17 >> put (s,l)
put (CASE_LIT (LFlt d) l) = putWord8 18 >> put (d,l)
put (ALLOC n) = putWord8 24 >> put n
put (PUT_CONSTR id) = putWord8 32 >> put id
put (PUT_FUN id) = putWord8 40 >> put id
put (PUT_CLOSURE l) = putWord8 48 >> put l
put (PUT_LIT (LInt n)) = putWord8 56 >> put n
put (PUT_LIT (LStr s)) = putWord8 57 >> put s
put (PUT_LIT (LFlt d)) = putWord8 58 >> put d
put (SET (HEAP n)) = putWord8 64 >> put n
put (SET (ARG_VAR n)) = putWord8 65 >> put n
put (SET (FREE_VAR n)) = putWord8 66 >> put n
put (SET_PAD ) = putWord8 72
put (PUSH (HEAP n)) = putWord8 80 >> put n
put (PUSH (ARG_VAR n)) = putWord8 81 >> put n
put (PUSH (FREE_VAR n)) = putWord8 82 >> put n
put (EVAL (HEAP n) RecCall ) = putWord8 88 >> put n
put (EVAL (ARG_VAR n) RecCall ) = putWord8 89 >> put n
put (EVAL (FREE_VAR n) RecCall ) = putWord8 90 >> put n
put (EVAL (HEAP n) (TailCall a b)) = putWord8 92 >> put n >> put a >> put b
put (EVAL (ARG_VAR n) (TailCall a b)) = putWord8 93 >> put n >> put a >> put b
put (EVAL (FREE_VAR n) (TailCall a b)) = putWord8 94 >> put n >> put a >> put b
put (CALL id RecCall ) = putWord8 96 >> put id
put (CALL id (TailCall a b)) = putWord8 100 >> put id >> put a >> put b
put (FAIL ) = putWord8 104
put (UPDATE ) = putWord8 112
put (RET n) = putWord8 120 >> put n
instance Binary Type where
put (DTyp hypos cat exps) = put (hypos,cat,exps)

85
src/runtime/haskell/PGF/ByteCode.hs
View File

@@ -1,65 +1,76 @@
module PGF.ByteCode(CodeLabel, Instr(..), ppCode, ppInstr) where
module PGF.ByteCode(Literal(..),
CodeLabel, Instr(..), IVal(..), TailInfo(..),
ppLit, ppCode, ppInstr
) where
import PGF.CId
import Text.PrettyPrint
data Literal =
LStr String -- ^ string constant
| LInt Int -- ^ integer constant
| LFlt Double -- ^ floating point constant
deriving (Eq,Ord,Show)
type CodeLabel = Int
data Instr
= ENTER
| EVAL_ARG_VAR {-# UNPACK #-} !Int
| EVAL_FREE_VAR {-# UNPACK #-} !Int
| CASE CId {-# UNPACK #-} !CodeLabel
| CASE_INT Int {-# UNPACK #-} !CodeLabel
| CASE_STR String {-# UNPACK #-} !CodeLabel
| CASE_FLT Double {-# UNPACK #-} !CodeLabel
| CASE_LIT Literal {-# UNPACK #-} !CodeLabel
| ALLOC {-# UNPACK #-} !Int
| PUT_CONSTR CId
| PUT_FUN CId
| PUT_CLOSURE {-# UNPACK #-} !CodeLabel
| PUT_INT {-# UNPACK #-} !Int
| PUT_STR String
| PUT_FLT {-# UNPACK #-} !Double
| SET_VALUE {-# UNPACK #-} !Int
| SET_ARG_VAR {-# UNPACK #-} !Int
| SET_FREE_VAR {-# UNPACK #-} !Int
| PUT_LIT Literal
| SET IVal
| SET_PAD
| PUSH_VALUE {-# UNPACK #-} !Int
| PUSH_ARG_VAR {-# UNPACK #-} !Int
| PUSH_FREE_VAR {-# UNPACK #-} !Int
| TAIL_CALL CId
| PUSH IVal
| EVAL IVal TailInfo
| CALL CId TailInfo
| FAIL
| UPDATE
| RET {-# UNPACK #-} !Int
data IVal
= HEAP {-# UNPACK #-} !Int
| ARG_VAR {-# UNPACK #-} !Int
| FREE_VAR {-# UNPACK #-} !Int
data TailInfo
= RecCall
| TailCall {-# UNPACK #-} !Int {-# UNPACK #-} !Int
ppLit (LStr s) = text (show s)
ppLit (LInt n) = int n
ppLit (LFlt d) = double d
ppCode :: Int -> [[Instr]] -> Doc
ppCode l [] = empty
ppCode l (is:iss) = ppLabel l <+> vcat (map ppInstr is) $$ ppCode (l+1) iss
ppInstr (ENTER ) = text "ENTER"
ppInstr (EVAL_ARG_VAR n) = text "EVAL_ARG_VAR " <+> int n
ppInstr (EVAL_FREE_VAR n) = text "EVAL_FREE_VAR" <+> int n
ppInstr (CASE id l ) = text "CASE " <+> ppCId id <+> ppLabel l
ppInstr (CASE_INT n l ) = text "CASE_INT " <+> int n <+> ppLabel l
ppInstr (CASE_STR str l ) = text "CASE_STR " <+> text (show str) <+> ppLabel l
ppInstr (CASE_FLT d l ) = text "CASE_FLT " <+> double d <+> ppLabel l
ppInstr (ALLOC n) = text "ALLOC " <+> int n
ppInstr (PUT_CONSTR id) = text "PUT_CONSTR " <+> ppCId id
ppInstr (PUT_FUN id) = text "PUT_FUN " <+> ppCId id
ppInstr (PUT_CLOSURE l) = text "PUT_CLOSURE " <+> ppLabel l
ppInstr (PUT_INT n ) = text "PUT_INT " <+> int n
ppInstr (PUT_STR str ) = text "PUT_STR " <+> text (show str)
ppInstr (PUT_FLT d ) = text "PUT_FLT " <+> double d
ppInstr (SET_VALUE n) = text "SET_VALUE " <+> int n
ppInstr (SET_ARG_VAR n) = text "SET_ARG_VAR " <+> int n
ppInstr (SET_FREE_VAR n) = text "SET_FREE_VAR " <+> int n
ppInstr (CASE id l ) = text "CASE " <+> ppCId id <+> ppLabel l
ppInstr (CASE_LIT lit l ) = text "CASE_LIT " <+> ppLit lit <+> ppLabel l
ppInstr (ALLOC n) = text "ALLOC " <+> int n
ppInstr (PUT_CONSTR id) = text "PUT_CONSTR " <+> ppCId id
ppInstr (PUT_FUN id) = text "PUT_FUN " <+> ppCId id
ppInstr (PUT_CLOSURE l) = text "PUT_CLOSURE" <+> ppLabel l
ppInstr (PUT_LIT lit ) = text "PUT_LIT " <+> ppLit lit
ppInstr (SET v) = text "SET " <+> ppIVal v
ppInstr (SET_PAD ) = text "SET_PAD"
ppInstr (PUSH_VALUE n) = text "PUSH_VALUE " <+> int n
ppInstr (PUSH_ARG_VAR n) = text "PUSH_ARG_VAR " <+> int n
ppInstr (PUSH_FREE_VAR n) = text "PUSH_FREE_VAR" <+> int n
ppInstr (TAIL_CALL id) = text "TAIL_CALL " <+> ppCId id
ppInstr (PUSH v) = text "PUSH " <+> ppIVal v
ppInstr (EVAL v ti) = text "EVAL " <+> ppIVal v <+> ppTailInfo ti
ppInstr (CALL v ti) = text "CALL " <+> ppCId v <+> ppTailInfo ti
ppInstr (FAIL ) = text "FAIL"
ppInstr (UPDATE ) = text "UPDATE"
ppInstr (RET n) = text "RET " <+> int n
ppInstr (RET n) = text "RET " <+> int n
ppIVal (HEAP n) = text "hp" <> parens (int n)
ppIVal (ARG_VAR n) = text "stk" <> parens (int n)
ppIVal (FREE_VAR n) = text "env" <> parens (int n)
ppTailInfo RecCall = empty
ppTailInfo (TailCall a b) = text "tail" <> parens (int a <> comma <> int b)
ppLabel l = text (let s = show l in replicate (3-length s) '0' ++ s)

10
src/runtime/haskell/PGF/Expr.hs
View File

@@ -31,12 +31,6 @@ import Control.Monad
import qualified Text.PrettyPrint as PP
import qualified Text.ParserCombinators.ReadP as RP
data Literal =
LStr String -- ^ string constant
| LInt Int -- ^ integer constant
| LFlt Double -- ^ floating point constant
deriving (Eq,Ord,Show)
type MetaId = Int
data BindType =
@@ -274,10 +268,6 @@ pattScope scope (PTilde e) = scope
ppBind Explicit x = ppCId x
ppBind Implicit x = PP.braces (ppCId x)
ppLit (LStr s) = PP.text (show s)
ppLit (LInt n) = PP.int n
ppLit (LFlt d) = PP.double d
ppMeta :: MetaId -> PP.Doc
ppMeta n
| n == 0 = PP.char '?'