src/M0ld.hs

   1 module M0ld where
   2 --(module M0ld.AST,dumpToC,parseM0ld) where
   3 import M0ld.AST
   4 import M0ld.Parser
   5 import qualified Data.Map as Map
   6
   7 prettyPrintBytecode indent stmts =
   8     let labelsMap = mapLabels stmts
   9         regMap    = mapRegisters stmts
  10         freeRegs  = countRegister stmts
  11         prettyPrintOp (Decl _ _) = ""
  12         prettyPrintOp op = indent ++ (joinStr " " $ ( map show (toBytecode op regMap labelsMap))) ++ "\n"
  13         decls = [prettyPrintConstant indent c | Decl reg c <- filter (not . isReg) stmts]
  14         in (concat $ map (\(i,e) -> indent ++ "$" ++ (show i) ++ " = " ++ e) (zip [0..(length decls - 1)] decls))
  15         ++ (concat $ map prettyPrintOp stmts)
  16
  17 type RegMap = Map.Map [Char] Int
  18
  19 type LabelsMap = Map.Map [Char] Int
  20
  21 resolveReg r regs = Map.findWithDefault (error $ "undeclared register: $"++r) r regs
  22
  23 resolveLabelDef l labels = Map.findWithDefault (error $ "undeclared label: "++l) l labels
  24
  25 toBytecode :: Stmt -> RegMap -> LabelsMap -> [Int]
  26 toBytecode stmt regs labels = case stmt of
  27     Call target identifier (Capture invocant positional named) ->
  28         let reg r = resolveReg r regs
  29             args x = [length x] ++ map reg x
  30             in [1,reg target,reg invocant,reg identifier] ++ args positional ++ args named
  31
  32     Call2 target responder identifier capture ->
  33         map (\r -> resolveReg r regs) [target,responder,identifier,capture]
  34
  35     Goto label -> [3, resolveLabelDef label labels]
  36
  37     Br value iftrue iffalse ->
  38         [4,resolveReg value regs,resolveLabelDef iftrue labels,resolveLabelDef iffalse labels]
  39
  40     LabelDef label -> []
  41
  42     Decl reg value -> []
  43
  44 isReg (Decl _ None) = True
  45 isReg _ = False
  46
  47 countRegister stmts = length $ filter isReg stmts
  48
  49 addRegister :: RegMap -> Stmt -> RegMap
  50 addRegister regs stmt = case stmt of
  51     Decl reg None  -> regs
  52     Decl reg value -> if (Map.member reg regs) then regs else  Map.insert reg (Map.size regs)  regs
  53     _ -> regs
  54
  55 addFreeRegister :: RegMap -> Stmt -> RegMap
  56 addFreeRegister regs stmt = case stmt of
  57     Decl reg None -> if (Map.member reg regs) then regs else Map.insert reg (Map.size regs)  regs
  58     Decl reg _ -> regs
  59     _ -> regs
  60
  61 mapRegisters :: [Stmt] -> RegMap
  62 mapRegisters stmts = foldl addFreeRegister (foldl addRegister Map.empty stmts) stmts
  63
  64 bytecodeLength :: Stmt -> Int
  65 bytecodeLength stmt = case stmt of
  66     Br _ _ _ -> 4
  67     Goto _ -> 2
  68     Call target identifier (Capture invocant positional named) ->
  69         6 + length positional + length named
  70     Call2 _ _ _ _ -> 5
  71     Decl _ _ -> 0
  72     LabelDef _ -> 0
  73
  74 addLabelDef (labels,offset) (LabelDef label) = (Map.insert label offset labels,offset)
  75 addLabelDef (labels,offset) stmt = (labels,offset+bytecodeLength stmt)
  76
  77 mapLabels :: [Stmt] -> LabelsMap
  78 mapLabels stmts = fst $ foldl addLabelDef (Map.empty,0) stmts
  79
  80 emit :: [Stmt] -> RegMap -> LabelsMap -> [Int]
  81 emit stmts regMap labelsMap = concatMap (\op -> toBytecode op regMap labelsMap) stmts ++ [0]
  82
  83 joinStr sep [] = ""
  84 joinStr sep list = foldl (\a b -> a ++ sep ++ b) (head list) (tail list)
  85
  86 cStrLength ('\\':next:rest) = 1 + cStrLength rest
  87 cStrLength (c:rest) = 1 + cStrLength rest
  88 cStrLength [] = 0
  89
  90 dumpConstantToC :: Value -> [Char]
  91 dumpConstantToC value = case value of
  92     StringConstant str ->
  93         "SMOP__NATIVE__idconst_createn(\"" ++ str ++"\"," ++ (show $ cStrLength str) ++ "),"
  94     IntegerConstant int -> "SMOP__NATIVE__int_create(" ++ show int ++ "),"
  95     None -> ""
  96     Var name -> "SMOP_REFERENCE(interpreter," ++ name ++ "),"
  97     SubMold stmts -> dumpToC stmts ++ ","
  98
  99 dumpConstantsToC stmts = "(SMOP__Object*[]) {" ++
 100     concat [dumpConstantToC c | Decl reg c <- stmts] ++ "NULL}"
 101
 102 dumpToC stmts =
 103     let labelsMap = mapLabels stmts
 104         regMap    = mapRegisters stmts
 105         freeRegs  = countRegister stmts
 106         bytecode  = emit stmts regMap labelsMap
 107         constants = dumpConstantsToC stmts
 108         in "SMOP__Mold_create(" ++ show freeRegs ++ "," ++ constants ++ ","
 109         ++ show (length bytecode) ++ ",(int[]) {"
 110         ++ (joinStr "," $ map show bytecode)
 111         ++ "})"
 112
 113 prettyPrintConstant :: [Char] -> Value -> [Char]
 114 prettyPrintConstant indent value = case value of
 115     StringConstant str -> (show str) ++ "\n"
 116     IntegerConstant int -> (show int) ++ "\n"
 117     None -> ""
 118     Var name -> "¢" ++ name ++ "\n"
 119     SubMold stmts -> "{\n" ++ (prettyPrintBytecode ("  " ++ indent) stmts) ++ indent ++ "}\n"