CoreLexer.x

{
{-# OPTIONS -w  #-}
module CoreLexer
( Alex(..)
, AlexPosn(..)
, Token(..)
, alexMonadScan
, runAlex
, alexGetInput
) where

import Prelude hiding (lex)

}

%wrapper "monad"

$digit = 0-9
$alpha = [A-Za-z]

tokens :-
  $white+                               ;
  "--".*                                ;
  let                                   { lex TokenSym          }
  letrec                                { lex' TokenLetRec      }
  in                                    { lex' TokenIn          }
  case                                  { lex' TokenCase        }
  of                                    { lex' TokenOf          }
  [\\λ]                                 { lex' TokenLambda      }
  \.                                    { lex' TokenDot         }
  \,                                    { lex' TokenComma       }
  \;                                    { lex' TokenSemiColon   }
  Pack                                  { lex' TokenPack        }
  $digit+                               { lex (TokenInt . read) }
  \(                                    { lex' TokenLParen      }
  \)                                    { lex' TokenRParen      }
  \{                                    { lex' TokenLBrace      }
  \}                                    { lex' TokenRBrace      }
  [\=\+\-\*\/\<\>\~\&\|]+               { lex TokenSym          }
  $alpha [$alpha $digit \_ \']*         { lex TokenVar          }
  
{
-- The token type:
data Token =
        TokenLet             |
        TokenLetRec          |
        TokenIn              |
        TokenCase            |
        TokenOf              |
        TokenLambda          |
        TokenDot             |
        TokenComma           |
        TokenSemiColon       |
        TokenPack            |
        TokenSym String      |
        TokenVar String      |
        TokenLParen          |
        TokenRParen          |
        TokenLBrace          |
        TokenRBrace          |
        TokenInt Integer     |
        TokenEOF
        deriving (Eq,Show)

alexEOF = return TokenEOF

-- Unfortunately, we have to extract the matching bit of string
-- ourselves...
lex :: (String -> a) -> AlexAction a
lex f = \(_,_,_,s) i -> return (f (take i s))

-- For constructing tokens that do not depend on
-- the input
lex' :: a -> AlexAction a
lex' = lex . const

}

CoreParser.y

{
{-# OPTIONS -w #-}
module CoreParser( parseCore, readCore ) where

import CoreLexer
import Language

}

%name parse
%tokentype { Token }
%monad { Alex }
%lexer { lexwrap } { TokenEOF }
-- Without this we get a type error
%error { happyError }

%token
   let    { TokenLet }
   letrec { TokenLetRec }
   in     { TokenIn }
   case   { TokenCase }
   of     { TokenOf }
   'λ'    { TokenLambda }
   '.'    { TokenDot }
   ','    { TokenComma }
   ';'    { TokenSemiColon }
   pack   { TokenPack }
   num    { TokenInt $$ }
   '('    { TokenLParen }
   ')'    { TokenRParen }
   '{'    { TokenLBrace }
   '}'    { TokenRBrace }
   '='    { TokenSym "="  }
   '->'   { TokenSym "->" }
   '+'    { TokenSym "+"  }
   '-'    { TokenSym "-"  }
   '*'    { TokenSym "*"  }
   '/'    { TokenSym "/"  }
   '<'    { TokenSym "<"  }
   '<='   { TokenSym "<=" }
   '=='   { TokenSym "==" }
   '~='   { TokenSym "~=" }
   '>='   { TokenSym ">=" }
   '>'    { TokenSym ">"  }
   '&'    { TokenSym "&"  }
   '|'    { TokenSym "|"  }
   var    { TokenVar $$ }   

%right in
%left '|' '&'
%nonassoc '<' '<=' '==' '~=' '>=' '>'
%left '+' '-'
%left '*' '/'
%left NEG
%right pack

%%

program :: { CoreProgram }
program : program1 { reverse $1 }
program1 : sc               { [$1] }
         | program1 ';' sc  { $3 : $1 }

sc :: { CoreScDefn }
   : var varlist0 '=' expr { ($1, reverse $2, $4) }

-- accepts 0 or more vars
varlist0 :: { [Id] }
         : {- empty -}     { [] }
         | varlist0 var    { $2 : $1 }

-- accepts 1 or more vars
varlist1 :: { [Id] }
         : var             { [$1] }
         | varlist1 var    { $2 : $1 }

expr :: { Expr Id }
expr : expr aexpr              { App $1 $2 }
     | expr binop expr         { App (App $2 $1) $3 }
     | '-' expr %prec NEG      { App (Var "negate") $2 }
     | let defn in expr        { Let $2 $4 }
     | letrec recdefns in expr { Let (Rec (reverse $2)) $4 }
-- TODO: GHC's core adds two fields here that we don't have. What gives?
     | case expr of alts       { Case $2 (reverse $4) }
     | 'λ' varlist1 '.' expr   { foldr Lam $4 (reverse $2) }
     | aexpr                   { $1 }

aexpr :: { Expr Id }
aexpr : var                       { Var $1 }
      | num                       { Lit (LitInteger $1) }
      | pack '{' num ',' num '}'  { Lit (Pack (fromIntegral $3) (fromIntegral $5)) }
      | '(' expr ')'              { $2 }

defn :: { Bind Id }
defn  : var '=' expr       { NonRec $1 $3 }

-- accepts 1 or more definitions
recdefns :: { [(Id, Expr Id)] }
recdefns : recdefn              { [$1]     }
         | recdefns ';' recdefn { $3 : $1  }
recdefn :: { (Id, Expr Id) }
recdefn  : var '=' expr         { ($1, $3) }

-- accepts 1 or more alts
alts :: { [Alt Id] }
alts : alt                 { [$1] }
     | alts ';' alt        { $3 : $1 }
-- accepts 0 or more vars
alt : '<' num '>' varlist0 '->' expr { (DataAlt (DataCon (fromIntegral $2)), (reverse $4), $6) }

binop : arithop { $1 }
      | relop   { $1 }
      | boolop  { $1 }

arithop : '+'  { Var "+"  }
        | '-'  { Var "-"  }
        | '*'  { Var "*"  }
        | '/'  { Var "/"  }

relop : '<'    { Var "<"  }
      | '<='   { Var "<=" }
      | '=='   { Var "==" }
      | '~='   { Var "~=" }
      | '>='   { Var ">=" }
      | '>'    { Var ">"  }

boolop : '|'   { Var "|"  }
       | '&'   { Var "&"  }

{

lexwrap :: (Token -> Alex a) -> Alex a
lexwrap cont = do
  t <- alexMonadScan
  cont t

getPosn :: Alex (Int,Int)
getPosn = do
  (AlexPn _ l c,_,_,_) <- alexGetInput
  return (l,c)

happyError :: Token -> Alex a
happyError t = do
  (l,c) <- getPosn
  fail (show l ++ ":" ++ show c ++ ": Parse error on Token: " ++ show t ++ "\n")

parseCore :: String -> Either String CoreProgram
parseCore s = runAlex s parse

readCore :: FilePath -> IO (Either String CoreProgram)
readCore fp = do
  cs <- readFile fp
  return (parseCore cs)
}

PrettyPrinter.hs

module PrettyPrinter where

import Language
import Text.PrettyPrint

pprProgram :: CoreProgram -> Doc
pprProgram defs = vcat (punctuate semi (map pprCoreScDefn defs))

pprCoreScDefn :: CoreScDefn -> Doc
pprCoreScDefn (name, args, body) =
  text name <+> hsep (map text args) <+> equals <+>
  pprExpr body

pprExpr :: CoreExpr -> Doc
pprExpr (Var s)       = text s
pprExpr (Lit l)       = pprLiteral l
pprExpr (App (App (Var s) e1) e2) 
  -- TODO: add in proper precendence information
  | isBinop s = pprAExpr e1 <+> text s <+> pprAExpr e2
pprExpr (App e1 e2)   = pprExpr e1 <+> pprAExpr e2
pprExpr (Let b e)     = text "let" $$ nest 2 (pprDefns b) $$ text "in" <+> pprExpr e
pprExpr (Case e alts) = text "case" <+> pprExpr e <+> text "of" $$ pprAlts alts
pprExpr e             = error ("Unsupported expression: " ++ show e)

isBinop :: Id -> Bool
isBinop s = s `elem` ["|","&","+","-","*","/","<","<=","==","~=",">=",">"]  

pprDefns :: Bind Id -> Doc
pprDefns bind = case bind of
  (NonRec b e) -> pprDefn (b, e)
  (Rec defns)  -> vcat (punctuate semi (map pprDefn defns))
  where
  pprDefn :: (Id, Expr Id) -> Doc
  pprDefn (b, e) = text b <+> equals <+> pprExpr e

pprAExpr :: CoreExpr -> Doc
pprAExpr e
  | isAtomicExpr e = pprExpr e
  | otherwise      = parens (pprExpr e)

pprAlts :: [Alt Id] -> Doc
pprAlts alts = vcat (punctuate semi (map pprAlt alts))

pprAlt :: Alt Id -> Doc
pprAlt (DataAlt (DataCon n), bs, e) =
  text "<" <> int n <> text ">" <+>
  hsep (map text bs) <+> text "->" <+> pprExpr e
pprAlt (LitAlt l, bs, e) =
  pprLiteral l <+> hsep (map text bs) <+> text "->" <+> pprExpr e
pprAlt (DEFAULT, [], e)  =
  text "_" <+> text "->" <+> pprExpr e
pprAlt _ = error "pprAlt just exploded: Did your DEFAULT case bind names?"

pprLiteral :: Literal -> Doc
pprLiteral (LitInteger n)  = integer n
pprLiteral (Pack tag args) = text "Pack" <> lbrack <> int tag <> comma <> int args <> rbrack

Utils.hs

module Utils where

import Data.Map (Map)
import qualified Data.Map as M

data Heap a = Heap
  { hNumObjs :: Int
  , hUnused  :: [Addr]
  , hMap     :: Map Addr a
  }
  deriving (Eq, Ord)

instance Show a => Show (Heap a) where
  show (Heap num free m) = "Heap " ++ show num ++ " [" ++ show (head free) ++ "..] " ++ show m

type Addr = Int

hInitial :: Heap a
hInitial = Heap 0 [1..] M.empty

hAlloc :: Heap a -> a -> (Heap a, Addr)
hAlloc h@(Heap { hNumObjs = size
               , hUnused  = next:free
               , hMap     = cts
               })
       n = (h { hNumObjs = size+1
              , hUnused  = free
              , hMap     = M.insert next n cts }, next)
hAlloc _ _ = error "Invalid heap"

hUpdate :: Heap a -> Addr -> a -> Heap a
hUpdate h@(Heap { hMap = cts }) a n
  = h { hMap = M.update (const (Just n)) a cts }

hLookup :: Heap a -> Addr -> a
hLookup h a = maybe (error ("can't find node " ++ show a ++ " in heap"))
                    id (M.lookup a (hMap h))

hNull :: Int
hNull = (-1)