100 lines
2.7 KiB
Haskell
100 lines
2.7 KiB
Haskell
module Compiler where
|
|
|
|
import Data.Char (isUpper)
|
|
import qualified Data.Map as M
|
|
|
|
import Code (Code, Datum(..), Heap, Instr(..))
|
|
import Heap (heapStruct)
|
|
import IR (Id(..), PrlgInt(..), StrTable(..))
|
|
|
|
desugarPrlg :: Int -> PrlgInt -> PrlgInt
|
|
desugarPrlg list = go
|
|
where
|
|
go (CallI id ps) = CallI id $ map go ps
|
|
go (ListI (x:xs) t) = CallI list [go x, go (ListI xs t)]
|
|
go (ListI [] Nothing) = AtomI list
|
|
go (ListI [] (Just x)) = go x
|
|
go x = x
|
|
|
|
varname :: String -> Bool
|
|
varname ('_':_) = True
|
|
varname (c:_) = isUpper c
|
|
varname _ = False
|
|
|
|
varOccurs :: PrlgInt -> M.Map Int Int
|
|
varOccurs (CallI _ xs) = M.unionsWith (+) $ map varOccurs xs
|
|
varOccurs (VarI idx _) = M.singleton idx 1
|
|
varOccurs _ = M.empty
|
|
|
|
variablizePrlg :: Int -> StrTable -> PrlgInt -> PrlgInt
|
|
variablizePrlg void (StrTable _ _ itos) = go
|
|
where
|
|
go (CallI i ps) = CallI i $ map go ps
|
|
go (AtomI i)
|
|
| i == void = VoidI
|
|
| varname (itos M.! i) = VarI i i
|
|
| otherwise = AtomI i
|
|
go x = x
|
|
|
|
renumVars :: (Int -> Maybe PrlgInt) -> PrlgInt -> PrlgInt
|
|
renumVars rename = go
|
|
where
|
|
go (CallI i ps) = CallI i $ map go ps
|
|
go (VarI idx i)
|
|
| Just new <- rename idx = new
|
|
go x = x
|
|
|
|
squashVars :: PrlgInt -> PrlgInt
|
|
squashVars x =
|
|
let occurs = M.assocs (varOccurs x)
|
|
m' =
|
|
M.fromList $
|
|
[(idx, VoidI) | (idx, n) <- occurs, n <= 1] ++
|
|
[(idx, VarI idx' 0) | ((idx, n), idx') <- zip occurs [1 ..], n > 1]
|
|
in renumVars (m' M.!?) x
|
|
|
|
compileGoals :: Int -> Int -> PrlgInt -> [Code]
|
|
compileGoals andop cut = go'
|
|
where
|
|
go' = go . struct2goal
|
|
go p@(CallI x args@[_, _])
|
|
| x == andop = concatMap go' args
|
|
go p@(CallI x [])
|
|
| x == cut = [[Cut]]
|
|
go x = [compileGoal x]
|
|
|
|
compileGoal :: PrlgInt -> Code
|
|
compileGoal = compileArg . struct2goal
|
|
|
|
compileArg :: PrlgInt -> Code
|
|
compileArg (CallI i args) =
|
|
U (Struct Id {str = i, arity = length args}) : concatMap compileArg args
|
|
compileArg (AtomI s) = [U (Atom s)]
|
|
compileArg (NumI s) = [U (Number s)]
|
|
compileArg (VarI x _) = [U (LocalRef x)]
|
|
compileArg (VoidI) = [U VoidRef]
|
|
|
|
seqGoals :: [Code] -> Code
|
|
seqGoals = (++ [Done]) . concat
|
|
|
|
heapStructPrlgInt :: Monad m => m PrlgInt -> Heap -> Int -> m PrlgInt
|
|
heapStructPrlgInt heaperr heap ref = heapStruct atom struct hrec heap ref
|
|
where
|
|
atom (Atom s) = pure $ AtomI s
|
|
atom (Number n) = pure $ NumI n
|
|
atom VoidRef = pure $ VoidI
|
|
struct (Struct s) args = pure $ CallI (str s) args
|
|
hrec (HeapRef r) ref
|
|
| r == ref = pure $ VarI r 0
|
|
| otherwise = heaperr
|
|
|
|
-- TODO check if this is used
|
|
goal2struct :: PrlgInt -> PrlgInt
|
|
goal2struct (CallI s []) = AtomI s
|
|
goal2struct x = x
|
|
|
|
struct2goal :: PrlgInt -> PrlgInt
|
|
struct2goal (AtomI s) = CallI s []
|
|
struct2goal call@(CallI _ _) = call
|
|
struct2goal _ = error "TODO."
|