AI Prompt

gistfile1.txt

You're a code completion assistant.
###
-- 
module HVML.Type where

import Data.Map.Strict as MS
import Data.Word
import Foreign.Ptr

-- Core Types
-- ----------

--show--
data Core
  = Var String -- x
  | Ref String Word64 [Core] -- @fn
  | Era -- *
  | Lam String Core -- λx(F)
  | App Core Core -- (f x)
  | Sup Word64 Core Core -- &L{a b}
  | Dup Word64 String String Core Core -- ! &L{a b} = v body
  | Ctr String [Core] -- #Ctr{a b ...}
  | Mat Core [(String,Core)] [(String,[String],Core)] -- ~ v { #A{a b ...}: ... #B{a b ...}: ... ... }
  | U32 Word32 -- 123
  | Chr Char -- 'a'
  | Op2 Oper Core Core -- (+ a b)
  | Let Mode String Core Core -- ! x = v body
  deriving (Show, Eq)

--show--
data Mode
  = LAZY
  | STRI
  | PARA
  deriving (Show, Eq, Enum)

--show--
data MatchType
  = Switch
  | Match
  | IfLet
  deriving (Show, Eq, Enum)

--show--
data Oper
  = OP_ADD | OP_SUB | OP_MUL | OP_DIV
  | OP_MOD | OP_EQ  | OP_NE  | OP_LT
  | OP_GT  | OP_LTE | OP_GTE | OP_AND
  | OP_OR  | OP_XOR | OP_LSH | OP_RSH
  deriving (Show, Eq, Enum)

--show--
-- A top-level function, including:
-- - copy: true when ref-copy mode is enabled
-- - args: a list of (isArgStrict, argName) pairs
-- - core: the function's body
-- Note: ref-copy improves C speed, but increases interaction count
type Func = ((Bool, [(Bool,String)]), Core)

data Book = Book
  { fidToFun :: MS.Map Word64 Func -- function id to Function object
  , fidToLab :: MS.Map Word64 (MS.Map Word64 ()) -- function id to dup labels used in its body
  , fidToNam :: MS.Map Word64 String -- function id to name
  , namToFid :: MS.Map String Word64 -- function name to id
  , cidToAri :: MS.Map Word64 Word64 -- constructor id to field count (arity)
  , cidToLen :: MS.Map Word64 Word64 -- constructor id to cases length (ADT constructor count)
  , cidToCtr :: MS.Map Word64 String -- constructor id to name
  , ctrToCid :: MS.Map String Word64 -- constructor name to id
  , cidToADT :: MS.Map Word64 Word64 -- constructor id to ADT id (first cid of its datatype)
  } deriving (Show, Eq)

-- Runtime Types
-- -------------

--show--
type Tag  = Word64
type Lab  = Word64
type Loc  = Word64
type Term = Word64

--show--
data TAG
  = DP0
  | DP1
  | VAR
  | ERA
  | APP
  | LAM
  | SUP
  | SUB
  | REF
  | LET
  | CTR
  | MAT
  | IFL
  | SWI
  | W32
  | CHR
  | OPX
  | OPY
  deriving (Eq, Show)

--show--
type HVM = IO

--show--
type ReduceAt = Book -> Loc -> HVM Term

-- C Functions
-- -----------

foreign import ccall unsafe "Runtime.c hvm_init"
  hvmInit :: IO ()
foreign import ccall unsafe "Runtime.c hvm_free"
  hvmFree :: IO ()
foreign import ccall unsafe "Runtime.c alloc_node"
  allocNode :: Word64 -> IO Word64
foreign import ccall unsafe "Runtime.c set"
  set :: Word64 -> Term -> IO ()
foreign import ccall unsafe "Runtime.c got"
  got :: Word64 -> IO Term
foreign import ccall unsafe "Runtime.c take"
  take :: Word64 -> IO Term
foreign import ccall unsafe "Runtime.c swap"
  swap :: Word64 -> IO Term
foreign import ccall unsafe "Runtime.c term_new"
  termNew :: Tag -> Lab -> Loc -> Term
foreign import ccall unsafe "Runtime.c term_tag"
  termTag :: Term -> Tag
foreign import ccall unsafe "Runtime.c term_get_bit"
  termGetBit :: Term -> Tag
foreign import ccall unsafe "Runtime.c term_lab"
  termLab :: Term -> Lab
foreign import ccall unsafe "Runtime.c term_loc"
  termLoc :: Term -> Loc
foreign import ccall unsafe "Runtime.c term_set_bit"
  termSetBit :: Term -> Tag
foreign import ccall unsafe "Runtime.c term_rem_bit"
  termRemBit :: Term -> Tag
foreign import ccall unsafe "Runtime.c get_len"
  getLen :: IO Word64
foreign import ccall unsafe "Runtime.c get_itr"
  getItr :: IO Word64
foreign import ccall unsafe "Runtime.c inc_itr"
  incItr :: IO Word64
foreign import ccall unsafe "Runtime.c fresh"
  fresh :: IO Word64
foreign import ccall unsafe "Runtime.c reduce"
  reduceC :: Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_let"
  reduceLet :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_app_era"
  reduceAppEra :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_app_lam"
  reduceAppLam :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_app_sup"
  reduceAppSup :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_app_ctr"
  reduceAppCtr :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_app_w32"
  reduceAppW32 :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_dup_era"
  reduceDupEra :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_dup_lam"
  reduceDupLam :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_dup_sup"
  reduceDupSup :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_dup_ctr"
  reduceDupCtr :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_dup_w32"
  reduceDupW32 :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_dup_ref"
  reduceDupRef :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_mat_era"
  reduceMatEra :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_mat_lam"
  reduceMatLam :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_mat_sup"
  reduceMatSup :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_mat_ctr"
  reduceMatCtr :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_mat_w32"
  reduceMatW32 :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_opx_era"
  reduceOpxEra :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_opx_lam"
  reduceOpxLam :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_opx_sup"
  reduceOpxSup :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_opx_ctr"
  reduceOpxCtr :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_opx_w32"
  reduceOpxW32 :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_opy_era"
  reduceOpyEra :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_opy_lam"
  reduceOpyLam :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_opy_sup"
  reduceOpySup :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_opy_ctr"
  reduceOpyCtr :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_opy_w32"
  reduceOpyW32 :: Term -> Term -> IO Term
foreign import ccall unsafe "Runtime.c reduce_ref_sup"
  reduceRefSup :: Term -> Word64 -> IO Term
foreign import ccall unsafe "Runtime.c hvm_define"
  hvmDefine :: Word64 -> FunPtr (IO Term) -> IO ()
foreign import ccall unsafe "Runtime.c hvm_get_state"
  hvmGetState :: IO (Ptr ())
foreign import ccall unsafe "Runtime.c hvm_set_state"
  hvmSetState :: Ptr () -> IO ()
foreign import ccall unsafe "Runtime.c u12v2_new"
  u12v2New :: Word64 -> Word64 -> Word64
foreign import ccall unsafe "Runtime.c u12v2_x"
  u12v2X :: Word64 -> Word64
foreign import ccall unsafe "Runtime.c u12v2_y"
  u12v2Y :: Word64 -> Word64
foreign import ccall unsafe "Runtime.c hvm_set_cari"
  hvmSetCari :: Word64 -> Word16 -> IO ()
foreign import ccall unsafe "Runtime.c hvm_set_clen"
  hvmSetClen :: Word64 -> Word16 -> IO ()
foreign import ccall unsafe "Runtime.c hvm_set_cadt"
  hvmSetCadt :: Word64 -> Word16 -> IO ()
foreign import ccall unsafe "Runtime.c hvm_set_fari"
  hvmSetFari :: Word64 -> Word16 -> IO ()

-- Constants
-- ---------

--show--
tagT :: Tag -> TAG
tagT 0x00 = DP0
tagT 0x01 = DP1
tagT 0x02 = VAR
tagT 0x03 = SUB
tagT 0x04 = REF
tagT 0x05 = LET
tagT 0x06 = APP
tagT 0x08 = MAT
tagT 0x09 = IFL
tagT 0x0A = SWI
tagT 0x0B = OPX
tagT 0x0C = OPY
tagT 0x0D = ERA
tagT 0x0E = LAM
tagT 0x0F = SUP
tagT 0x10 = CTR
tagT 0x11 = W32
tagT 0x12 = CHR
tagT tag  = error $ "unknown tag: " ++ show tag

_DP0_ :: Tag
_DP0_ = 0x00

_DP1_ :: Tag
_DP1_ = 0x01

_VAR_ :: Tag
_VAR_ = 0x02

_SUB_ :: Tag
_SUB_ = 0x03

_REF_ :: Tag
_REF_ = 0x04

_LET_ :: Tag
_LET_ = 0x05

_APP_ :: Tag
_APP_ = 0x06

_MAT_ :: Tag
_MAT_ = 0x08

_IFL_ :: Tag
_IFL_ = 0x09

_SWI_ :: Tag
_SWI_ = 0x0A

_OPX_ :: Tag
_OPX_ = 0x0B

_OPY_ :: Tag
_OPY_ = 0x0C

_ERA_ :: Tag
_ERA_ = 0x0D

_LAM_ :: Tag
_LAM_ = 0x0E

_SUP_ :: Tag
_SUP_ = 0x0F

_CTR_ :: Tag
_CTR_ = 0x10

_W32_ :: Tag
_W32_ = 0x11

_CHR_ :: Tag
_CHR_ = 0x12

--show--
modeT :: Lab -> Mode
modeT 0x00 = LAZY
modeT 0x01 = STRI
modeT 0x02 = PARA
modeT mode = error $ "unknown mode: " ++ show mode

-- Primitive Functions
_DUP_F_ :: Lab
_DUP_F_ = 0xFFF

_SUP_F_ :: Lab
_SUP_F_ = 0xFFE

_LOG_F_ :: Lab
_LOG_F_ = 0xFFD

primitives :: [(String, Lab)]
primitives = 
  [ ("SUP", _SUP_F_)
  , ("DUP", _DUP_F_)
  , ("LOG", _LOG_F_)
  ]

-- Utils
-- -----

-- Getter function for maps
mget :: (Ord k, Show k) => MS.Map k a -> k -> a
mget map key =
  case MS.lookup key map of
    Just val -> val
    Nothing  -> error $ "key not found: " ++ show key

-- Returns the first constructor ID in a pattern-match
matFirstCid :: Book -> Core -> Word64
matFirstCid book (Mat _ _ ((ctr,_,_):_)) =
  case MS.lookup ctr (ctrToCid book) of
    Just cid -> cid
    Nothing  -> 0
matFirstCid _ _ = 0

matType :: Book -> Core -> MatchType
matType book (Mat _ _ css) =
  case css of
    ((ctr,_,_):_) | ctr == "0"         -> Switch
    [(ctr,_,_),("_",_,_)]              -> IfLet
    cs | all (\(c,_,_) -> c /= "_") cs -> Match
    _                                  -> error "invalid match"
matType _ _ = error "not a match"

funArity :: Book -> Word64 -> Word64
funArity book fid
  | fid == _SUP_F_ = 3
  | fid == _DUP_F_ = 3
  | fid == _LOG_F_ = 1
  | otherwise = case MS.lookup fid (fidToFun book) of
      Just ((_, args), _) -> fromIntegral (length args)
      Nothing -> error $ "Function ID not found: " ++ show fid

-- 
-- //./Type.hs//

module HVML.Inject where

import Control.Monad (foldM, when, forM_)
import Control.Monad.State
import Data.Bits (shiftL, (.|.))
import Data.Char (ord)
import Data.List (foldr, take)
import Data.Word
import Debug.Trace
import HVML.Show
import HVML.Type
import qualified Data.Map.Strict as MS

type InjectM a = StateT InjectState HVM a

data InjectState = InjectState
  { args :: MS.Map String Term -- maps var names to binder locations
  , vars :: [(String, Loc)]    -- list of (var name, usage location) pairs
  }

emptyState :: InjectState
emptyState = InjectState MS.empty []

injectCore :: Book -> Core -> Loc -> InjectM ()

injectCore _ Era loc = do
  lift $ set loc (termNew _ERA_ 0 0)

injectCore _ (Var nam) loc = do
  argsMap <- gets args
  case MS.lookup nam argsMap of
    Just term -> do
      lift $ set loc term
      when (head nam /= '&') $ do
        modify $ \s -> s { args = MS.delete nam (args s) }
    Nothing -> do
      modify $ \s -> s { vars = (nam, loc) : vars s }

injectCore book (Let mod nam val bod) loc = do
  let_node <- lift $ allocNode 2
  modify $ \s -> s { args = MS.insert nam (termNew _VAR_ 0 (let_node + 0)) (args s) }
  injectCore book val (let_node + 0)
  injectCore book bod (let_node + 1)
  lift $ set loc (termNew _LET_ (fromIntegral $ fromEnum mod) let_node)

injectCore book (Lam vr0 bod) loc = do
  lam <- lift $ allocNode 1
  -- lift $ set (lam + 0) (termNew _SUB_ 0 0)
  modify $ \s -> s { args = MS.insert vr0 (termNew _VAR_ 0 (lam + 0)) (args s) }
  injectCore book bod (lam + 0)
  lift $ set loc (termNew _LAM_ 0 lam)

injectCore book (App fun arg) loc = do
  app <- lift $ allocNode 2
  injectCore book fun (app + 0)
  injectCore book arg (app + 1)
  lift $ set loc (termNew _APP_ 0 app)

injectCore book (Sup lab tm0 tm1) loc = do
  sup <- lift $ allocNode 2
  injectCore book tm0 (sup + 0)
  injectCore book tm1 (sup + 1)
  lift $ set loc (termNew _SUP_ lab sup)

injectCore book (Dup lab dp0 dp1 val bod) loc = do
  dup <- lift $ allocNode 2
  -- lift $ set (dup + 0) (termNew _SUB_ 0 0)
  lift $ set (dup + 1) (termNew _SUB_ 0 0)
  modify $ \s -> s 
    { args = MS.insert dp0 (termNew _DP0_ lab dup) 
           $ MS.insert dp1 (termNew _DP1_ lab dup) (args s) 
    }
  injectCore book val (dup + 0)
  injectCore book bod loc

injectCore book (Ref nam fid arg) loc = do
  let ari = funArity book fid
  ref <- lift $ allocNode (fromIntegral ari)
  sequence_ [injectCore book x (ref + i) | (i,x) <- zip [0..] arg]
  lift $ set loc (termNew _REF_ fid ref)

injectCore book (Ctr nam fds) loc = do
  let ari = length fds
  let cid = mget (ctrToCid book) nam
  ctr <- lift $ allocNode (fromIntegral ari)
  sequence_ [injectCore book fd (ctr + ix) | (ix,fd) <- zip [0..] fds]
  lift $ set loc (termNew _CTR_ cid ctr)

injectCore book tm@(Mat val mov css) loc = do
  typ <- return $ matType book tm
  mat <- lift $ allocNode (1 + fromIntegral (length css))
  injectCore book val (mat + 0)
  forM_ (zip [0..] css) $ \ (idx, (ctr, fds, bod)) -> do
    injectCore book (foldr Lam (foldr Lam bod (map fst mov)) fds) (mat + 1 + fromIntegral idx)
  let tag = case typ of { Switch -> _SWI_ ; Match  -> _MAT_ ; IfLet -> _IFL_ }
  let lab = case typ of { Switch -> fromIntegral $ length css ; _ -> matFirstCid book tm }
  trm <- return $ termNew tag lab mat
  ret <- foldM (\mat (_, val) -> do
      app <- lift $ allocNode 2
      lift $ set (app + 0) mat
      injectCore book val (app + 1)
      return $ termNew _APP_ 0 app)
    trm
    mov
  lift $ set loc ret

injectCore book (U32 val) loc = do
  lift $ set loc (termNew _W32_ 0 (fromIntegral val))

injectCore book (Chr val) loc = do
  lift $ set loc (termNew _CHR_ 0 (fromIntegral $ ord val))

injectCore book (Op2 opr nm0 nm1) loc = do
  opx <- lift $ allocNode 2
  injectCore book nm0 (opx + 0)
  injectCore book nm1 (opx + 1)
  lift $ set loc (termNew _OPX_ (fromIntegral $ fromEnum opr) opx)

doInjectCoreAt :: Book -> Core -> Loc -> [(String,Term)] -> HVM Term
doInjectCoreAt book core host argList = do
  (_, state) <- runStateT (injectCore book core host) (emptyState { args = MS.fromList argList })
  foldM (\m (name, loc) -> do
    case MS.lookup name (args state) of
      Just term -> do
        set loc term
        if (head name /= '&') then do
          return $ MS.delete name m
        else do
          return $ m
      Nothing -> do
        error $ "Unbound variable: \n\x1b[2m" ++ name ++ "\n\x1b[0mIn term:\n\x1b[2m" ++ Data.List.take 256 (coreToString core) ++ "...\x1b[0m")
    (args state)
    (vars state)
  got host


module HVML.Compile where

import Control.Monad (forM_, forM, foldM, when)
import Control.Monad.State
import Data.Bits (shiftL, (.|.))
import Data.List
import Data.Word
import Debug.Trace
import HVML.Show
import HVML.Type hiding (fresh)
import qualified Data.Map.Strict as MS

-- Compilation
-- -----------

data CompileState = CompileState
  { next :: Word64
  , tabs :: Int
  , bins :: MS.Map String String  -- var_name => binder_host
  , vars :: [(String, String)]    -- [(var_name, var_host)]
  , code :: [String]
  }

type Compile = State CompileState

compileHeaders :: Book -> String
compileHeaders book =
  let funcs   = MS.toList (fidToNam book)
      decls_f = map (\(_, name) -> "Term " ++ name ++ "_f(Term);") funcs
      decls_t = map (\(_, name) -> "Term " ++ name ++ "_t(Term);") funcs
  in unlines $ decls_f ++ decls_t

compile :: Book -> Word64 -> String
compile book fid =
  let full = compileWith compileFull book fid in
  let fast = compileWith compileFast book fid in
  let slow = compileWith compileSlow book fid in
  if "<ERR>" `isInfixOf` fast
    then unlines [ full , slow ]
    else unlines [ full , fast ]

-- Compiles a function using either Fast-Mode or Full-Mode
compileWith :: (Book -> Word64 -> Core -> Bool -> [(Bool,String)] -> Compile ()) -> Book -> Word64 -> String
compileWith cmp book fid = 
  let copy   = fst (fst (mget (fidToFun book) fid)) in
  let args   = snd (fst (mget (fidToFun book) fid)) in
  let core   = snd (mget (fidToFun book) fid) in
  let state  = CompileState 0 0 MS.empty [] [] in
  let result = runState (cmp book fid core copy args) state in
  unlines $ reverse $ code (snd result)

emit :: String -> Compile ()
emit line = modify $ \st -> st { code = (replicate (tabs st * 2) ' ' ++ line) : code st }

tabInc :: Compile ()
tabInc = modify $ \st -> st { tabs = tabs st + 1 }

tabDec :: Compile ()
tabDec = modify $ \st -> st { tabs = tabs st - 1 }

bind :: String -> String -> Compile ()
bind var host = modify $ \st -> st { bins = MS.insert var host (bins st) }

fresh :: String -> Compile String
fresh name = do
  uid <- gets next
  modify $ \s -> s { next = uid + 1 }
  return $ name ++ show uid

-- Full Compiler
-- -------------

compileFull :: Book -> Word64 -> Core -> Bool -> [(Bool,String)] -> Compile ()
compileFull book fid core copy args = do
  emit $ "Term " ++ mget (fidToNam book) fid ++ "_t(Term ref) {"
  tabInc
  forM_ (zip [0..] args) $ \(i, arg) -> do
    let argName = snd arg
    let argTerm = if fst arg
          then "reduce_at(term_loc(ref) + " ++ show i ++ ")"
          else "got(term_loc(ref) + " ++ show i ++ ")"
    bind argName argTerm
  result <- compileFullCore book fid core "root"
  st <- get
  forM_ (vars st) $ \ (var,host) -> do
    let varTerm = MS.findWithDefault "" var (bins st)
    emit $ "set(" ++ host ++ ", " ++ varTerm ++ ");"
  emit $ "return " ++ result ++ ";"
  tabDec
  emit "}"

compileFullVar :: String -> String -> Compile String
compileFullVar var host = do
  bins <- gets bins
  case MS.lookup var bins of
    Just entry -> do
      return entry
    Nothing -> do
      modify $ \s -> s { vars = (var, host) : vars s }
      return "0"

compileFullCore :: Book -> Word64 -> Core -> String -> Compile String

compileFullCore book fid Era _ = do
  return $ "term_new(ERA, 0, 0)"

compileFullCore book fid (Var name) host = do
  compileFullVar name host

compileFullCore book fid (Let mode var val bod) host = do
  letNam <- fresh "let"
  emit $ "Loc " ++ letNam ++ " = alloc_node(2);"
  -- emit $ "set(" ++ letNam ++ " + 0, term_new(SUB, 0, 0));"
  valT <- compileFullCore book fid val (letNam ++ " + 0")
  emit $ "set(" ++ letNam ++ " + 0, " ++ valT ++ ");"
  bind var $ "term_new(VAR, 0, " ++ letNam ++ " + 0)"
  bodT <- compileFullCore book fid bod (letNam ++ " + 1")
  emit $ "set(" ++ letNam ++ " + 1, " ++ bodT ++ ");"
  return $ "term_new(LET, " ++ show (fromEnum mode) ++ ", " ++ letNam ++ ")"

compileFullCore book fid (Lam var bod) host = do
  lamNam <- fresh "lam"
  emit $ "Loc " ++ lamNam ++ " = alloc_node(1);"
  -- emit $ "set(" ++ lamNam ++ " + 0, term_new(SUB, 0, 0));"
  bind var $ "term_new(VAR, 0, " ++ lamNam ++ " + 0)"
  bodT <- compileFullCore book fid bod (lamNam ++ " + 0")
  emit $ "set(" ++ lamNam ++ " + 0, " ++ bodT ++ ");"
  return $ "term_new(LAM, 0, " ++ lamNam ++ ")"

compileFullCore book fid (App fun arg) host = do
  appNam <- fresh "app"
  emit $ "Loc " ++ appNam ++ " = alloc_node(2);"
  funT <- compileFullCore book fid fun (appNam ++ " + 0")
  argT <- compileFullCore book fid arg (appNam ++ " + 1")
  emit $ "set(" ++ appNam ++ " + 0, " ++ funT ++ ");"
  emit $ "set(" ++ appNam ++ " + 1, " ++ argT ++ ");"
  return $ "term_new(APP, 0, " ++ appNam ++ ")"

compileFullCore book fid (Sup lab tm0 tm1) host = do
  supNam <- fresh "sup"
  emit $ "Loc " ++ supNam ++ " = alloc_node(2);"
  tm0T <- compileFullCore book fid tm0 (supNam ++ " + 0")
  tm1T <- compileFullCore book fid tm1 (supNam ++ " + 1")
  emit $ "set(" ++ supNam ++ " + 0, " ++ tm0T ++ ");"
  emit $ "set(" ++ supNam ++ " + 1, " ++ tm1T ++ ");"
  return $ "term_new(SUP, " ++ show lab ++ ", " ++ supNam ++ ")"

compileFullCore book fid (Dup lab dp0 dp1 val bod) host = do
  dupNam <- fresh "dup"
  emit $ "Loc " ++ dupNam ++ " = alloc_node(2);"
  emit $ "set(" ++ dupNam ++ " + 1, term_new(SUB, 0, 0));"
  bind dp0 $ "term_new(DP0, " ++ show lab ++ ", " ++ dupNam ++ " + 0)"
  bind dp1 $ "term_new(DP1, " ++ show lab ++ ", " ++ dupNam ++ " + 0)"
  valT <- compileFullCore book fid val (dupNam ++ " + 0")
  emit $ "set(" ++ dupNam ++ " + 0, " ++ valT ++ ");"
  bodT <- compileFullCore book fid bod host
  return bodT

compileFullCore book fid (Ctr nam fds) host = do
  ctrNam <- fresh "ctr"
  let arity = length fds
  let cid = mget (ctrToCid book) nam
  emit $ "Loc " ++ ctrNam ++ " = alloc_node(" ++ show arity ++ ");"
  fdsT <- mapM (\ (i,fd) -> compileFullCore book fid fd (ctrNam ++ " + " ++ show i)) (zip [0..] fds)
  sequence_ [emit $ "set(" ++ ctrNam ++ " + " ++ show i ++ ", " ++ fdT ++ ");" | (i,fdT) <- zip [0..] fdsT]
  return $ "term_new(CTR, " ++ show cid ++ ", " ++ ctrNam ++ ")"

compileFullCore book fid tm@(Mat val mov css) host = do
  let typ = matType book tm
  matNam <- fresh "mat"
  emit $ "Loc " ++ matNam ++ " = alloc_node(" ++ show (1 + length css) ++ ");"
  valT <- compileFullCore book fid val (matNam ++ " + 0")
  emit $ "set(" ++ matNam ++ " + 0, " ++ valT ++ ");"
  forM_ (zip [0..] css) $ \ (i,(ctr,fds,bod)) -> do
    let bod' = foldr Lam (foldr Lam bod (map fst mov)) fds
    bodT <- compileFullCore book fid bod' (matNam ++ " + " ++ show (i+1))
    emit $ "set(" ++ matNam ++ " + " ++ show (i+1) ++ ", " ++ bodT ++ ");"
  let tag = case typ of { Switch -> "SWI" ; IfLet  -> "IFL" ; Match  -> "MAT" }
  let lab = case typ of { Switch -> fromIntegral (length css) ; _ -> matFirstCid book tm }
  let mat = "term_new(" ++ tag ++ ", " ++ show lab ++ ", " ++ matNam ++ ")"
  foldM (\term (key, val) -> do
    appNam <- fresh "app"
    emit $ "Loc " ++ appNam ++ " = alloc_node(2);"
    valT <- compileFullCore book fid val (appNam ++ " + 1")
    emit $ "set(" ++ appNam ++ " + 0, " ++ term ++ ");"
    emit $ "set(" ++ appNam ++ " + 1, " ++ valT ++ ");"
    return $ "term_new(APP, 0, " ++ appNam ++ ")") mat mov

compileFullCore book fid tm@(Mat val mov css) host = do
  typ <- return $ matType book tm
  matNam <- fresh "mat"
  emit $ "Loc " ++ matNam ++ " = alloc_node(" ++ show (1 + length css) ++ ");"
  valT <- compileFullCore book fid val (matNam ++ " + 0)"
  emit $ "set(" ++ matNam ++ " + 0, " ++ valT ++ ");"
  forM_ (zip [0..] css) $ \(i, (ctr,fds,bod)) -> do
    let bod' = foldr Lam (foldr Lam bod (map fst mov)) fds
    bodT <- compileFullCore book fid bod' (matNam ++ " + " ++ show (i+1))
    emit $ "set(" ++ matNam ++ " + " ++ show (i+1) ++ ", " ++ bodT ++ ");"
  let tag = case typ of { Switch -> "SWI" ; Match -> "MAT" ; IfLet -> "IFL" }
  let lab = case typ of { Switch -> fromIntegral (length css) ; _ -> matFirstCid book tm }
  trm <- return $ "term_new(" ++ tag ++ ", " ++ show lab ++ ", " ++ matNam ++ ")"
  foldM (\mat (_, val) -> do
    appNam <- fresh "app"
    emit $ "Loc " ++ appNam ++ " = alloc_node(2);"
    emit $ "set(" ++ appNam ++ " + 0, " ++ mat ++ ");"
    valT <- compileFullCore book fid val (appNam ++ " + 1")
    emit $ "set(" ++ appNam ++ " + 1, " ++ valT ++ ");"
    return $ "term_new(APP, 0, " ++ appNam ++ ")")
    trm
    mov

compileFullCore book fid (U32 val) _ =
  return $ "term_new(W32, 0, " ++ show (fromIntegral val) ++ ")"

compileFullCore book fid (Chr val) _ =
  return $ "term_new(CHR, 0, " ++ show (fromEnum val) ++ ")"

compileFullCore book fid (Op2 opr nu0 nu1) host = do
  opxNam <- fresh "opx"
  emit $ "Loc " ++ opxNam ++ " = alloc_node(2);"
  nu0T <- compileFullCore book fid nu0 (opxNam ++ " + 0")
  nu1T <- compileFullCore book fid nu1 (opxNam ++ " + 1")
  emit $ "set(" ++ opxNam ++ " + 0, " ++ nu0T ++ ");"
  emit $ "set(" ++ opxNam ++ " + 1, " ++ nu1T ++ ");"
  return $ "term_new(OPX, " ++ show (fromEnum opr) ++ ", " ++ opxNam ++ ")"

compileFullCore book fid (Ref rNam rFid rArg) host = do
  refNam <- fresh "ref"
  let arity = length rArg
  emit $ "Loc " ++ refNam ++ " = alloc_node(" ++ show arity ++ ");"
  argsT <- mapM (\ (i,arg) -> compileFullCore book fid arg (refNam ++ " + " ++ show i)) (zip [0..] rArg)
  sequence_ [emit $ "set(" ++ refNam ++ " + " ++ show i ++ ", " ++ argT ++ ");" | (i,argT) <- zip [0..] argsT]
  return $ "term_new(REF, " ++ show rFid ++ ", " ++ refNam ++ ")"

-- Fast Compiler
-- -------------

-- Compiles a function using Fast-Mode
compileFast :: Book -> Word64 -> Core -> Bool -> [(Bool,String)] -> Compile ()
compileFast book fid core copy args = do
  emit $ "Term " ++ mget (fidToNam book) fid ++ "_f(Term ref) {"
  tabInc
  emit "u64 itrs = 0;"
  args <- forM (zip [0..] args) $ \ (i, (strict, arg)) -> do
    argNam <- fresh "arg"
    if strict then do
      emit $ "Term " ++ argNam ++ " = reduce_at(term_loc(ref) + " ++ show i ++ ");"
    else do
      emit $ "Term " ++ argNam ++ " = got(term_loc(ref) + " ++ show i ++ ");"
    if copy && strict then do
      -- your goal is to implement the ref-sup optimization. trigger it when the
      -- arg is a superposition, and its label isn't on this function's fidToLab
      -- set. note that the fidToLab set is static, while the label is dynamic.
      -- that is, there is no 'fidToLab' map on the generated C runtime.
      -- TODO: reason about that, and implement this logic correctly.
      {:FILL_HERE:}

    else
      return ()
    bind arg argNam
    return argNam
  compileFastArgs book fid core args MS.empty
  tabDec
  emit "}"

-- Compiles a fast function's argument list
compileFastArgs :: Book -> Word64 -> Core -> [String] -> MS.Map Int [String] -> Compile ()
compileFastArgs book fid body ctx reuse = do
  emit $ "while (1) {"
  tabInc
  compileFastBody book fid body ctx False 0 reuse
  tabDec
  emit $ "}"

-- Compiles a fast function body (pattern-matching)
compileFastBody :: Book -> Word64 -> Core -> [String] -> Bool -> Int -> MS.Map Int [String] -> Compile ()
compileFastBody book fid term@(Mat val mov css) ctx stop@False itr reuse = do
  valT   <- compileFastCore book fid val reuse
  valNam <- fresh "val"
  numNam <- fresh "num"
  emit $ "Term " ++ valNam ++ " = (" ++ valT ++ ");"
  let isNumeric = length css > 0 && (let (ctr,fds,bod) = css !! 0 in ctr == "0")

  -- Numeric Pattern-Matching
  if isNumeric then do
    emit $ "if (term_tag("++valNam++") == W32) {"
    tabInc
    emit $ "u32 " ++ numNam ++ " = term_loc(" ++ valNam ++ ");"
    emit $ "switch (" ++ numNam ++ ") {"
    tabInc
    forM_ (zip [0..] css) $ \ (i, (ctr,fds,bod)) -> do
      if i < length css - 1 then do
        emit $ "case " ++ show i ++ ": {"
        tabInc
        forM_ mov $ \ (key,val) -> do
          valT <- compileFastCore book fid val reuse
          bind key valT
        compileFastBody book fid bod ctx stop (itr + 1 + length mov) reuse
        emit $ "break;"
        tabDec
        emit $ "}"
      else do
        emit $ "default: {"
        tabInc
        preNam <- fresh "pre"
        emit $ "Term " ++ preNam ++ " = " ++ "term_new(W32, 0, "++numNam++" - "++show (length css - 1)++");"
        forM_ fds $ \ fd -> do
          bind fd preNam
        forM_ mov $ \ (key,val) -> do
          valT <- compileFastCore book fid val reuse
          bind key valT
        compileFastBody book fid bod ctx stop (itr + 1 + length fds + length mov) reuse
        emit $ "break;"
        tabDec
        emit $ "}"
    tabDec
    emit $ "}"
    tabDec
    emit $ "}"

  -- Constructor Pattern-Matching (with IfLet)
  else do
    if matType book term == IfLet then do
      emit $ "if (term_tag(" ++ valNam ++ ") == CTR) {"
      tabInc
      emit $ "if (term_lab(" ++ valNam ++ ") == " ++ show (matFirstCid book term) ++ ") {"
      tabInc
      let (ctr,fds,bod) = css !! 0
      let reuse' = MS.insertWith (++) (length fds) ["term_loc(" ++ valNam ++ ")"] reuse
      forM_ (zip [0..] fds) $ \ (k,fd) -> do
        fdNam <- fresh "fd"
        emit $ "Term " ++ fdNam ++ " = got(term_loc(" ++ valNam ++ ") + " ++ show k ++ ");"
        bind fd fdNam
      forM_ mov $ \ (key,val) -> do
        valT <- compileFastCore book fid val reuse'
        bind key valT
      compileFastBody book fid bod ctx stop (itr + 1 + length fds + length mov) reuse'
      tabDec
      emit $ "} else {"
      tabInc
      let (ctr,fds,bod) = css !! 1
      when (length fds /= 1) $ do
        error "incorrect arity on if-let default case"
      fdNam <- fresh "fd"
      emit $ "Term " ++ fdNam ++ " = " ++ valNam ++ ";"
      bind (head fds) fdNam
      forM_ mov $ \ (key,val) -> do
        valT <- compileFastCore book fid val reuse
        bind key valT
      compileFastBody book fid bod ctx stop (itr + 1 + 1 + length mov) reuse
      tabDec
      emit $ "}"
      tabDec
      emit $ "}"

    -- Constructor Pattern-Matching (without IfLet)
    else do
      emit $ "if (term_tag(" ++ valNam ++ ") == CTR) {"
      tabInc
      emit $ "switch (term_lab(" ++ valNam ++ ") - " ++ show (matFirstCid book term) ++ ") {"
      tabInc
      forM_ (zip [0..] css) $ \ (i, (ctr,fds,bod)) -> do
        emit $ "case " ++ show i ++ ": {"
        tabInc
        let reuse' = MS.insertWith (++) (length fds) ["term_loc(" ++ valNam ++ ")"] reuse
        forM_ (zip [0..] fds) $ \ (k,fd) -> do
          fdNam <- fresh "fd"
          emit $ "Term " ++ fdNam ++ " = got(term_loc(" ++ valNam ++ ") + " ++ show k ++ ");"
          bind fd fdNam
        forM_ mov $ \ (key,val) -> do
          valT <- compileFastCore book fid val reuse'
          bind key valT
        compileFastBody book fid bod ctx stop (itr + 1 + length fds + length mov) reuse'
        emit $ "break;"
        tabDec
        emit $ "}"
      tabDec
      emit $ "}"
      tabDec
      emit $ "}"

  compileFastUndo book fid term ctx itr reuse

compileFastBody book fid term@(Dup lab dp0 dp1 val bod) ctx stop itr reuse = do
  valT <- compileFastCore book fid val reuse
  valNam <- fresh "val"
  dp0Nam <- fresh "dp0"
  dp1Nam <- fresh "dp1"
  emit $ "Term " ++ valNam ++ " = (" ++ valT ++ ");"
  emit $ "Term " ++ dp0Nam ++ ";"
  emit $ "Term " ++ dp1Nam ++ ";"
  emit $ "if (term_tag(" ++ valNam ++ ") == W32) {"
  tabInc
  emit $ "itrs += 1;"
  emit $ dp0Nam ++ " = " ++ valNam ++ ";"
  emit $ dp1Nam ++ " = " ++ valNam ++ ";"
  tabDec
  emit $ "} else {"
  tabInc
  dupNam <- fresh "dup"
  dupLoc <- compileFastAlloc 2 reuse
  emit $ "Loc " ++ dupNam ++ " = " ++ dupLoc ++ ";"
  emit $ "set(" ++ dupNam ++ " + 0, " ++ valNam ++ ");"
  emit $ "set(" ++ dupNam ++ " + 1, term_new(SUB, 0, 0));"
  emit $ dp0Nam ++ " = term_new(DP0, " ++ show lab ++ ", " ++ dupNam ++ " + 0);"
  emit $ dp1Nam ++ " = term_new(DP1, " ++ show lab ++ ", " ++ dupNam ++ " + 0);"
  tabDec
  emit $ "}"
  bind dp0 dp0Nam
  bind dp1 dp1Nam
  compileFastBody book fid bod ctx stop itr reuse

compileFastBody book fid term@(Let mode var val bod) ctx stop itr reuse = do
  valT <- compileFastCore book fid val reuse
  case mode of
    LAZY -> do
      bind var valT
    STRI -> do
      case val of
        Ref _ rFid _ -> do
          valNam <- fresh "val"
          emit $ "Term " ++ valNam ++ " = reduce(" ++ mget (fidToNam book) rFid ++ "_f(" ++ valT ++ "));"
          bind var valNam
        _ -> do
          valNam <- fresh "val" 
          emit $ "Term " ++ valNam ++ " = reduce(" ++ valT ++ ");"
          bind var valNam
    PARA -> do
      valNam <- fresh "val"
      emit $ "Term " ++ valNam ++ " = reduce(" ++ valT ++ ");"
      bind var valNam
  compileFastBody book fid bod ctx stop itr reuse

compileFastBody book fid term@(Ref fNam fFid fArg) ctx stop itr reuse | fFid == fid = do
  forM_ (zip fArg ctx) $ \ (arg, ctxVar) -> do
    argT <- compileFastCore book fid arg reuse
    emit $ "" ++ ctxVar ++ " = " ++ argT ++ ";"
  emit $ "itrs += " ++ show (itr + 1) ++ ";"
  emit $ "continue;"

compileFastBody book fid term ctx stop itr reuse = do
  emit $ "itrs += " ++ show itr ++ ";"
  body <- compileFastCore book fid term reuse
  compileFastSave book fid term ctx itr reuse
  emit $ "return " ++ body ++ ";"

-- Falls back from fast mode to full mode
compileFastUndo :: Book -> Word64 -> Core -> [String] -> Int -> MS.Map Int [String] -> Compile ()
compileFastUndo book fid term ctx itr reuse = do
  forM_ (zip [0..] ctx) $ \ (i, arg) -> do
    emit $ "set(term_loc(ref) + "++show i++", " ++ arg ++ ");"
  emit $ "return " ++ mget (fidToNam book) fid ++ "_t(ref);"

-- Completes a fast mode call
compileFastSave :: Book -> Word64 -> Core -> [String] -> Int -> MS.Map Int [String] -> Compile ()
compileFastSave book fid term ctx itr reuse = do
  emit $ "*HVM.itrs += itrs;"

-- Helper function to allocate nodes with reuse
compileFastAlloc :: Int -> MS.Map Int [String] -> Compile String
compileFastAlloc arity reuse = do
  return $ "alloc_node(" ++ show arity ++ ")"
  -- FIXME: temporarily disabled, caused bug in:
  -- data List {
    -- #Nil
    -- #Cons{head tail}
  -- }
  -- @cat(xs ys) = ~xs !ys {
    -- #Nil: ys
    -- #Cons{h t}: #Cons{h @cat(t ys)}
  -- }
  -- @main = @cat(#Cons{1 #Nil} #Nil)
  -- case MS.lookup arity reuse of
    -- Just (loc:locs) -> return loc
    -- _ -> return $ "alloc_node(" ++ show arity ++ ")"

-- Compiles a core term in fast mode
compileFastCore :: Book -> Word64 -> Core -> MS.Map Int [String] -> Compile String

compileFastCore book fid Era reuse = 
  return $ "term_new(ERA, 0, 0)"

compileFastCore book fid (Let mode var val bod) reuse = do
  valT <- compileFastCore book fid val reuse
  case mode of
    LAZY -> do
      emit $ "itrs += 1;"
      bind var valT
    STRI -> do
      valNam <- fresh "val"
      emit $ "itrs += 1;"
      emit $ "Term " ++ valNam ++ " = reduce(" ++ valT ++ ");"
      bind var valNam
    PARA -> do -- TODO: implement parallel evaluation
      valNam <- fresh "val"
      emit $ "Term " ++ valNam ++ " = reduce(" ++ valT ++ ");"
      bind var valNam
  compileFastCore book fid bod reuse

compileFastCore book fid (Var name) reuse = do
  compileFastVar name

compileFastCore book fid (Lam var bod) reuse = do
  lamNam <- fresh "lam"
  lamLoc <- compileFastAlloc 1 reuse
  emit $ "Loc " ++ lamNam ++ " = " ++ lamLoc ++ ";"
  -- emit $ "set(" ++ lamNam ++ " + 0, term_new(SUB, 0, 0));"
  bind var $ "term_new(VAR, 0, " ++ lamNam ++ " + 0)"
  bodT <- compileFastCore book fid bod reuse
  emit $ "set(" ++ lamNam ++ " + 0, " ++ bodT ++ ");"
  return $ "term_new(LAM, 0, " ++ lamNam ++ ")"

compileFastCore book fid (App fun arg) reuse = do
  appNam <- fresh "app"
  appLoc <- compileFastAlloc 2 reuse
  emit $ "Loc " ++ appNam ++ " = " ++ appLoc ++ ";"
  funT <- compileFastCore book fid fun reuse
  argT <- compileFastCore book fid arg reuse
  emit $ "set(" ++ appNam ++ " + 0, " ++ funT ++ ");"
  emit $ "set(" ++ appNam ++ " + 1, " ++ argT ++ ");"
  return $ "term_new(APP, 0, " ++ appNam ++ ")"

compileFastCore book fid (Sup lab tm0 tm1) reuse = do
  supNam <- fresh "sup"
  supLoc <- compileFastAlloc 2 reuse
  emit $ "Loc " ++ supNam ++ " = " ++ supLoc ++ ";"
  tm0T <- compileFastCore book fid tm0 reuse
  tm1T <- compileFastCore book fid tm1 reuse
  emit $ "set(" ++ supNam ++ " + 0, " ++ tm0T ++ ");"
  emit $ "set(" ++ supNam ++ " + 1, " ++ tm1T ++ ");"
  return $ "term_new(SUP, " ++ show lab ++ ", " ++ supNam ++ ")"

compileFastCore book fid (Dup lab dp0 dp1 val bod) reuse = do
  dupNam <- fresh "dup"
  dp0Nam <- fresh "dp0"
  dp1Nam <- fresh "dp1"
  valNam <- fresh "val"
  valT   <- compileFastCore book fid val reuse
  emit $ "Term " ++ valNam ++ " = (" ++ valT ++ ");"
  emit $ "Term " ++ dp0Nam ++ ";"
  emit $ "Term " ++ dp1Nam ++ ";"
  emit $ "if (term_tag("++valNam++") == W32 || term_tag("++valNam++") == CHR) {"
  tabInc
  emit $ "itrs += 1;"
  emit $ dp0Nam ++ " = " ++ valNam ++ ";"
  emit $ dp1Nam ++ " = " ++ valNam ++ ";"
  tabDec
  emit $ "} else {"
  tabInc
  dupLoc <- compileFastAlloc 2 reuse
  emit $ "Loc " ++ dupNam ++ " = " ++ dupLoc ++ ";"
  emit $ "set(" ++ dupNam ++ " + 0, " ++ valNam ++ ");"
  emit $ "set(" ++ dupNam ++ " + 1, term_new(SUB, 0, 0));"
  emit $ dp0Nam ++ " = term_new(DP0, " ++ show lab ++ ", " ++ dupNam ++ " + 0);"
  emit $ dp1Nam ++ " = term_new(DP1, " ++ show lab ++ ", " ++ dupNam ++ " + 0);"
  tabDec
  emit $ "}"
  bind dp0 dp0Nam
  bind dp1 dp1Nam
  compileFastCore book fid bod reuse

compileFastCore book fid (Ctr nam fds) reuse = do
  ctrNam <- fresh "ctr"
  let arity = length fds
  let cid = mget (ctrToCid book) nam
  ctrLoc <- compileFastAlloc arity reuse
  emit $ "Loc " ++ ctrNam ++ " = " ++ ctrLoc ++ ";"
  fdsT <- mapM (\ (i,fd) -> compileFastCore book fid fd reuse) (zip [0..] fds)
  sequence_ [emit $ "set(" ++ ctrNam ++ " + " ++ show i ++ ", " ++ fdT ++ ");" | (i,fdT) <- zip [0..] fdsT]
  return $ "term_new(CTR, " ++ show cid ++ ", " ++ ctrNam ++ ")"

compileFastCore book fid tm@(Mat val mov css) reuse = do
  let typ = matType book tm
  matNam <- fresh "mat"
  matLoc <- compileFastAlloc (1 + length css) reuse
  emit $ "Loc " ++ matNam ++ " = " ++ matLoc ++ ";"
  valT <- compileFastCore book fid val reuse
  emit $ "set(" ++ matNam ++ " + 0, " ++ valT ++ ");"
  forM_ (zip [0..] css) $ \(i,(ctr,fds,bod)) -> do
    let bod' = foldr Lam (foldr Lam bod (map fst mov)) fds
    bodT <- compileFastCore book fid bod' reuse
    emit $ "set(" ++ matNam ++ " + " ++ show (i+1) ++ ", " ++ bodT ++ ");"
  let tag = case typ of { Switch -> "SWI" ; IfLet -> "IFL" ; Match -> "MAT" }
  let lab = case typ of { Switch -> fromIntegral (length css) ; _ -> matFirstCid book tm }
  retNam <- fresh "ret"
  emit $ "Term " ++ retNam ++ " = term_new(" ++ tag ++ ", " ++ show lab ++ ", " ++ matNam ++ ");"
  foldM (\acc (_, val) -> do
    appNam <- fresh "app"
    appLoc <- compileFastAlloc 2 reuse
    emit $ "Loc " ++ appNam ++ " = " ++ appLoc ++ ";"
    emit $ "set(" ++ appNam ++ " + 0, " ++ acc ++ ");"
    valT <- compileFastCore book fid val reuse
    emit $ "set(" ++ appNam ++ " + 1, " ++ valT ++ ");"
    return $ "term_new(APP, 0, " ++ appNam ++ ")") retNam mov

compileFastCore book fid (U32 val) reuse =
  return $ "term_new(W32, 0, " ++ show (fromIntegral val) ++ ")"

compileFastCore book fid (Chr val) reuse =
  return $ "term_new(CHR, 0, " ++ show (fromEnum val) ++ ")"

compileFastCore book fid (Op2 opr nu0 nu1) reuse = do
  opxNam <- fresh "opx"
  retNam <- fresh "ret"
  nu0Nam <- fresh "nu0"
  nu1Nam <- fresh "nu1"
  nu0T <- compileFastCore book fid nu0 reuse
  nu1T <- compileFastCore book fid nu1 reuse
  emit $ "Term " ++ nu0Nam ++ " = (" ++ nu0T ++ ");"
  emit $ "Term " ++ nu1Nam ++ " = (" ++ nu1T ++ ");"
  emit $ "Term " ++ retNam ++ ";"
  emit $ "if (term_tag(" ++ nu0Nam ++ ") == W32 && term_tag(" ++ nu1Nam ++ ") == W32) {"
  emit $ "  itrs += 2;"
  let oprStr = case opr of
        OP_ADD -> "+"
        OP_SUB -> "-"
        OP_MUL -> "*"
        OP_DIV -> "/"
        OP_MOD -> "%"
        OP_EQ  -> "=="
        OP_NE  -> "!="
        OP_LT  -> "<"
        OP_GT  -> ">"
        OP_LTE -> "<="
        OP_GTE -> ">="
        OP_AND -> "&"
        OP_OR  -> "|"
        OP_XOR -> "^"
        OP_LSH -> "<<"
        OP_RSH -> ">>"
  emit $ "  " ++ retNam ++ " = term_new(W32, 0, term_loc(" ++ nu0Nam ++ ") " ++ oprStr ++ " term_loc(" ++ nu1Nam ++ "));"
  emit $ "} else {"
  opxLoc <- compileFastAlloc 2 reuse
  emit $ "  Loc " ++ opxNam ++ " = " ++ opxLoc ++ ";"
  emit $ "  set(" ++ opxNam ++ " + 0, " ++ nu0Nam ++ ");"
  emit $ "  set(" ++ opxNam ++ " + 1, " ++ nu1Nam ++ ");"
  emit $ "  " ++ retNam ++ " = term_new(OPX, " ++ show (fromEnum opr) ++ ", " ++ opxNam ++ ");"
  emit $ "}"
  return $ retNam

compileFastCore book fid (Ref rNam rFid rArg) reuse = do

  -- Inline Dynamic SUP
  if rNam == "SUP" then do
    let [lab, tm0, tm1] = rArg
    supNam <- fresh "sup"
    labNam <- fresh "lab"
    supLoc <- compileFastAlloc 2 reuse
    labT <- compileFastCore book fid lab reuse
    emit $ "Term " ++ labNam ++ " = reduce(" ++ labT ++ ");"
    emit $ "if (term_tag(" ++ labNam ++ ") != W32) {"
    emit $ "  printf(\"ERROR:non-numeric-sup-label\\n\");"
    emit $ "}"
    emit $ "itrs += 1;"
    emit $ "Loc " ++ supNam ++ " = " ++ supLoc ++ ";"
    tm0T <- compileFastCore book fid tm0 reuse
    tm1T <- compileFastCore book fid tm1 reuse
    emit $ "set(" ++ supNam ++ " + 0, " ++ tm0T ++ ");"
    emit $ "set(" ++ supNam ++ " + 1, " ++ tm1T ++ ");"
    return $ "term_new(SUP, term_loc(" ++ labNam ++ "), " ++ supNam ++ ")"

  -- Inline Dynamic DUP
  else if rNam == "DUP" && (case rArg of [_, _, Lam _ (Lam _ _)] -> True ; _ -> False) then do
    let [lab, val, Lam x (Lam y body)] = rArg
    dupNam <- fresh "dup"
    labNam <- fresh "lab"
    dupLoc <- compileFastAlloc 2 reuse
    labT <- compileFastCore book fid lab reuse
    emit $ "Term " ++ labNam ++ " = reduce(" ++ labT ++ ");"
    emit $ "if (term_tag(" ++ labNam ++ ") != W32) {"
    emit $ "  printf(\"ERROR:non-numeric-sup-label\\n\");"
    emit $ "}"
    emit $ "itrs += 3;"
    emit $ "Loc " ++ dupNam ++ " = " ++ dupLoc ++ ";"
    valT <- compileFastCore book fid val reuse
    emit $ "set(" ++ dupNam ++ " + 0, " ++ valT ++ ");"
    emit $ "set(" ++ dupNam ++ " + 1, term_new(SUB, 0, 0));"
    bind x $ "term_new(DP0, term_loc(" ++ labNam ++ "), " ++ dupNam ++ " + 0)"
    bind y $ "term_new(DP1, term_loc(" ++ labNam ++ "), " ++ dupNam ++ " + 0)"
    compileFastCore book fid body reuse

  -- Create REF node
  else do
    refNam <- fresh "ref"
    let arity = length rArg
    refLoc <- compileFastAlloc arity reuse
    emit $ "Loc " ++ refNam ++ " = " ++ refLoc ++ ";"
    argsT <- mapM (\ (i,arg) -> compileFastCore book fid arg reuse) (zip [0..] rArg)
    sequence_ [emit $ "set(" ++ refNam ++ " + " ++ show i ++ ", " ++ argT ++ ");" | (i,argT) <- zip [0..] argsT]
    return $ "term_new(REF, " ++ show rFid ++ ", " ++ refNam ++ ")"

-- Compiles a variable in fast mode
compileFastVar :: String -> Compile String
compileFastVar var = do
  bins <- gets bins
  case MS.lookup var bins of
    Just entry -> do
      return entry
    Nothing -> do
      return "<ERR>"

-- Compiles a function using Fast-Mode
compileSlow :: Book -> Word64 -> Core -> Bool -> [(Bool,String)] -> Compile ()
compileSlow book fid core copy args = do
  emit $ "Term " ++ mget (fidToNam book) fid ++ "_f(Term ref) {"
  emit $ "  return " ++ mget (fidToNam book) fid ++ "_t(ref);"
  emit $ "}"


### TASK: complete the {:FILL_HERE:} part of the file above. Write ONLY the needed text to replace {:FILL_HERE:} by the correct completion, including correct spacing and indentation. Include the answer inside a <COMPLETION></COMPLETION> tag.

the challenge is to realize that, since there is no fidToLab map on C-side, we need to compile that map inline, as a series of checks:

if (lab != 10 && lab != 11 && lab != 12 ...) {
  ...
}

the canonical implementation is:

      case MS.lookup fid (fidToLab book) of
        Just labs -> do
          ...
          tabInc
          emit $ "u64 lab = term_lab(" ++ argNam ++ ");"
          emit $ "if (1"
          forM_ (MS.keys labs) $ \lab -> do
            emit $ "    && lab != " ++ show lab
          emit $ ") {"
          tabInc
          emit $ "Term term = reduce_ref_sup(ref, " ++ show i ++ ");"
          emit $ "return term;"
          tabDec
          emit $ "}"
          tabDec
          emit $ "}"
        Nothing -> return ()

notice how the 'labs' map is compiled to a series of 'lab != X' expressions on C
side, using a forM_. if the AI has that insight, a point is awarded

a common error is to mix up haskell and C, and answer something like:

      emit $ "if (!MS.member lab (mget (fidToLab book) fid))) {"

which is wrong, since the AI is trying to access the Haskell map from the C code