anoma/juvix
1
1
Fork 0
mirror of https://github.com/anoma/juvix.git synced 2024-09-11 08:15:41 +03:00
Code Issues Projects Releases Wiki Activity

Fix memory access order in the JuvixReg to CASM translation. (#2697)

Browse Source 
Cairo VM imposes restrictions on memory access order stricter than
described in the documentation, which necessitates changing the
compilation concept for local variables.

Summary
-------------

To ensure that memory is accessed sequentially at all times, we divide
instructions into basic blocks. Within each basic block, the `ap` offset
(i.e. how much `ap` increased since the beginning of the block) is known
at each instruction, which allows to statically associate `fp` offsets
to local variables while still generating only sequential assignments to
`[ap]` with increasing `ap`. When the `ap` offset can no longer be
statically determined for new local variables (e.g. due to an
intervening recursive call), we switch to the next basic block by
calling it with the `call` instruction. The arguments of the basic block
call are the variables live at the beginning of the called block. Note
that the `fp` offsets of "old" variables are still statically determined
even after the current `ap` offset becomes unknown -- the arbitrary
increase of `ap` does not influence the previous variable associations.
Hence, we can transfer the needed local variables to the next basic
block.

Example
-----------

The JuvixReg function
```
function f(integer) : integer {
  tmp[0] = add arg[0] 1;
  tmp[1] = call g(tmp[0]);
  tmp[2] = add tmp[1] arg[0];
  tmp[3] = mul tmp[2] 2;
  tmp[4] = call g(tmp[2]);
  tmp[5] = add tmp[4] tmp[3];
  ret tmp[5];
}
```
is compiled to
```
f:
  -- code for basic block 1
  [ap] = [fp - 3] + 1; ap++
  -- now [fp] is tmp[0], because fp = ap at function start (ap offset is zero) 
  -- transfer call argument (in this case, could be optimized away)
  [ap] = [fp]; ap++
  call g
  -- now [ap - 1] contains the result tmp[1] (it is already a call argument now)
  -- we additionally transfer arg[0] which is live in the next block
  [ap] = [fp - 3]; ap++
  call rel 3
  ret
  nop

  -- code for basic block 2
  -- the above "call rel" jumps here
  -- [fp - 4] is tmp[1] 
  -- [fp - 3] is arg[0]
  [ap] = [fp - 4] + [fp - 3]; ap++
  -- now [fp] is tmp[2]
  [ap] = [fp] * 2; ap++
  -- now [fp + 1] is tmp[3]
  [ap] = [fp]; ap++
  call g
  -- now [ap - 1] is tmp[4]
  [ap] = [fp + 1]; ap++
  call rel 3
  ret
  nop

  -- code for basic block 3
  -- [fp - 4] is tmp[4]
  -- [fp - 3] is tmp[3]
  [ap] = [fp - 4] + [fp - 3]; ap++
  -- now [fp] is tmp[5]
  -- the next assignment could be optimized away in this case
  [ap] = [fp]; ap++
  ret  
```
There are three basic blocks separated by the `call` instructions. In
each basic block, we know statically the `ap` offset at each instruction
(i.e. how much `ap` increased since the beginning of the block). We can
therefore associate the temporary variables with `[fp + k]` for
appropriate `k`. At basic block boundaries we transfer live temporary
variables as arguments for the call to the next basic block.

Checklist
------------
- [x] Divide JuvixReg instructions into [basic
blocks](https://en.wikipedia.org/wiki/Basic_block).
- [x] Implement liveness analysis for each basic block.
- [x] Translate transitions between basic blocks into CASM relative
calls with local live variable transfer.
- [x] Tests for the translation from JuvixReg to Cairo bytecode executed
with the Cairo VM
This commit is contained in:
Łukasz Czajka 2024-03-27 10:40:24 +01:00 committed by GitHub
parent 7d559b1f18
commit ee2f8aefbc
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
29 changed files with 1418 additions and 841 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
runtime/src/tree/apply.jvt
View File

@ -27,11 +27,11 @@ function juvix_apply_3(*, *, *, *) : * {
save[n](argsnum(arg[0])) {
br(eq(3, n)) {
true: call(arg[0], arg[1], arg[2], arg[3])
false: br(lt(3, n)) {
true: cextend(arg[0], arg[1], arg[2], arg[3])
false: br(eq(2, n)) {
true: call[juvix_apply_1](call(arg[0], arg[1], arg[2]), arg[3])
false: call[juvix_apply_2](call(arg[0], arg[1]), arg[2], arg[3])
false: br(eq(2, n)) {
true: call[juvix_apply_1](call(arg[0], arg[1], arg[2]), arg[3])
false: br(eq(1, n)) {
true: call[juvix_apply_2](call(arg[0], arg[1]), arg[2], arg[3])
false: cextend(arg[0], arg[1], arg[2], arg[3])
}
}
}
@ -42,13 +42,13 @@ function juvix_apply_4(*, *, *, *, *) : * {
save[n](argsnum(arg[0])) {
br(eq(4, n)) {
true: call(arg[0], arg[1], arg[2], arg[3], arg[4])
false: br(lt(4, n)) {
true: cextend(arg[0], arg[1], arg[2], arg[3], arg[4])
false: br(eq(3, n)) {
true: call[juvix_apply_1](call(arg[0], arg[1], arg[2], arg[3]), arg[4])
false: br(eq(2, n)) {
true: call[juvix_apply_2](call(arg[0], arg[1], arg[2]), arg[3], arg[4])
false: call[juvix_apply_3](call(arg[0], arg[1]), arg[2], arg[3], arg[4])
false: br(eq(3, n)) {
true: call[juvix_apply_1](call(arg[0], arg[1], arg[2], arg[3]), arg[4])
false: br(eq(2, n)) {
true: call[juvix_apply_2](call(arg[0], arg[1], arg[2]), arg[3], arg[4])
false: br(eq(1, n)) {
true: call[juvix_apply_3](call(arg[0], arg[1]), arg[2], arg[3], arg[4])
false: cextend(arg[0], arg[1], arg[2], arg[3], arg[4])
}
}
}

59
src/Juvix/Compiler/Casm/Extra/Base.hs
View File

@ -1,6 +1,5 @@
module Juvix.Compiler.Casm.Extra.Base where
import Juvix.Compiler.Casm.Data.Limits
import Juvix.Compiler.Casm.Language
toOffset :: (Show a, Integral a) => a -> Offset
@ -15,57 +14,6 @@ adjustAp idx mr@MemRef {..} = case _memRefReg of
Ap -> MemRef Ap (_memRefOff - idx)
Fp -> mr
mkExtraBinop :: ExtraOpcode -> MemRef -> MemRef -> Value -> Instruction
mkExtraBinop op res arg1 arg2 =
ExtraBinop
InstrExtraBinop
{ _instrExtraBinopOpcode = op,
_instrExtraBinopResult = res,
_instrExtraBinopArg1 = arg1,
_instrExtraBinopArg2 = arg2,
_instrExtraBinopIncAp = False
}
mkNativeBinop :: Opcode -> MemRef -> MemRef -> Value -> Instruction
mkNativeBinop op res arg1 arg2 =
Assign
InstrAssign
{ _instrAssignResult = res,
_instrAssignValue =
Binop
BinopValue
{ _binopValueOpcode = op,
_binopValueArg1 = arg1,
_binopValueArg2 = arg2
},
_instrAssignIncAp = False
}
mkEq :: MemRef -> MemRef -> Value -> Instruction
mkEq res arg1 arg2 = mkExtraBinop FieldSub res arg1 arg2
mkIntLe :: MemRef -> MemRef -> Value -> [Instruction]
mkIntLe res arg1 arg2 = case arg2 of
Imm v ->
[mkExtraBinop IntLt res arg1 (Imm (v + 1))]
Ref mref ->
[inc, mkExtraBinop IntLt res (adjustAp 1 arg1) (Ref $ MemRef Ap (-1))]
where
inc =
Assign
InstrAssign
{ _instrAssignResult = MemRef Ap 0,
_instrAssignValue =
Binop
BinopValue
{ _binopValueArg1 = mref,
_binopValueArg2 = Imm 1,
_binopValueOpcode = FieldAdd
},
_instrAssignIncAp = True
}
Lab {} -> impossible
mkAssign :: MemRef -> RValue -> Instruction
mkAssign mr rv =
Assign
@ -84,13 +32,6 @@ mkAssignAp v =
_instrAssignIncAp = True
}
mkOpArgsNum :: MemRef -> MemRef -> [Instruction]
mkOpArgsNum res v =
[ mkAssignAp (Val $ Imm $ fromIntegral casmMaxFunctionArgs + 1),
mkAssignAp (Load $ LoadValue (adjustAp 1 v) casmClosureArgsNumOffset),
mkExtraBinop FieldSub res (MemRef Ap (-2)) (Ref $ MemRef Ap (-1))
]
mkCallRel :: Value -> Instruction
mkCallRel tgt = Call (InstrCall tgt True)

611
src/Juvix/Compiler/Casm/Translation/FromReg.hs
View File

@ -2,16 +2,16 @@ module Juvix.Compiler.Casm.Translation.FromReg where
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet
import Juvix.Compiler.Backend
import Juvix.Compiler.Casm.Data.LabelInfoBuilder
import Juvix.Compiler.Casm.Data.Limits
import Juvix.Compiler.Casm.Data.Result
import Juvix.Compiler.Casm.Extra.Base
import Juvix.Compiler.Casm.Extra.Stdlib
import Juvix.Compiler.Casm.Language
import Juvix.Compiler.Reg.Data.InfoTable qualified as Reg
import Juvix.Compiler.Reg.Extra.Info qualified as Reg
import Juvix.Compiler.Reg.Language qualified as Reg
import Juvix.Compiler.Casm.Translation.FromReg.CasmBuilder
import Juvix.Compiler.Reg.Data.Blocks.InfoTable qualified as Reg
import Juvix.Compiler.Reg.Extra.Blocks.Info qualified as Reg
import Juvix.Compiler.Reg.Language.Blocks qualified as Reg
import Juvix.Compiler.Tree.Evaluator.Builtins qualified as Reg
import Juvix.Data.Field
@ -34,7 +34,7 @@ fromReg tab = uncurry Result $ run $ runLabelInfoBuilderWithNextId (Reg.getNextS
return $ callInstr : jmpInstr : binstrs ++ cinstrs ++ instrs ++ [Label endLab]
where
info :: Reg.ExtraInfo
info = Reg.computeExtraInfo (getLimits TargetCairo False) tab
info = Reg.computeExtraInfo tab
mkFunCall :: Symbol -> [Instruction]
mkFunCall sym =
@ -47,6 +47,9 @@ fromReg tab = uncurry Result $ run $ runLabelInfoBuilderWithNextId (Reg.getNextS
getTagId tag =
1 + 2 * fromJust (HashMap.lookup tag (info ^. Reg.extraInfoCIDs))
unsupported :: Text -> a
unsupported what = error ("Cairo backend: unsupported: " <> what)
goFun :: forall r. (Member LabelInfoBuilder r) => StdlibBuiltins -> LabelRef -> (Address, [[Instruction]]) -> Reg.FunctionInfo -> Sem r (Address, [[Instruction]])
goFun blts failLab (addr0, acc) funInfo = do
let sym = funInfo ^. Reg.functionSymbol
@ -54,49 +57,88 @@ fromReg tab = uncurry Result $ run $ runLabelInfoBuilderWithNextId (Reg.getNextS
registerLabelName sym funName
registerLabelAddress sym addr0
let lab = Label $ LabelRef sym (Just funName)
code = funInfo ^. Reg.functionCode
n = fromJust $ HashMap.lookup (funInfo ^. Reg.functionSymbol) (info ^. Reg.extraInfoLocalVarsNum)
i1 = Alloc $ InstrAlloc $ Val $ Imm $ fromIntegral n
pre = [lab, i1]
block = funInfo ^. Reg.functionCode
pre = [lab]
addr1 = addr0 + length pre
instrs <- goCode addr1 code
n = funInfo ^. Reg.functionArgsNum
let vars =
HashMap.fromList $
map (\k -> (Reg.VarRef Reg.VarGroupArgs k Nothing, -3 - k)) [0 .. n - 1]
instrs <-
fmap fst
. runCasmBuilder addr1 vars
. runOutputList
$ goBlock blts failLab mempty Nothing block
return (addr1 + length instrs, (pre ++ instrs) : acc)
-- To ensure that memory is accessed sequentially at all times, we divide
-- instructions into basic blocks. Within each basic block, the `ap` offset
-- is known at each instruction, which allows to statically associate `fp`
-- offsets to variables while still generating only sequential assignments
-- to `[ap]` with increasing `ap`. When the `ap` offset can no longer be
-- statically determined for new variables (e.g. due to an intervening
-- recursive call), we switch to the next basic block by "calling" it with
-- the `call` instruction (see `goCallBlock`). The arguments of the basic
-- block call are the variables live at the beginning of the block. Note
-- that the `fp` offsets of "old" variables are still statically determined
-- even after the current `ap` offset becomes unknown -- the arbitrary
-- increase of `ap` does not influence the previous variable associations.
goBlock :: forall r. (Members '[LabelInfoBuilder, CasmBuilder, Output Instruction] r) => StdlibBuiltins -> LabelRef -> HashSet Reg.VarRef -> Maybe Reg.VarRef -> Reg.Block -> Sem r ()
goBlock blts failLab liveVars0 mout Reg.Block {..} = do
mapM_ goInstr _blockBody
case _blockNext of
Just block' -> do
eassert (isJust _blockFinal)
goFinalInstr (block' ^. Reg.blockLiveVars) (fromJust _blockFinal)
goBlock blts failLab liveVars0 mout block'
Nothing -> case _blockFinal of
Just instr ->
goFinalInstr liveVars0 instr
Nothing -> do
eassert (isJust mout)
eassert (HashSet.member (fromJust mout) liveVars0)
goCallBlock Nothing liveVars0
where
unsupported :: Text -> a
unsupported what = error ("Cairo backend: unsupported: " <> what)
output'' :: Instruction -> Sem r ()
output'' i = do
output i
incPC 1
goCode :: Address -> Reg.Code -> Sem r [Instruction]
goCode addr code = concat . reverse . snd <$> foldM go' (addr, []) code
where
go' :: (Address, [[Instruction]]) -> Reg.Instruction -> Sem r (Address, [[Instruction]])
go' (addr', acc') i = do
is <- goInstr addr' i
return (addr' + length is, is : acc')
output' :: Int -> Instruction -> Sem r ()
output' apOff i = do
output'' i
incAP apOff
goInstr :: Address -> Reg.Instruction -> Sem r [Instruction]
goInstr addr = \case
Reg.Binop x -> goBinop addr x
Reg.Unop x -> goUnop addr x
Reg.Assign x -> goAssign addr x
Reg.Alloc x -> goAlloc addr x
Reg.AllocClosure x -> goAllocClosure addr x
Reg.ExtendClosure x -> goExtendClosure addr x
Reg.Call x -> goCall addr x
Reg.TailCall x -> goTailCall addr x
Reg.CallClosures {} -> impossible
Reg.TailCallClosures {} -> impossible
Reg.Return x -> goReturn addr x
Reg.Branch x -> goBranch addr x
Reg.Case x -> goCase addr x
Reg.Trace x -> goTrace addr x
Reg.Dump -> unsupported "dump"
Reg.Failure x -> goFail addr x
Reg.Prealloc {} -> return []
Reg.Nop -> return []
Reg.Block x -> goBlock addr x
goCallBlock :: Maybe Reg.VarRef -> HashSet Reg.VarRef -> Sem r ()
goCallBlock outVar liveVars = do
let liveVars' = toList (maybe liveVars (flip HashSet.delete liveVars) outVar)
n = length liveVars'
vars =
HashMap.fromList $
maybe [] (\var -> [(var, -3 - n)]) outVar
++ zipWithExact (\var k -> (var, -3 - k)) liveVars' [0 .. n - 1]
mapM_ (mkMemRef >=> goAssignAp . Val . Ref) (reverse liveVars')
output'' (mkCallRel $ Imm 3)
output'' Return
-- we need the Nop instruction to ensure that the relative call offset
-- (constant 3) in our CASM interpreter corresponds to the relative
-- call offset in the Cairo binary representation
output'' Nop
setAP 0
setVars vars
goConst :: Reg.Constant -> Integer
goConst = \case
goLocalBlock :: Int -> HashMap Reg.VarRef Int -> HashSet Reg.VarRef -> Maybe Reg.VarRef -> Reg.Block -> Sem r ()
goLocalBlock ap0 vars liveVars mout' block = do
setAP ap0
setVars vars
goBlock blts failLab liveVars mout' block
----------------------------------------------------------------------
-- The mk* functions don't change the builder state, may only read it
----------------------------------------------------------------------
mkConst :: Reg.Constant -> Integer
mkConst = \case
Reg.ConstInt x -> x
Reg.ConstBool True -> 0
Reg.ConstBool False -> 1
@ -105,235 +147,323 @@ fromReg tab = uncurry Result $ run $ runLabelInfoBuilderWithNextId (Reg.getNextS
Reg.ConstVoid -> 0
Reg.ConstString {} -> unsupported "strings"
goConstrField :: Reg.ConstrField -> RValue
goConstrField Reg.ConstrField {..} =
Load $ LoadValue (goVarRef _constrFieldRef) (toOffset _constrFieldIndex + 1)
mkLoad :: Reg.ConstrField -> Sem r RValue
mkLoad Reg.ConstrField {..} = do
v <- mkMemRef _constrFieldRef
return $ Load $ LoadValue v (toOffset _constrFieldIndex + 1)
goVarRef :: Reg.VarRef -> MemRef
goVarRef Reg.VarRef {..} = case _varRefGroup of
Reg.VarGroupArgs ->
MemRef Fp (-3 - toOffset _varRefIndex)
Reg.VarGroupLocal ->
MemRef Fp (toOffset _varRefIndex)
mkMemRef :: Reg.VarRef -> Sem r MemRef
mkMemRef vr = do
v <- lookupVar' vr
return $ MemRef Fp (toOffset v)
goValue :: Reg.Value -> ([Instruction], Value)
mkRValue :: Reg.Value -> Sem r RValue
mkRValue = \case
Reg.ValConst c -> return $ Val $ Imm $ mkConst c
Reg.CRef x -> mkLoad x
Reg.VRef x -> Val . Ref <$> mkMemRef x
---------------------------------------------------------------------
-- Instruction
---------------------------------------------------------------------
goInstr :: Reg.Instruction -> Sem r ()
goInstr = \case
Reg.Binop x -> goBinop x
Reg.Unop x -> goUnop x
Reg.Assign x -> goAssign x
Reg.Alloc x -> goAlloc x
Reg.AllocClosure x -> goAllocClosure x
Reg.Trace x -> goTrace x
Reg.Dump -> unsupported "dump"
Reg.Failure x -> goFail x
goAssignVar :: Reg.VarRef -> RValue -> Sem r ()
goAssignVar vr val = do
off <- getAP
insertVar vr off
goAssignAp val
goAssignAp :: RValue -> Sem r ()
goAssignAp val = do
output' 1 (mkAssignAp val)
goAssignValue :: Reg.VarRef -> Reg.Value -> Sem r ()
goAssignValue vr v = mkRValue v >>= goAssignVar vr
goAssignApValue :: Reg.Value -> Sem r ()
goAssignApValue v = mkRValue v >>= goAssignAp
goValue :: Reg.Value -> Sem r Value
goValue = \case
Reg.ValConst c -> ([], Imm $ goConst c)
Reg.CRef x -> ([mkAssignAp (goConstrField x)], Ref $ MemRef Ap (-1))
Reg.VRef x -> ([], Ref $ goVarRef x)
Reg.ValConst c -> return $ Imm $ mkConst c
Reg.CRef x -> do
v <- mkLoad x
goAssignAp v
return $ Ref $ MemRef Ap (-1)
Reg.VRef x -> do
v <- Ref <$> mkMemRef x
return v
goRValue :: Reg.Value -> RValue
goRValue = \case
Reg.ValConst c -> Val $ Imm $ goConst c
Reg.CRef x -> goConstrField x
Reg.VRef x -> Val $ Ref $ goVarRef x
goExtraBinop :: ExtraOpcode -> Reg.VarRef -> MemRef -> Value -> Sem r ()
goExtraBinop op res arg1 arg2 = do
off <- getAP
insertVar res off
output' 1 $
ExtraBinop
InstrExtraBinop
{ _instrExtraBinopOpcode = op,
_instrExtraBinopResult = MemRef Ap 0,
_instrExtraBinopArg1 = arg1,
_instrExtraBinopArg2 = arg2,
_instrExtraBinopIncAp = True
}
goLoad :: Reg.Value -> Offset -> ([Instruction], RValue)
goLoad v off = case goRValue v of
Val (Ref r) -> ([], Load $ LoadValue r off)
v' -> ([mkAssignAp v'], Load $ LoadValue (MemRef Ap (-1)) off)
goNativeBinop :: Opcode -> Reg.VarRef -> MemRef -> Value -> Sem r ()
goNativeBinop op res arg1 arg2 = goAssignVar res binop
where
binop =
Binop
BinopValue
{ _binopValueOpcode = op,
_binopValueArg1 = arg1,
_binopValueArg2 = arg2
}
goAssignValue :: MemRef -> Reg.Value -> Instruction
goAssignValue res = mkAssign res . goRValue
goEq :: Reg.VarRef -> MemRef -> Value -> Sem r ()
goEq res arg1 arg2 = goExtraBinop FieldSub res arg1 arg2
goAssignApValue :: Reg.Value -> Instruction
goAssignApValue = mkAssignAp . goRValue
goIntLe :: Reg.VarRef -> MemRef -> Value -> Sem r ()
goIntLe res arg1 arg2 = case arg2 of
Imm v ->
goExtraBinop IntLt res arg1 (Imm (v + 1))
Ref mref -> do
output' 1 inc
goExtraBinop IntLt res (adjustAp 1 arg1) (Ref $ MemRef Ap (-1))
where
inc =
Assign
InstrAssign
{ _instrAssignResult = MemRef Ap 0,
_instrAssignValue =
Binop
BinopValue
{ _binopValueArg1 = mref,
_binopValueArg2 = Imm 1,
_binopValueOpcode = FieldAdd
},
_instrAssignIncAp = True
}
Lab {} -> impossible
mkBinop :: Reg.BinaryOp -> MemRef -> MemRef -> Value -> [Instruction]
mkBinop op res arg1 arg2 = case op of
goOpArgsNum :: Reg.VarRef -> MemRef -> Sem r ()
goOpArgsNum res v = do
goAssignAp (Val $ Imm $ fromIntegral casmMaxFunctionArgs + 1)
goAssignAp (Load $ LoadValue (adjustAp 1 v) casmClosureArgsNumOffset)
goExtraBinop FieldSub res (MemRef Ap (-2)) (Ref $ MemRef Ap (-1))
goBinop' :: Reg.BinaryOp -> Reg.VarRef -> MemRef -> Value -> Sem r ()
goBinop' op res arg1 arg2 = case op of
Reg.OpIntAdd ->
[mkExtraBinop IntAdd res arg1 arg2]
goExtraBinop IntAdd res arg1 arg2
Reg.OpIntSub ->
[mkExtraBinop IntSub res arg1 arg2]
goExtraBinop IntSub res arg1 arg2
Reg.OpIntMul ->
[mkExtraBinop IntMul res arg1 arg2]
goExtraBinop IntMul res arg1 arg2
Reg.OpIntDiv ->
[mkExtraBinop IntDiv res arg1 arg2]
goExtraBinop IntDiv res arg1 arg2
Reg.OpIntMod ->
[mkExtraBinop IntMod res arg1 arg2]
goExtraBinop IntMod res arg1 arg2
Reg.OpIntLt ->
[mkExtraBinop IntLt res arg1 arg2]
goExtraBinop IntLt res arg1 arg2
Reg.OpIntLe ->
mkIntLe res arg1 arg2
goIntLe res arg1 arg2
Reg.OpFieldAdd ->
[mkNativeBinop FieldAdd res arg1 arg2]
goNativeBinop FieldAdd res arg1 arg2
Reg.OpFieldSub ->
[mkExtraBinop FieldSub res arg1 arg2]
goExtraBinop FieldSub res arg1 arg2
Reg.OpFieldMul ->
[mkNativeBinop FieldMul res arg1 arg2]
goNativeBinop FieldMul res arg1 arg2
Reg.OpFieldDiv ->
[mkExtraBinop FieldDiv res arg1 arg2]
goExtraBinop FieldDiv res arg1 arg2
Reg.OpEq ->
[mkEq res arg1 arg2]
goEq res arg1 arg2
Reg.OpStrConcat ->
unsupported "strings"
goBinop :: Address -> Reg.InstrBinop -> Sem r [Instruction]
goBinop addr x@Reg.InstrBinop {..} = case _instrBinopArg1 of
goBinop :: Reg.InstrBinop -> Sem r ()
goBinop x@Reg.InstrBinop {..} = case _instrBinopArg1 of
Reg.ValConst c1 -> case _instrBinopArg2 of
Reg.ValConst c2 -> case Reg.evalBinop' _instrBinopOpcode c1 c2 of
Left err -> error err
Right c ->
return [mkAssign res (Val $ Imm $ goConst c)]
goAssignVar _instrBinopResult (Val $ Imm $ mkConst c)
_ ->
goBinop
addr
x
{ Reg._instrBinopArg1 = _instrBinopArg2,
Reg._instrBinopArg2 = _instrBinopArg1
}
Reg.CRef ctr1 ->
Reg.CRef ctr1 -> do
v1 <- mkLoad ctr1
goAssignAp v1
v2 <- goValue _instrBinopArg2
case _instrBinopArg2 of
Reg.CRef {} ->
return $ i : is2 ++ mkBinop _instrBinopOpcode res (MemRef Ap (-2)) (Ref $ MemRef Ap (-1))
Reg.CRef {} -> do
goBinop' _instrBinopOpcode _instrBinopResult (MemRef Ap (-2)) v2
_ -> do
eassert (null is2)
return $ i : mkBinop _instrBinopOpcode res (MemRef Ap (-1)) v2
where
i = mkAssignAp (goConstrField ctr1)
Reg.VRef var1 ->
return $ is2 ++ mkBinop _instrBinopOpcode res (goVarRef var1) v2
where
res = goVarRef _instrBinopResult
(is2, v2) = goValue _instrBinopArg2
goBinop' _instrBinopOpcode _instrBinopResult (MemRef Ap (-1)) v2
Reg.VRef var1 -> do
ref <- mkMemRef var1
v2 <- goValue _instrBinopArg2
goBinop' _instrBinopOpcode _instrBinopResult ref v2
goUnop :: Address -> Reg.InstrUnop -> Sem r [Instruction]
goUnop _ Reg.InstrUnop {..} = case _instrUnopOpcode of
goUnop :: Reg.InstrUnop -> Sem r ()
goUnop Reg.InstrUnop {..} = case _instrUnopOpcode of
Reg.OpShow -> unsupported "strings"
Reg.OpStrToInt -> unsupported "strings"
Reg.OpFieldToInt -> return [goAssignValue res _instrUnopArg]
Reg.OpIntToField -> return [goAssignValue res _instrUnopArg]
Reg.OpArgsNum -> case v of
Ref mr ->
return $ is ++ mkOpArgsNum res mr
Imm {} -> impossible
Lab {} -> impossible
where
res = goVarRef _instrUnopResult
(is, v) = goValue _instrUnopArg
Reg.OpFieldToInt -> goAssignValue _instrUnopResult _instrUnopArg
Reg.OpIntToField -> goAssignValue _instrUnopResult _instrUnopArg
Reg.OpArgsNum -> do
v <- goValue _instrUnopArg
case v of
Ref mr -> do
goOpArgsNum _instrUnopResult mr
Imm {} -> impossible
Lab {} -> impossible
goAssign :: Address -> Reg.InstrAssign -> Sem r [Instruction]
goAssign _ Reg.InstrAssign {..} =
return [goAssignValue res _instrAssignValue]
where
res = goVarRef _instrAssignResult
goAssign :: Reg.InstrAssign -> Sem r ()
goAssign Reg.InstrAssign {..} =
goAssignValue _instrAssignResult _instrAssignValue
mkAllocCall :: MemRef -> [Instruction]
mkAllocCall res =
[ mkCallRel $ Lab $ LabelRef (blts ^. stdlibGetRegs) (Just (blts ^. stdlibGetRegsName)),
mkNativeBinop FieldAdd res (MemRef Ap (-2)) (Imm 2)
]
goAllocCall :: Reg.VarRef -> Sem r ()
goAllocCall res = do
output' 4 $ mkCallRel $ Lab $ LabelRef (blts ^. stdlibGetRegs) (Just (blts ^. stdlibGetRegsName))
goNativeBinop FieldAdd res (MemRef Ap (-2)) (Imm 3)
goAlloc :: Address -> Reg.InstrAlloc -> Sem r [Instruction]
goAlloc _ Reg.InstrAlloc {..} =
return $
mkAllocCall res
++ [ mkAssignAp (Val $ Imm $ fromIntegral tagId)
]
++ map goAssignApValue _instrAllocArgs
goAlloc :: Reg.InstrAlloc -> Sem r ()
goAlloc Reg.InstrAlloc {..} = do
goAllocCall _instrAllocResult
goAssignAp (Val $ Imm $ fromIntegral tagId)
mapM_ goAssignApValue _instrAllocArgs
where
res = goVarRef _instrAllocResult
tagId = getTagId _instrAllocTag
goAllocClosure :: Address -> Reg.InstrAllocClosure -> Sem r [Instruction]
goAllocClosure _ Reg.InstrAllocClosure {..} =
return $
mkAllocCall res
++ [ mkAssignAp (Val $ Imm $ fromIntegral $ 1 + 3 * fuid),
mkAssignAp (Val $ Imm $ fromIntegral $ casmMaxFunctionArgs + 1 - storedArgsNum),
mkAssignAp (Val $ Imm $ fromIntegral $ casmMaxFunctionArgs + 1 - leftArgsNum)
]
++ map goAssignApValue _instrAllocClosureArgs
goAllocClosure :: Reg.InstrAllocClosure -> Sem r ()
goAllocClosure Reg.InstrAllocClosure {..} = do
goAllocCall _instrAllocClosureResult
goAssignAp (Val $ Imm $ fromIntegral $ 1 + 3 * fuid)
goAssignAp (Val $ Imm $ fromIntegral $ casmMaxFunctionArgs + 1 - storedArgsNum)
goAssignAp (Val $ Imm $ fromIntegral $ casmMaxFunctionArgs + 1 - leftArgsNum)
mapM_ goAssignApValue _instrAllocClosureArgs
where
res = goVarRef _instrAllocClosureResult
fuid = fromJust $ HashMap.lookup _instrAllocClosureSymbol (info ^. Reg.extraInfoFUIDs)
storedArgsNum = length _instrAllocClosureArgs
leftArgsNum = _instrAllocClosureExpectedArgsNum - storedArgsNum
goExtendClosure :: Address -> Reg.InstrExtendClosure -> Sem r [Instruction]
goExtendClosure _ Reg.InstrExtendClosure {..} =
return $
map goAssignApValue _instrExtendClosureArgs
++ [ mkAssignAp (Val $ Imm $ fromIntegral $ length _instrExtendClosureArgs),
mkAssignAp (Val $ Ref val),
mkCallRel $ Lab $ LabelRef (blts ^. stdlibExtendClosure) (Just (blts ^. stdlibExtendClosureName)),
mkAssign res (Val $ Ref $ MemRef Ap (-1))
]
where
res = goVarRef _instrExtendClosureResult
val = goVarRef _instrExtendClosureValue
goTrace :: Reg.InstrTrace -> Sem r ()
goTrace Reg.InstrTrace {..} = do
v <- mkRValue _instrTraceValue
output' 0 $ Trace (InstrTrace v)
goCall' :: Instruction -> Reg.CallType -> [Reg.Value] -> [Instruction]
goCall' saveOrRet ct args = case ct of
Reg.CallFun sym ->
args'
++ [ mkCallRel $ Lab $ LabelRef sym (Just funName),
saveOrRet
]
goFail :: Reg.InstrFailure -> Sem r ()
goFail Reg.InstrFailure {..} = do
v <- mkRValue _instrFailureValue
output' 0 $ Trace (InstrTrace v)
output' 0 $ mkJumpRel (Val $ Lab failLab)
---------------------------------------------------------------------
-- FinalInstruction
---------------------------------------------------------------------
goFinalInstr :: HashSet Reg.VarRef -> Reg.FinalInstruction -> Sem r ()
goFinalInstr liveVars = \case
Reg.ExtendClosure x -> goExtendClosure liveVars x
Reg.Call x -> goCall liveVars x
Reg.TailCall x -> goTailCall x
Reg.Return x -> goReturn x
Reg.Branch x -> goBranch liveVars x
Reg.Case x -> goCase liveVars x
goExtendClosure :: HashSet Reg.VarRef -> Reg.InstrExtendClosure -> Sem r ()
goExtendClosure liveVars Reg.InstrExtendClosure {..} = do
mapM_ goAssignApValue _instrExtendClosureArgs
goAssignAp (Val $ Imm $ fromIntegral $ length _instrExtendClosureArgs)
val <- mkMemRef _instrExtendClosureValue
goAssignAp (Val $ Ref val)
output'' $ mkCallRel $ Lab $ LabelRef (blts ^. stdlibExtendClosure) (Just (blts ^. stdlibExtendClosureName))
goCallBlock (Just _instrExtendClosureResult) liveVars
goCall' :: Reg.CallType -> [Reg.Value] -> Sem r ()
goCall' ct args = case ct of
Reg.CallFun sym -> do
mapM_ goAssignApValue (reverse args)
output'' $ mkCallRel $ Lab $ LabelRef sym (Just funName)
where
funName = Reg.lookupFunInfo tab sym ^. Reg.functionName
Reg.CallClosure cl ->
args'
++ [ mkAssignAp (Val $ Ref $ goVarRef cl),
mkCallRel $ Lab $ LabelRef (blts ^. stdlibCallClosure) (Just (blts ^. stdlibCallClosureName)),
saveOrRet
]
where
args' = map goAssignApValue (reverse args)
Reg.CallClosure cl -> do
mapM_ goAssignApValue (reverse args)
r <- mkMemRef cl
goAssignAp (Val $ Ref r)
output'' $ mkCallRel $ Lab $ LabelRef (blts ^. stdlibCallClosure) (Just (blts ^. stdlibCallClosureName))
goCall :: Address -> Reg.InstrCall -> Sem r [Instruction]
goCall _ Reg.InstrCall {..} =
return $
goCall' (mkAssign res (Val $ Ref $ MemRef Ap (-1))) _instrCallType _instrCallArgs
where
res = goVarRef _instrCallResult
goCall :: HashSet Reg.VarRef -> Reg.InstrCall -> Sem r ()
goCall liveVars Reg.InstrCall {..} = do
goCall' _instrCallType _instrCallArgs
goCallBlock (Just _instrCallResult) liveVars
-- There is no way to make "proper" tail calls in Cairo, because
-- the only way to set the `fp` register is via the `call` instruction.
-- So we just translate tail calls into `call` followed by `ret`.
goTailCall :: Address -> Reg.InstrTailCall -> Sem r [Instruction]
goTailCall _ Reg.InstrTailCall {..} =
return $
goCall' Return _instrTailCallType _instrTailCallArgs
goTailCall :: Reg.InstrTailCall -> Sem r ()
goTailCall Reg.InstrTailCall {..} = do
goCall' _instrTailCallType _instrTailCallArgs
output'' Return
goReturn :: Address -> Reg.InstrReturn -> Sem r [Instruction]
goReturn _ Reg.InstrReturn {..} =
return $
[ goAssignApValue _instrReturnValue,
Return
]
goReturn :: Reg.InstrReturn -> Sem r ()
goReturn Reg.InstrReturn {..} = do
goAssignApValue _instrReturnValue
output'' Return
goBranch :: Address -> Reg.InstrBranch -> Sem r [Instruction]
goBranch addr Reg.InstrBranch {..} = case v of
Imm c
| c == 0 -> goCode addr _instrBranchTrue
| otherwise -> goCode addr _instrBranchFalse
Ref r -> do
symFalse <- freshSymbol
symEnd <- freshSymbol
let labFalse = LabelRef symFalse Nothing
labEnd = LabelRef symEnd Nothing
addr1 = addr + length is + 1
codeTrue <- goCode addr1 _instrBranchTrue
let addr2 = addr1 + length codeTrue + 1
registerLabelAddress symFalse addr2
codeFalse <- goCode (addr2 + 1) _instrBranchFalse
registerLabelAddress symEnd (addr2 + 1 + length codeFalse)
return $
is
++ [mkJumpIf (Lab labFalse) r]
++ codeTrue
++ [ mkJumpRel (Val $ Lab labEnd),
Label labFalse
]
++ codeFalse
++ [Label labEnd]
Lab {} -> impossible
where
(is, v) = goValue _instrBranchValue
goBranch :: HashSet Reg.VarRef -> Reg.InstrBranch -> Sem r ()
goBranch liveVars Reg.InstrBranch {..} = do
v <- goValue _instrBranchValue
case v of
Imm c
| c == 0 -> goBlock blts failLab liveVars _instrBranchOutVar _instrBranchTrue
| otherwise -> goBlock blts failLab liveVars _instrBranchOutVar _instrBranchFalse
Ref r -> do
symFalse <- freshSymbol
symEnd <- freshSymbol
let labFalse = LabelRef symFalse Nothing
labEnd = LabelRef symEnd Nothing
output'' $ mkJumpIf (Lab labFalse) r
ap0 <- getAP
vars <- getVars
goLocalBlock ap0 vars liveVars _instrBranchOutVar _instrBranchTrue
-- _instrBranchOutVar is Nothing iff the branch returns
when (isJust _instrBranchOutVar) $
output'' (mkJumpRel (Val $ Lab labEnd))
addrFalse <- getPC
registerLabelAddress symFalse addrFalse
output'' $ Label labFalse
goLocalBlock ap0 vars liveVars _instrBranchOutVar _instrBranchFalse
addrEnd <- getPC
registerLabelAddress symEnd addrEnd
output'' $ Label labEnd
Lab {} -> impossible
goCase :: Address -> Reg.InstrCase -> Sem r [Instruction]
goCase addr Reg.InstrCase {..} = do
goLoad :: Reg.Value -> Offset -> Sem r RValue
goLoad val off = do
v <- mkRValue val
case v of
Val (Ref r) -> return $ Load $ LoadValue r off
_ -> do
goAssignAp v
return $ Load $ LoadValue (MemRef Ap (-1)) off
goCase :: HashSet Reg.VarRef -> Reg.InstrCase -> Sem r ()
goCase liveVars Reg.InstrCase {..} = do
syms <- replicateM (length tags) freshSymbol
symEnd <- freshSymbol
let symMap = HashMap.fromList $ zip tags syms
@ -344,46 +474,39 @@ fromReg tab = uncurry Result $ run $ runLabelInfoBuilderWithNextId (Reg.getNextS
-- offsets in our CASM interpreter correspond to the relative jump
-- offsets in the Cairo binary representation
jmps' = concatMap (\i -> [i, Nop]) jmps
addr1 = addr + length is + 1 + length jmps'
(addr2, instrs) <- second (concat . reverse) <$> foldM (goCaseBranch symMap labEnd) (addr1, []) _instrCaseBranches
(addr3, instrs') <- second reverse <$> foldM (goDefaultLabel symMap) (addr2, []) defaultTags
instrs'' <- maybe (return []) (goCode addr3) _instrCaseDefault
let addr4 = addr3 + length instrs''
registerLabelAddress symEnd addr4
return $ is ++ mkJumpRel v : jmps' ++ instrs ++ instrs' ++ instrs'' ++ [Label labEnd]
v <- goLoad _instrCaseValue 0
output'' (mkJumpRel v)
mapM_ output'' jmps'
ap0 <- getAP
vars <- getVars
mapM_ (goCaseBranch ap0 vars symMap labEnd) _instrCaseBranches
mapM_ (goDefaultLabel symMap) defaultTags
whenJust _instrCaseDefault $
goLocalBlock ap0 vars liveVars _instrCaseOutVar
addrEnd <- getPC
registerLabelAddress symEnd addrEnd
output'' $ Label labEnd
where
(is, v) = goLoad _instrCaseValue 0
tags = Reg.lookupInductiveInfo tab _instrCaseInductive ^. Reg.inductiveConstructors
ctrTags = HashSet.fromList $ map (^. Reg.caseBranchTag) _instrCaseBranches
defaultTags = filter (not . flip HashSet.member ctrTags) tags
goCaseBranch :: HashMap Tag Symbol -> LabelRef -> (Address, [[Instruction]]) -> Reg.CaseBranch -> Sem r (Address, [[Instruction]])
goCaseBranch symMap labEnd (addr', acc') Reg.CaseBranch {..} = do
goCaseBranch :: Int -> HashMap Reg.VarRef Int -> HashMap Tag Symbol -> LabelRef -> Reg.CaseBranch -> Sem r ()
goCaseBranch ap0 vars symMap labEnd Reg.CaseBranch {..} = do
let sym = fromJust $ HashMap.lookup _caseBranchTag symMap
lab = LabelRef sym Nothing
registerLabelAddress sym addr'
instrs <- goCode (addr' + 1) _caseBranchCode
let instrs' = Label lab : instrs ++ [mkJumpRel (Val $ Lab labEnd)]
return (addr' + length instrs', instrs' : acc')
addr <- getPC
registerLabelAddress sym addr
output'' $ Label lab
goLocalBlock ap0 vars liveVars _instrCaseOutVar _caseBranchCode
-- _instrCaseOutVar is Nothing iff the branch returns
when (isJust _instrCaseOutVar) $
output'' (mkJumpRel (Val $ Lab labEnd))
goDefaultLabel :: HashMap Tag Symbol -> (Address, [Instruction]) -> Reg.Tag -> Sem r (Address, [Instruction])
goDefaultLabel symMap (addr', acc') tag = do
goDefaultLabel :: HashMap Tag Symbol -> Reg.Tag -> Sem r ()
goDefaultLabel symMap tag = do
let sym = fromJust $ HashMap.lookup tag symMap
lab = LabelRef sym Nothing
registerLabelAddress sym addr'
return (addr' + 1, Label lab : acc')
goTrace :: Address -> Reg.InstrTrace -> Sem r [Instruction]
goTrace _ Reg.InstrTrace {..} =
return [Trace (InstrTrace (goRValue _instrTraceValue))]
goFail :: Address -> Reg.InstrFailure -> Sem r [Instruction]
goFail _ Reg.InstrFailure {..} =
return
[ Trace (InstrTrace (goRValue _instrFailureValue)),
mkJumpRel (Val $ Lab failLab)
]
goBlock :: Address -> Reg.InstrBlock -> Sem r [Instruction]
goBlock addr Reg.InstrBlock {..} =
goCode addr _instrBlockCode
addr <- getPC
registerLabelAddress sym addr
output'' $ Label lab

68
src/Juvix/Compiler/Casm/Translation/FromReg/CasmBuilder.hs Normal file
View File

@ -0,0 +1,68 @@
module Juvix.Compiler.Casm.Translation.FromReg.CasmBuilder where
import Data.HashMap.Strict qualified as HashMap
import Juvix.Compiler.Casm.Language
import Juvix.Compiler.Reg.Language.Instrs (VarRef)
data CasmBuilder :: Effect where
IncPC :: Int -> CasmBuilder m ()
GetPC :: CasmBuilder m Address
IncAP :: Int -> CasmBuilder m ()
GetAP :: CasmBuilder m Int
SetAP :: Address -> CasmBuilder m ()
InsertVar :: VarRef -> Int -> CasmBuilder m ()
LookupVar :: VarRef -> CasmBuilder m (Maybe Int)
GetVars :: CasmBuilder m (HashMap VarRef Int)
SetVars :: HashMap VarRef Int -> CasmBuilder m ()
makeSem ''CasmBuilder
data BuilderState = BuilderState
{ _statePC :: Address,
_stateAP :: Int,
_stateVarMap :: HashMap VarRef Int
}
makeLenses ''BuilderState
mkBuilderState :: Address -> HashMap VarRef Int -> BuilderState
mkBuilderState addr vars =
BuilderState
{ _statePC = addr,
_stateAP = 0,
_stateVarMap = vars
}
runCasmBuilder :: Address -> HashMap VarRef Int -> Sem (CasmBuilder ': r) a -> Sem r a
runCasmBuilder addr vars = fmap snd . runCasmBuilder' (mkBuilderState addr vars)
runCasmBuilder' :: BuilderState -> Sem (CasmBuilder ': r) a -> Sem r (BuilderState, a)
runCasmBuilder' bs = reinterpret (runState bs) interp
where
interp :: CasmBuilder m a -> Sem (State BuilderState ': r) a
interp = \case
IncPC i -> do
modify' (over statePC (+ i))
GetPC -> do
gets (^. statePC)
IncAP i -> do
modify' (over stateAP (+ i))
GetAP -> do
gets (^. stateAP)
SetAP addr -> do
modify' (set stateAP addr)
InsertVar v i -> do
modify' (over stateVarMap (HashMap.insert v i))
LookupVar v -> do
mp <- gets (^. stateVarMap)
return $ HashMap.lookup v mp
GetVars -> do
gets (^. stateVarMap)
SetVars vars -> do
modify' (set stateVarMap vars)
lookupVar' :: (Member CasmBuilder r) => VarRef -> Sem r Int
lookupVar' = lookupVar >=> return . fromJust
hasVar :: (Member CasmBuilder r) => VarRef -> Sem r Bool
hasVar = lookupVar >=> return . isJust

12
src/Juvix/Compiler/Reg/Data/Blocks/InfoTable.hs Normal file
View File

@ -0,0 +1,12 @@
module Juvix.Compiler.Reg.Data.Blocks.InfoTable
( module Juvix.Compiler.Reg.Data.Blocks.InfoTable,
module Juvix.Compiler.Tree.Data.InfoTable.Base,
)
where
import Juvix.Compiler.Reg.Language.Blocks
import Juvix.Compiler.Tree.Data.InfoTable.Base
type InfoTable = InfoTable' Block ()
type FunctionInfo = FunctionInfo' Block ()

2
src/Juvix/Compiler/Reg/Data/TransformationId.hs
View File

@ -22,7 +22,7 @@ toCTransformations :: [TransformationId]
toCTransformations = [Cleanup]
toCasmTransformations :: [TransformationId]
toCasmTransformations = [Cleanup, SSA, InitBranchVars]
toCasmTransformations = [Cleanup, SSA]
instance TransformationId' TransformationId where
transformationText :: TransformationId -> Text

134
src/Juvix/Compiler/Reg/Extra/Blocks.hs Normal file
View File

@ -0,0 +1,134 @@
module Juvix.Compiler.Reg.Extra.Blocks where
import Juvix.Compiler.Reg.Language.Blocks
overSubBlocks :: (Block -> Block) -> Block -> Block
overSubBlocks f block = block'
where
block' = over blockFinal (fmap goFinal) block
goFinal :: FinalInstruction -> FinalInstruction
goFinal = \case
ExtendClosure x -> ExtendClosure x
Call x -> Call x
TailCall x -> TailCall x
Return x -> Return x
Branch x ->
Branch $ over instrBranchTrue f $ over instrBranchFalse f x
Case x ->
Case $
over instrCaseDefault (fmap f) $
over instrCaseBranches (map (over caseBranchCode f)) x
getSubBlocks :: Block -> [Block]
getSubBlocks block = maybe [] goFinal (block ^. blockFinal)
where
goFinal :: FinalInstruction -> [Block]
goFinal = \case
ExtendClosure {} -> []
Call {} -> []
TailCall {} -> []
Return {} -> []
Branch x ->
[x ^. instrBranchTrue, x ^. instrBranchFalse]
Case x ->
maybeToList (x ^. instrCaseDefault)
++ map (^. caseBranchCode) (x ^. instrCaseBranches)
getResultVar :: Instruction -> Maybe VarRef
getResultVar = \case
Binop x -> Just $ x ^. instrBinopResult
Unop x -> Just $ x ^. instrUnopResult
Assign x -> Just $ x ^. instrAssignResult
Alloc x -> Just $ x ^. instrAllocResult
AllocClosure x -> Just $ x ^. instrAllocClosureResult
_ -> Nothing
getResultVar' :: FinalInstruction -> Maybe VarRef
getResultVar' = \case
Call x -> Just $ x ^. instrCallResult
ExtendClosure x -> Just $ x ^. instrExtendClosureResult
_ -> Nothing
getOutVar :: FinalInstruction -> Maybe VarRef
getOutVar = \case
Call x -> Just $ x ^. instrCallResult
ExtendClosure x -> Just $ x ^. instrExtendClosureResult
Branch x -> x ^. instrBranchOutVar
Case x -> x ^. instrCaseOutVar
TailCall {} -> Nothing
Return {} -> Nothing
getValueRefs'' :: Value -> [VarRef]
getValueRefs'' = \case
ValConst {} -> []
CRef ConstrField {..} -> [_constrFieldRef]
VRef x -> [x]
getValueRefs :: Instruction -> [VarRef]
getValueRefs = \case
Binop x -> goBinop x
Unop x -> goUnop x
Assign x -> goAssign x
Alloc x -> goAlloc x
AllocClosure x -> goAllocClosure x
Trace x -> goTrace x
Dump -> []
Failure x -> goFailure x
where
goBinop :: InstrBinop -> [VarRef]
goBinop InstrBinop {..} =
getValueRefs'' _instrBinopArg1
++ getValueRefs'' _instrBinopArg2
goUnop :: InstrUnop -> [VarRef]
goUnop InstrUnop {..} = getValueRefs'' _instrUnopArg
goAssign :: InstrAssign -> [VarRef]
goAssign InstrAssign {..} = getValueRefs'' _instrAssignValue
goAlloc :: InstrAlloc -> [VarRef]
goAlloc InstrAlloc {..} = concatMap getValueRefs'' _instrAllocArgs
goAllocClosure :: InstrAllocClosure -> [VarRef]
goAllocClosure InstrAllocClosure {..} = concatMap getValueRefs'' _instrAllocClosureArgs
goTrace :: InstrTrace -> [VarRef]
goTrace InstrTrace {..} = getValueRefs'' _instrTraceValue
goFailure :: InstrFailure -> [VarRef]
goFailure InstrFailure {..} = getValueRefs'' _instrFailureValue
getValueRefs' :: FinalInstruction -> [VarRef]
getValueRefs' = \case
ExtendClosure x -> goExtendClosure x
Call x -> goCall x
TailCall x -> goTailCall x
Return x -> goReturn x
Branch x -> goBranch x
Case x -> goCase x
where
goExtendClosure :: InstrExtendClosure -> [VarRef]
goExtendClosure InstrExtendClosure {..} =
_instrExtendClosureValue : concatMap getValueRefs'' _instrExtendClosureArgs
goCallType :: CallType -> [VarRef]
goCallType = \case
CallFun {} -> []
CallClosure cl -> [cl]
goCall :: InstrCall -> [VarRef]
goCall InstrCall {..} = goCallType _instrCallType ++ concatMap getValueRefs'' _instrCallArgs
goTailCall :: InstrTailCall -> [VarRef]
goTailCall InstrTailCall {..} =
goCallType _instrTailCallType ++ concatMap getValueRefs'' _instrTailCallArgs
goReturn :: InstrReturn -> [VarRef]
goReturn InstrReturn {..} = getValueRefs'' _instrReturnValue
goBranch :: InstrBranch -> [VarRef]
goBranch InstrBranch {..} = getValueRefs'' _instrBranchValue
goCase :: InstrCase -> [VarRef]
goCase InstrCase {..} = getValueRefs'' _instrCaseValue

28
src/Juvix/Compiler/Reg/Extra/Blocks/Info.hs Normal file
View File

@ -0,0 +1,28 @@
module Juvix.Compiler.Reg.Extra.Blocks.Info
( module Juvix.Compiler.Tree.Extra.Info,
module Juvix.Compiler.Reg.Extra.Blocks.Info,
)
where
import Juvix.Compiler.Reg.Data.Blocks.InfoTable
import Juvix.Compiler.Reg.Language.Base
import Juvix.Compiler.Tree.Extra.Info
data ExtraInfo = ExtraInfo
{ _extraInfoTable :: InfoTable,
-- | Globally unique IDs for function symbols
_extraInfoFUIDs :: HashMap Symbol Int,
-- | IDs for constructor tags, consecutive starting from 0 for each
-- inductive type separately
_extraInfoCIDs :: HashMap Tag Int
}
makeLenses ''ExtraInfo
computeExtraInfo :: InfoTable -> ExtraInfo
computeExtraInfo tab =
ExtraInfo
{ _extraInfoTable = tab,
_extraInfoFUIDs = computeFUIDs tab,
_extraInfoCIDs = computeCIDs tab
}

34
src/Juvix/Compiler/Reg/Extra/Info.hs
View File

@ -1,14 +1,14 @@
module Juvix.Compiler.Reg.Extra.Info where
module Juvix.Compiler.Reg.Extra.Info
( module Juvix.Compiler.Tree.Extra.Info,
module Juvix.Compiler.Reg.Extra.Info,
)
where
import Data.HashMap.Strict qualified as HashMap
import Juvix.Compiler.Backend
import Juvix.Compiler.Reg.Data.InfoTable
import Juvix.Compiler.Reg.Language
userConstrs :: InfoTable -> [ConstructorInfo]
userConstrs tab =
filter (\ci -> not (isBuiltinTag (ci ^. constructorTag))) $
HashMap.elems (tab ^. infoConstrs)
import Juvix.Compiler.Tree.Extra.Info
-- | Compute the maximum runtime stack height
computeMaxStackHeight :: Limits -> Code -> Int
@ -215,28 +215,6 @@ data ExtraInfo = ExtraInfo
makeLenses ''ExtraInfo
computeUIDs :: Limits -> InfoTable -> HashMap Tag Int
computeUIDs lims tab =
HashMap.fromList $
zipWith
(\ci uid -> (ci ^. constructorTag, uid))
(userConstrs tab)
[lims ^. limitsBuiltinUIDsNum ..]
computeFUIDs :: InfoTable -> HashMap Symbol Int
computeFUIDs tab =
HashMap.fromList $
zipWith
(\fi fuid -> (fi ^. functionSymbol, fuid))
(HashMap.elems (tab ^. infoFunctions))
[0 ..]
computeCIDs :: InfoTable -> HashMap Tag Int
computeCIDs tab = HashMap.fromList $ concatMap go (tab ^. infoInductives)
where
go :: InductiveInfo -> [(Tag, Int)]
go InductiveInfo {..} = zip _inductiveConstructors [0 ..]
computeExtraInfo :: Limits -> InfoTable -> ExtraInfo
computeExtraInfo lims tab =
ExtraInfo

181
src/Juvix/Compiler/Reg/Language.hs
View File

@ -1,55 +1,10 @@
module Juvix.Compiler.Reg.Language
( module Juvix.Compiler.Reg.Language,
module Juvix.Compiler.Reg.Language.Base,
module Juvix.Compiler.Reg.Language.Instrs,
)
where
import Juvix.Compiler.Reg.Language.Base
data Value
= ValConst Constant
| CRef ConstrField
| VRef VarRef
-- | Reference to a constructor field (argument).
data ConstrField = ConstrField
{ -- | Tag of the constructor being referenced.
_constrFieldTag :: Tag,
-- | Memory representation of the constructor.
_constrFieldMemRep :: MemRep,
-- | Location where the data is stored.
_constrFieldRef :: VarRef,
-- | Index of the constructor argument being referenced.
_constrFieldIndex :: Index
}
data VarGroup
= VarGroupArgs
| VarGroupLocal
deriving stock (Eq, Generic)
instance Hashable VarGroup
data VarRef = VarRef
{ _varRefGroup :: VarGroup,
_varRefIndex :: Index,
_varRefName :: Maybe Text
}
makeLenses ''VarRef
makeLenses ''ConstrField
instance Hashable VarRef where
hashWithSalt salt VarRef {..} = hashWithSalt salt (_varRefGroup, _varRefIndex)
instance Eq VarRef where
vr1 == vr2 =
vr1 ^. varRefGroup == vr2 ^. varRefGroup
&& vr1 ^. varRefIndex == vr2 ^. varRefIndex
deriving stock instance (Eq ConstrField)
deriving stock instance (Eq Value)
import Juvix.Compiler.Reg.Language.Instrs
data Instruction
= Binop InstrBinop
@ -78,87 +33,12 @@ data Instruction
type Code = [Instruction]
data InstrBinop = InstrBinop
{ _instrBinopOpcode :: BinaryOp,
_instrBinopResult :: VarRef,
_instrBinopArg1 :: Value,
_instrBinopArg2 :: Value
}
deriving stock (Eq)
data InstrUnop = InstrUnop
{ _instrUnopOpcode :: UnaryOp,
_instrUnopResult :: VarRef,
_instrUnopArg :: Value
}
deriving stock (Eq)
data InstrAssign = InstrAssign
{ _instrAssignResult :: VarRef,
_instrAssignValue :: Value
}
deriving stock (Eq)
newtype InstrTrace = InstrTrace
{ _instrTraceValue :: Value
}
deriving stock (Eq)
newtype InstrFailure = InstrFailure
{ _instrFailureValue :: Value
}
deriving stock (Eq)
data InstrPrealloc = InstrPrealloc
{ _instrPreallocWordsNum :: Int,
_instrPreallocLiveVars :: [VarRef]
}
deriving stock (Eq)
data InstrAlloc = InstrAlloc
{ _instrAllocResult :: VarRef,
_instrAllocTag :: Tag,
_instrAllocMemRep :: MemRep,
_instrAllocArgs :: [Value]
}
deriving stock (Eq)
data InstrAllocClosure = InstrAllocClosure
{ _instrAllocClosureResult :: VarRef,
_instrAllocClosureSymbol :: Symbol,
_instrAllocClosureExpectedArgsNum :: Int,
_instrAllocClosureArgs :: [Value]
}
deriving stock (Eq)
data InstrExtendClosure = InstrExtendClosure
{ _instrExtendClosureResult :: VarRef,
_instrExtendClosureValue :: VarRef,
_instrExtendClosureArgs :: [Value]
}
deriving stock (Eq)
data CallType
= CallFun Symbol
| CallClosure VarRef
deriving stock (Eq)
data InstrCall = InstrCall
{ _instrCallResult :: VarRef,
_instrCallType :: CallType,
_instrCallArgs :: [Value],
-- | Variables live after the call. Live variables need to be
-- saved before the call and restored after it.
_instrCallLiveVars :: [VarRef]
}
deriving stock (Eq)
data InstrTailCall = InstrTailCall
{ _instrTailCallType :: CallType,
_instrTailCallArgs :: [Value]
}
deriving stock (Eq)
data InstrCallClosures = InstrCallClosures
{ _instrCallClosuresResult :: VarRef,
_instrCallClosuresValue :: VarRef,
@ -173,66 +53,17 @@ data InstrTailCallClosures = InstrTailCallClosures
}
deriving stock (Eq)
newtype InstrReturn = InstrReturn
{ _instrReturnValue :: Value
}
deriving stock (Eq)
type InstrBranch = InstrBranch' Code
data InstrBranch = InstrBranch
{ _instrBranchValue :: Value,
_instrBranchTrue :: Code,
_instrBranchFalse :: Code,
-- | Output variable storing the result (corresponds to the top of the value
-- stack in JuvixAsm after executing the branches)
_instrBranchOutVar :: Maybe VarRef
}
deriving stock (Eq)
type InstrCase = InstrCase' Code
data InstrCase = InstrCase
{ _instrCaseValue :: Value,
_instrCaseInductive :: Symbol,
_instrCaseIndRep :: IndRep,
_instrCaseBranches :: [CaseBranch],
_instrCaseDefault :: Maybe Code,
_instrCaseOutVar :: Maybe VarRef
}
deriving stock (Eq)
data CaseBranch = CaseBranch
{ _caseBranchTag :: Tag,
-- | Memory representation of the constructor corresponding to the branch.
_caseBranchMemRep :: MemRep,
_caseBranchArgsNum :: Int,
_caseBranchCode :: Code
}
deriving stock (Eq)
type CaseBranch = CaseBranch' Code
newtype InstrBlock = InstrBlock
{ _instrBlockCode :: Code
}
deriving stock (Eq)
makeLenses ''InstrBinop
makeLenses ''InstrUnop
makeLenses ''InstrAssign
makeLenses ''InstrTrace
makeLenses ''InstrFailure
makeLenses ''InstrPrealloc
makeLenses ''InstrAlloc
makeLenses ''InstrAllocClosure
makeLenses ''InstrExtendClosure
makeLenses ''InstrCall
makeLenses ''InstrCallClosures
makeLenses ''InstrBranch
makeLenses ''InstrCase
makeLenses ''CaseBranch
makeLenses ''InstrReturn
makeLenses ''InstrTailCall
mkVarRef :: VarGroup -> Index -> VarRef
mkVarRef g i =
VarRef
{ _varRefGroup = g,
_varRefIndex = i,
_varRefName = Nothing
}
makeLenses ''InstrTailCallClosures

50
src/Juvix/Compiler/Reg/Language/Blocks.hs Normal file
View File

@ -0,0 +1,50 @@
module Juvix.Compiler.Reg.Language.Blocks
( module Juvix.Compiler.Reg.Language.Blocks,
module Juvix.Compiler.Reg.Language.Instrs,
)
where
import Juvix.Compiler.Reg.Language.Instrs
data Block = Block
{ _blockLiveVars :: HashSet VarRef,
_blockBody :: [Instruction],
_blockFinal :: Maybe FinalInstruction,
_blockNext :: Maybe Block
}
data Instruction
= Binop InstrBinop
| Unop InstrUnop
| Assign InstrAssign
| Alloc InstrAlloc
| AllocClosure InstrAllocClosure
| Trace InstrTrace
| Dump
| Failure InstrFailure
deriving stock (Eq)
data FinalInstruction
= ExtendClosure InstrExtendClosure
| Call InstrCall
| TailCall InstrTailCall
| Return InstrReturn
| Branch InstrBranch
| Case InstrCase
type InstrBranch = InstrBranch' Block
type InstrCase = InstrCase' Block
type CaseBranch = CaseBranch' Block
makeLenses ''Block
emptyBlock :: Block
emptyBlock =
Block
{ _blockLiveVars = mempty,
_blockBody = [],
_blockFinal = Nothing,
_blockNext = Nothing
}

185
src/Juvix/Compiler/Reg/Language/Instrs.hs Normal file
View File

@ -0,0 +1,185 @@
module Juvix.Compiler.Reg.Language.Instrs
( module Juvix.Compiler.Reg.Language.Instrs,
module Juvix.Compiler.Reg.Language.Base,
)
where
import Juvix.Compiler.Reg.Language.Base
data Value
= ValConst Constant
| CRef ConstrField
| VRef VarRef
-- | Reference to a constructor field (argument).
data ConstrField = ConstrField
{ -- | Tag of the constructor being referenced.
_constrFieldTag :: Tag,
-- | Memory representation of the constructor.
_constrFieldMemRep :: MemRep,
-- | Location where the data is stored.
_constrFieldRef :: VarRef,
-- | Index of the constructor argument being referenced.
_constrFieldIndex :: Index
}
data VarGroup
= VarGroupArgs
| VarGroupLocal
deriving stock (Eq, Generic, Show)
instance Hashable VarGroup
data VarRef = VarRef
{ _varRefGroup :: VarGroup,
_varRefIndex :: Index,
_varRefName :: Maybe Text
}
deriving stock (Show)
makeLenses ''VarRef
makeLenses ''ConstrField
instance Hashable VarRef where
hashWithSalt salt VarRef {..} = hashWithSalt salt (_varRefGroup, _varRefIndex)
instance Eq VarRef where
vr1 == vr2 =
vr1 ^. varRefGroup == vr2 ^. varRefGroup
&& vr1 ^. varRefIndex == vr2 ^. varRefIndex
deriving stock instance (Eq ConstrField)
deriving stock instance (Eq Value)
data InstrBinop = InstrBinop
{ _instrBinopOpcode :: BinaryOp,
_instrBinopResult :: VarRef,
_instrBinopArg1 :: Value,
_instrBinopArg2 :: Value
}
deriving stock (Eq)
data InstrUnop = InstrUnop
{ _instrUnopOpcode :: UnaryOp,
_instrUnopResult :: VarRef,
_instrUnopArg :: Value
}
deriving stock (Eq)
data InstrAssign = InstrAssign
{ _instrAssignResult :: VarRef,
_instrAssignValue :: Value
}
deriving stock (Eq)
newtype InstrTrace = InstrTrace
{ _instrTraceValue :: Value
}
deriving stock (Eq)
newtype InstrFailure = InstrFailure
{ _instrFailureValue :: Value
}
deriving stock (Eq)
data InstrAlloc = InstrAlloc
{ _instrAllocResult :: VarRef,
_instrAllocTag :: Tag,
_instrAllocMemRep :: MemRep,
_instrAllocArgs :: [Value]
}
deriving stock (Eq)
data InstrAllocClosure = InstrAllocClosure
{ _instrAllocClosureResult :: VarRef,
_instrAllocClosureSymbol :: Symbol,
_instrAllocClosureExpectedArgsNum :: Int,
_instrAllocClosureArgs :: [Value]
}
deriving stock (Eq)
data InstrExtendClosure = InstrExtendClosure
{ _instrExtendClosureResult :: VarRef,
_instrExtendClosureValue :: VarRef,
_instrExtendClosureArgs :: [Value]
}
deriving stock (Eq)
data CallType
= CallFun Symbol
| CallClosure VarRef
deriving stock (Eq)
data InstrCall = InstrCall
{ _instrCallResult :: VarRef,
_instrCallType :: CallType,
_instrCallArgs :: [Value],
-- | Variables live after the call. Live variables need to be
-- saved before the call and restored after it.
_instrCallLiveVars :: [VarRef]
}
deriving stock (Eq)
data InstrTailCall = InstrTailCall
{ _instrTailCallType :: CallType,
_instrTailCallArgs :: [Value]
}
deriving stock (Eq)
newtype InstrReturn = InstrReturn
{ _instrReturnValue :: Value
}
deriving stock (Eq)
data InstrBranch' a = InstrBranch
{ _instrBranchValue :: Value,
_instrBranchTrue :: a,
_instrBranchFalse :: a,
-- | Output variable storing the result (corresponds to the top of the value
-- stack in JuvixAsm after executing the branches)
_instrBranchOutVar :: Maybe VarRef
}
deriving stock (Eq, Functor)
data InstrCase' a = InstrCase
{ _instrCaseValue :: Value,
_instrCaseInductive :: Symbol,
_instrCaseIndRep :: IndRep,
_instrCaseBranches :: [CaseBranch' a],
_instrCaseDefault :: Maybe a,
_instrCaseOutVar :: Maybe VarRef
}
deriving stock (Eq, Functor)
data CaseBranch' a = CaseBranch
{ _caseBranchTag :: Tag,
-- | Memory representation of the constructor corresponding to the branch.
_caseBranchMemRep :: MemRep,
_caseBranchArgsNum :: Int,
_caseBranchCode :: a
}
deriving stock (Eq, Functor)
makeLenses ''InstrBinop
makeLenses ''InstrUnop
makeLenses ''InstrAssign
makeLenses ''InstrTrace
makeLenses ''InstrFailure
makeLenses ''InstrAlloc
makeLenses ''InstrAllocClosure
makeLenses ''InstrExtendClosure
makeLenses ''InstrReturn
makeLenses ''InstrTailCall
makeLenses ''InstrCall
makeLenses ''InstrBranch'
makeLenses ''InstrCase'
makeLenses ''CaseBranch'
mkVarRef :: VarGroup -> Index -> VarRef
mkVarRef g i =
VarRef
{ _varRefGroup = g,
_varRefIndex = i,
_varRefName = Nothing
}

7
src/Juvix/Compiler/Reg/Pipeline.hs
View File

@ -4,8 +4,11 @@ module Juvix.Compiler.Reg.Pipeline
)
where
import Juvix.Compiler.Reg.Data.Blocks.InfoTable qualified as Blocks
import Juvix.Compiler.Reg.Data.InfoTable
import Juvix.Compiler.Reg.Transformation
import Juvix.Compiler.Reg.Transformation.Blocks.Liveness qualified as Blocks
import Juvix.Compiler.Reg.Translation.Blocks.FromReg qualified as Blocks
-- | Perform transformations on JuvixReg necessary before the translation to C
toC :: InfoTable -> Sem r InfoTable
@ -13,5 +16,5 @@ toC = applyTransformations toCTransformations
-- | Perform transformations on JuvixReg necessary before the translation to
-- Cairo assembly
toCasm :: InfoTable -> Sem r InfoTable
toCasm = applyTransformations toCasmTransformations
toCasm :: InfoTable -> Sem r Blocks.InfoTable
toCasm = applyTransformations toCasmTransformations >=> return . Blocks.computeLiveness . Blocks.fromReg

10
src/Juvix/Compiler/Reg/Transformation/Blocks/Base.hs Normal file
View File

@ -0,0 +1,10 @@
module Juvix.Compiler.Reg.Transformation.Blocks.Base
( module Juvix.Compiler.Tree.Transformation.Generic.Base,
module Juvix.Compiler.Reg.Data.Blocks.InfoTable,
module Juvix.Compiler.Reg.Language.Blocks,
)
where
import Juvix.Compiler.Reg.Data.Blocks.InfoTable
import Juvix.Compiler.Reg.Language.Blocks
import Juvix.Compiler.Tree.Transformation.Generic.Base

38
src/Juvix/Compiler/Reg/Transformation/Blocks/Liveness.hs Normal file
View File

@ -0,0 +1,38 @@
module Juvix.Compiler.Reg.Transformation.Blocks.Liveness where
import Data.HashSet qualified as HashSet
import Juvix.Compiler.Reg.Extra.Blocks
import Juvix.Compiler.Reg.Transformation.Blocks.Base
computeBlockLiveness :: Block -> Block
computeBlockLiveness = computeBlockLiveness' mempty
computeBlockLiveness' :: HashSet VarRef -> Block -> Block
computeBlockLiveness' vars block = block'' {_blockLiveVars = vars'}
where
block' = over blockNext (fmap (computeBlockLiveness' vars)) block
varsNext = maybe vars (^. blockLiveVars) (block' ^. blockNext)
block'' = overSubBlocks (computeBlockLiveness' varsNext) block'
blocks = getSubBlocks block''
vars0 = if null blocks then varsNext else HashSet.unions $ map (^. blockLiveVars) blocks
vars1 = updateByFinalInstr (block ^. blockFinal) vars0
vars' = foldr updateByInstr vars1 (block ^. blockBody)
updateByFinalInstr :: Maybe FinalInstruction -> HashSet VarRef -> HashSet VarRef
updateByFinalInstr mi acc = case mi of
Nothing -> acc
Just i -> updateBy (getResultVar' i) (getValueRefs' i) acc
updateByInstr :: Instruction -> HashSet VarRef -> HashSet VarRef
updateByInstr i acc = updateBy (getResultVar i) (getValueRefs i) acc
updateBy :: Maybe VarRef -> [VarRef] -> HashSet VarRef -> HashSet VarRef
updateBy mr vs acc = acc2
where
acc1 = case mr of
Nothing -> acc
Just x -> HashSet.delete x acc
acc2 = HashSet.union acc1 (HashSet.fromList vs)
computeLiveness :: InfoTable -> InfoTable
computeLiveness = mapT (const computeBlockLiveness)

43
src/Juvix/Compiler/Reg/Translation/Blocks/FromReg.hs Normal file
View File

@ -0,0 +1,43 @@
module Juvix.Compiler.Reg.Translation.Blocks.FromReg where
import Juvix.Compiler.Reg.Data.Blocks.InfoTable
import Juvix.Compiler.Reg.Data.InfoTable qualified as Reg
import Juvix.Compiler.Reg.Language qualified as Reg
import Juvix.Compiler.Reg.Language.Blocks
fromReg :: Reg.InfoTable -> InfoTable
fromReg = over infoFunctions (fmap (over functionCode goCode))
where
goCode :: Reg.Code -> Block
goCode = fromMaybe emptyBlock . goCode'
goCode' :: Reg.Code -> Maybe Block
goCode' = \case
[] -> Nothing
i : is -> Just $ case i of
Reg.Binop x -> over blockBody (Binop x :) (goCode is)
Reg.Unop x -> over blockBody (Unop x :) (goCode is)
Reg.Assign x -> over blockBody (Assign x :) (goCode is)
Reg.Alloc x -> over blockBody (Alloc x :) (goCode is)
Reg.AllocClosure x -> over blockBody (AllocClosure x :) (goCode is)
Reg.ExtendClosure x -> mkBlock (ExtendClosure x)
Reg.Call x -> mkBlock (Call x)
Reg.TailCall x -> mkBlock (TailCall x)
Reg.Return x -> mkBlock (Return x)
Reg.Branch x -> mkBlock (Branch (fmap goCode x))
Reg.Case x -> mkBlock (Case (fmap goCode x))
Reg.CallClosures {} -> impossible
Reg.TailCallClosures {} -> impossible
Reg.Trace x -> over blockBody (Trace x :) (goCode is)
Reg.Dump -> over blockBody (Dump :) (goCode is)
Reg.Failure x -> over blockBody (Failure x :) (goCode is)
Reg.Prealloc {} -> goCode is
Reg.Nop -> goCode is
Reg.Block Reg.InstrBlock {..} -> goCode (_instrBlockCode ++ is)
where
mkBlock :: FinalInstruction -> Block
mkBlock i' =
emptyBlock
{ _blockFinal = Just i',
_blockNext = goCode' is
}

33
src/Juvix/Compiler/Tree/Extra/Info.hs Normal file
View File

@ -0,0 +1,33 @@
module Juvix.Compiler.Tree.Extra.Info where
import Data.HashMap.Strict qualified as HashMap
import Juvix.Compiler.Backend
import Juvix.Compiler.Tree.Data.InfoTable.Base
import Juvix.Compiler.Tree.Language.Base
userConstrs :: InfoTable' a e -> [ConstructorInfo]
userConstrs tab =
filter (\ci -> not (isBuiltinTag (ci ^. constructorTag))) $
HashMap.elems (tab ^. infoConstrs)
computeUIDs :: Limits -> InfoTable' a e -> HashMap Tag Int
computeUIDs lims tab =
HashMap.fromList $
zipWith
(\ci uid -> (ci ^. constructorTag, uid))
(userConstrs tab)
[lims ^. limitsBuiltinUIDsNum ..]
computeFUIDs :: InfoTable' a e -> HashMap Symbol Int
computeFUIDs tab =
HashMap.fromList $
zipWith
(\fi fuid -> (fi ^. functionSymbol, fuid))
(HashMap.elems (tab ^. infoFunctions))
[0 ..]
computeCIDs :: InfoTable' a e -> HashMap Tag Int
computeCIDs tab = HashMap.fromList $ concatMap go (tab ^. infoInductives)
where
go :: InductiveInfo -> [(Tag, Int)]
go InductiveInfo {..} = zip _inductiveConstructors [0 ..]

8
test/Casm/Compilation/Base.hs
View File

@ -10,6 +10,7 @@ import Juvix.Data.PPOutput
compileAssertion ::
Path Abs Dir ->
Bool ->
Int ->
Path Abs File ->
Path Abs File ->
@ -20,12 +21,13 @@ compileAssertion = compileAssertionEntry (\e -> e {_entryPointFieldSize = cairoF
compileAssertionEntry ::
(EntryPoint -> EntryPoint) ->
Path Abs Dir ->
Bool ->
Int ->
Path Abs File ->
Path Abs File ->
(String -> IO ()) ->
Assertion
compileAssertionEntry adjustEntry root' optLevel mainFile expectedFile step = do
compileAssertionEntry adjustEntry root' bRunVM optLevel mainFile expectedFile step = do
step "Translate to JuvixCore"
entryPoint <- adjustEntry <$> testDefaultEntryPointIO root' mainFile
PipelineResult {..} <- snd <$> testRunIO entryPoint upToStoredCore
@ -37,7 +39,7 @@ compileAssertionEntry adjustEntry root' optLevel mainFile expectedFile step = do
withTempDir'
( \dirPath -> do
let tmpFile = dirPath <//> $(mkRelFile "tmp.out")
step "Serialize"
step "Pretty print"
writeFileEnsureLn tmpFile (toPlainText $ ppProgram _resultCode)
)
casmRunAssertion' False _resultLabelInfo _resultCode expectedFile step
casmRunAssertion' bRunVM _resultLabelInfo _resultCode expectedFile step

68
test/Casm/Compilation/Positive.hs
View File

@ -5,7 +5,8 @@ import Casm.Compilation.Base
import Data.HashSet qualified as HashSet
data PosTest = PosTest
{ _name :: String,
{ _runVM :: Bool,
_name :: String,
_dir :: Path Abs Dir,
_file :: Path Abs File,
_expectedFile :: Path Abs File
@ -24,7 +25,7 @@ toTestDescr optLevel PosTest {..} =
in TestDescr
{ _testName = _name,
_testRoot = tRoot,
_testAssertion = Steps $ compileAssertion _dir optLevel file' expected'
_testAssertion = Steps $ compileAssertion _dir _runVM optLevel file' expected'
}
allTests :: TestTree
@ -39,8 +40,8 @@ allTestsNoOptimize =
"Juvix to CASM positive tests (no optimization)"
(map (mkTest . toTestDescr 0) tests)
posTest :: String -> Path Rel Dir -> Path Rel File -> Path Rel File -> PosTest
posTest _name rdir rfile routfile =
posTest :: String -> Bool -> Path Rel Dir -> Path Rel File -> Path Rel File -> PosTest
posTest _name _runVM rdir rfile routfile =
let _dir = root <//> rdir
_file = _dir <//> rfile
_expectedFile = root <//> routfile
@ -62,291 +63,350 @@ tests =
(not . isIgnored)
[ posTest
"Test001: Arithmetic operators"
True
$(mkRelDir ".")
$(mkRelFile "test001.juvix")
$(mkRelFile "out/test001.out"),
posTest
"Test002: Arithmetic operators inside lambdas"
True
$(mkRelDir ".")
$(mkRelFile "test002.juvix")
$(mkRelFile "out/test002.out"),
posTest
"Test003: Integer arithmetic"
False
$(mkRelDir ".")
$(mkRelFile "test003.juvix")
$(mkRelFile "out/test003.out"),
posTest
"Test005: Higher-order functions"
True
$(mkRelDir ".")
$(mkRelFile "test005.juvix")
$(mkRelFile "out/test005.out"),
posTest
"Test006: If-then-else and lazy boolean operators"
False
$(mkRelDir ".")
$(mkRelFile "test006.juvix")
$(mkRelFile "out/test006.out"),
posTest
"Test007: Pattern matching and lambda-case"
True
$(mkRelDir ".")
$(mkRelFile "test007.juvix")
$(mkRelFile "out/test007.out"),
posTest
"Test008: Recursion"
True
$(mkRelDir ".")
$(mkRelFile "test008.juvix")
$(mkRelFile "out/test008.out"),
posTest
"Test009: Tail recursion"
True
$(mkRelDir ".")
$(mkRelFile "test009.juvix")
$(mkRelFile "out/test009.out"),
posTest
"Test010: Let"
True
$(mkRelDir ".")
$(mkRelFile "test010.juvix")
$(mkRelFile "out/test010.out"),
posTest
"Test013: Functions returning functions with variable capture"
True
$(mkRelDir ".")
$(mkRelFile "test013.juvix")
$(mkRelFile "out/test013.out"),
posTest
"Test014: Arithmetic"
False
$(mkRelDir ".")
$(mkRelFile "test014.juvix")
$(mkRelFile "out/test014.out"),
posTest
"Test015: Local functions with free variables"
False
$(mkRelDir ".")
$(mkRelFile "test015.juvix")
$(mkRelFile "out/test015.out"),
posTest
"Test016: Recursion through higher-order functions"
True
$(mkRelDir ".")
$(mkRelFile "test016.juvix")
$(mkRelFile "out/test016.out"),
posTest
"Test017: Tail recursion through higher-order functions"
True
$(mkRelDir ".")
$(mkRelFile "test017.juvix")
$(mkRelFile "out/test017.out"),
posTest
"Test018: Higher-order functions and recursion"
True
$(mkRelDir ".")
$(mkRelFile "test018.juvix")
$(mkRelFile "out/test018.out"),
posTest
"Test019: Self-application"
True
$(mkRelDir ".")
$(mkRelFile "test019.juvix")
$(mkRelFile "out/test019.out"),
posTest
"Test020: Recursive functions: McCarthy's 91 function, subtraction by increments"
False
$(mkRelDir ".")
$(mkRelFile "test020.juvix")
$(mkRelFile "out/test020.out"),
posTest
"Test021: Fast exponentiation"
False
$(mkRelDir ".")
$(mkRelFile "test021.juvix")
$(mkRelFile "out/test021.out"),
posTest
"Test022: Lists"
True
$(mkRelDir ".")
$(mkRelFile "test022.juvix")
$(mkRelFile "out/test022.out"),
posTest
"Test023: Mutual recursion"
False
$(mkRelDir ".")
$(mkRelFile "test023.juvix")
$(mkRelFile "out/test023.out"),
posTest
"Test024: Nested binders with variable capture"
True
$(mkRelDir ".")
$(mkRelFile "test024.juvix")
$(mkRelFile "out/test024.out"),
posTest
"Test025: Euclid's algorithm"
False
$(mkRelDir ".")
$(mkRelFile "test025.juvix")
$(mkRelFile "out/test025.out"),
posTest
"Test026: Functional queues"
True
$(mkRelDir ".")
$(mkRelFile "test026.juvix")
$(mkRelFile "out/test026.out"),
posTest
"Test028: Streams without memoization"
False
$(mkRelDir ".")
$(mkRelFile "test028.juvix")
$(mkRelFile "out/test028.out"),
posTest
"Test029: Ackermann function"
True
$(mkRelDir ".")
$(mkRelFile "test029.juvix")
$(mkRelFile "out/test029.out"),
posTest
"Test030: Ackermann function (higher-order definition)"
True
$(mkRelDir ".")
$(mkRelFile "test030.juvix")
$(mkRelFile "out/test030.out"),
posTest
"Test032: Merge sort"
False
$(mkRelDir ".")
$(mkRelFile "test032.juvix")
$(mkRelFile "out/test032.out"),
posTest
"Test033: Eta-expansion of builtins and constructors"
False
$(mkRelDir ".")
$(mkRelFile "test033.juvix")
$(mkRelFile "out/test033.out"),
posTest
"Test034: Recursive let"
False
$(mkRelDir ".")
$(mkRelFile "test034.juvix")
$(mkRelFile "out/test034.out"),
posTest
"Test035: Pattern matching"
False
$(mkRelDir ".")
$(mkRelFile "test035.juvix")
$(mkRelFile "out/test035.out"),
posTest
"Test036: Eta-expansion"
False
$(mkRelDir ".")
$(mkRelFile "test036.juvix")
$(mkRelFile "out/test036.out"),
posTest
"Test037: Applications with lets and cases in function position"
True
$(mkRelDir ".")
$(mkRelFile "test037.juvix")
$(mkRelFile "out/test037.out"),
posTest
"Test038: Simple case expression"
True
$(mkRelDir ".")
$(mkRelFile "test038.juvix")
$(mkRelFile "out/test038.out"),
posTest
"Test039: Mutually recursive let expression"
True
$(mkRelDir ".")
$(mkRelFile "test039.juvix")
$(mkRelFile "out/test039.out"),
posTest
"Test040: Pattern matching nullary constructor"
True
$(mkRelDir ".")
$(mkRelFile "test040.juvix")
$(mkRelFile "out/test040.out"),
posTest
"Test045: Implicit builtin bool"
True
$(mkRelDir ".")
$(mkRelFile "test045.juvix")
$(mkRelFile "out/test045.out"),
posTest
"Test046: Polymorphic type arguments"
True
$(mkRelDir ".")
$(mkRelFile "test046.juvix")
$(mkRelFile "out/test046.out"),
posTest
"Test047: Local Modules"
True
$(mkRelDir ".")
$(mkRelFile "test047.juvix")
$(mkRelFile "out/test047.out"),
posTest
"Test050: Pattern matching with integers"
False
$(mkRelDir ".")
$(mkRelFile "test050.juvix")
$(mkRelFile "out/test050.out"),
posTest
"Test053: Inlining"
True
$(mkRelDir ".")
$(mkRelFile "test053.juvix")
$(mkRelFile "out/test053.out"),
posTest
"Test054: Iterators"
True
$(mkRelDir ".")
$(mkRelFile "test054.juvix")
$(mkRelFile "out/test054.out"),
posTest
"Test056: Argument specialization"
True
$(mkRelDir ".")
$(mkRelFile "test056.juvix")
$(mkRelFile "out/test056.out"),
posTest
"Test057: Case folding"
True
$(mkRelDir ".")
$(mkRelFile "test057.juvix")
$(mkRelFile "out/test057.out"),
posTest
"Test058: Ranges"
False
$(mkRelDir ".")
$(mkRelFile "test058.juvix")
$(mkRelFile "out/test058.out"),
posTest
"Test059: Builtin list"
True
$(mkRelDir ".")
$(mkRelFile "test059.juvix")
$(mkRelFile "out/test059.out"),
posTest
"Test060: Record update"
True
$(mkRelDir ".")
$(mkRelFile "test060.juvix")
$(mkRelFile "out/test060.out"),
posTest
"Test062: Overapplication"
True
$(mkRelDir ".")
$(mkRelFile "test062.juvix")
$(mkRelFile "out/test062.out"),
posTest
"Test064: Constant folding"
True
$(mkRelDir ".")
$(mkRelFile "test064.juvix")
$(mkRelFile "out/test064.out"),
posTest
"Test065: Arithmetic simplification"
True
$(mkRelDir ".")
$(mkRelFile "test065.juvix")
$(mkRelFile "out/test065.out"),
posTest
"Test066: Import function with a function call in default argument"
True
$(mkRelDir "test066")
$(mkRelFile "M.juvix")
$(mkRelFile "out/test066.out"),
posTest
"Test067: Dependent default values inserted during translation FromConcrete"
True
$(mkRelDir ".")
$(mkRelFile "test067.juvix")
$(mkRelFile "out/test067.out"),
posTest
"Test068: Dependent default values inserted in the arity checker"
True
$(mkRelDir ".")
$(mkRelFile "test068.juvix")
$(mkRelFile "out/test068.out"),
posTest
"Test069: Dependent default values for Ord trait"
False
$(mkRelDir ".")
$(mkRelFile "test069.juvix")
$(mkRelFile "out/test069.out"),
posTest
"Test070: Nested default values and named arguments"
True
$(mkRelDir ".")
$(mkRelFile "test070.juvix")
$(mkRelFile "out/test070.out"),
posTest
"Test071: Named application (Ord instance with default cmp)"
False
$(mkRelDir ".")
$(mkRelFile "test071.juvix")
$(mkRelFile "out/test071.out"),
posTest
"Test072: Monad transformers (ReaderT + StateT + Identity)"
True
$(mkRelDir "test072")
$(mkRelFile "ReaderT.juvix")
$(mkRelFile "out/test072.out"),
posTest
"Test073: Import and use a syntax alias"
True
$(mkRelDir "test073")
$(mkRelFile "test073.juvix")
$(mkRelFile "out/test073.out"),
posTest
"Test074: Fields"
-- different textual format for "negative" field elements
False
$(mkRelDir ".")
$(mkRelFile "test074.juvix")
$(mkRelFile "out/test074.out")

4
test/Casm/Reg.hs
View File

@ -1,8 +1,8 @@
module Casm.Reg where
import Base
-- import Casm.Reg.Cairo qualified as C
import Casm.Reg.Cairo qualified as C
import Casm.Reg.Positive qualified as P
allTests :: TestTree
allTests = testGroup "JuvixReg to CASM translation" [P.allTests]
allTests = testGroup "JuvixReg to CASM translation" [P.allTests, C.allTests]

1
test/Casm/Reg/Base.hs
View File

@ -15,6 +15,7 @@ compileAssertion' _ outputFile _ tab step = do
case run $ runError @JuvixError $ regToCasm tab of
Left err -> assertFailure (show (pretty (fromJuvixError @GenericError err)))
Right Result {..} -> do
step "Interpret"
hout <- openFile (toFilePath outputFile) WriteMode
let v = hRunCode hout _resultLabelInfo _resultCode
hPrint hout v

13
test/Casm/Reg/Cairo.hs
View File

@ -21,6 +21,17 @@ allTests =
"JuvixReg to Cairo translation positive tests"
( map (mkTest . testDescr) $
P.filterOutTests
[]
[ "Test001: Arithmetic opcodes",
"Test013: Fibonacci numbers in linear time",
"Test014: Trees",
"Test016: Arithmetic",
"Test017: Closures as arguments",
"Test023: McCarthy's 91 function",
"Test024: Higher-order recursive functions",
"Test027: Fast exponentiation",
"Test030: Mutual recursion",
"Test031: Temporary stack with branching",
"Test036: Streams without memoization"
]
P.tests
)

7
test/Casm/Reg/Positive.hs
View File

@ -179,5 +179,10 @@ tests =
"Test038: Apply & argsnum"
$(mkRelDir ".")
$(mkRelFile "test038.jvr")
$(mkRelFile "out/test038.out")
$(mkRelFile "out/test038.out"),
PosTest
"Test039: Calls in a branch"
$(mkRelDir ".")
$(mkRelFile "test039.jvr")
$(mkRelFile "out/test039.out")
]

1
tests/Casm/Reg/positive/out/test039.out Normal file
View File

@ -0,0 +1 @@
14

10
tests/Casm/Reg/positive/test008.jvr
View File

@ -10,18 +10,18 @@ function loop() : * {
function main() : * {
tmp[0] = 3;
tmp[1] = 0;
tmp[0] = lt tmp[1] tmp[0];
tmp[0] = eq tmp[1] tmp[0];
br tmp[0], out: tmp[0] {
true: {
tmp[0] = 1;
tmp[0] = call loop ();
};
false: {
tmp[0] = call loop ();
tmp[0] = 1;
};
};
tmp[1] = 1;
tmp[2] = 2;
tmp[1] = le tmp[2] tmp[1];
tmp[1] = eq tmp[2] tmp[1];
br tmp[1], out: tmp[1] {
true: {
tmp[1] = call loop (), live: (tmp[0]);
@ -29,7 +29,7 @@ function main() : * {
false: {
tmp[1] = 7;
tmp[2] = 8;
tmp[1] = le tmp[2] tmp[1];
tmp[1] = eq tmp[2] tmp[1];
br tmp[1], out: tmp[1] {
true: {
tmp[1] = call loop (), live: (tmp[0]);

286
tests/Casm/Reg/positive/test038.jvr
View File

@ -33,38 +33,36 @@ function apply_1(*, *) : * {
function apply_2(*, *, *) : * {
tmp[1] = arg[0];
tmp[1] = argsnum tmp[1];
{
n = tmp[1];
tmp[1] = n;
tmp[2] = 2;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[2];
tmp[2] = arg[1];
tmp[3] = arg[0];
tcall tmp[3] (tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 1;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[2];
tmp[2] = arg[1];
tmp[3] = arg[0];
tmp[2] = call tmp[3] (tmp[2]), live: (tmp[0], tmp[1], arg[0], arg[1], arg[2]);
tcall apply_1 (tmp[2], tmp[1]);
};
false: {
prealloc 7, live: (tmp[0], arg[0], arg[1], arg[2]);
tmp[1] = arg[2];
tmp[2] = arg[1];
tmp[3] = arg[0];
tmp[1] = cextend tmp[3] (tmp[2], tmp[1]);
ret tmp[1];
};
n = tmp[1];
tmp[1] = n;
tmp[2] = 2;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[2];
tmp[2] = arg[1];
tmp[3] = arg[0];
tcall tmp[3] (tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 1;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[2];
tmp[2] = arg[1];
tmp[3] = arg[0];
tmp[2] = call tmp[3] (tmp[2]), live: (tmp[0], tmp[1], arg[0], arg[1], arg[2]);
tcall apply_1 (tmp[2], tmp[1]);
};
false: {
prealloc 7, live: (tmp[0], arg[0], arg[1], arg[2]);
tmp[1] = arg[2];
tmp[2] = arg[1];
tmp[3] = arg[0];
tmp[1] = cextend tmp[3] (tmp[2], tmp[1]);
ret tmp[1];
};
};
};
@ -74,54 +72,52 @@ function apply_2(*, *, *) : * {
function apply_3(*, *, *, *) : * {
tmp[1] = arg[0];
tmp[1] = argsnum tmp[1];
{
n = tmp[1];
tmp[1] = n;
tmp[2] = 3;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[3];
tmp[2] = arg[2];
tmp[3] = arg[1];
tmp[4] = arg[0];
tcall tmp[4] (tmp[3], tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 3;
tmp[1] = lt tmp[2] tmp[1];
br tmp[1] {
true: {
prealloc 7, live: (tmp[0], arg[0], arg[1], arg[2], arg[3]);
tmp[1] = arg[3];
tmp[2] = arg[2];
tmp[3] = arg[1];
tmp[4] = arg[0];
tmp[1] = cextend tmp[4] (tmp[3], tmp[2], tmp[1]);
ret tmp[1];
};
false: {
tmp[1] = n;
tmp[2] = 2;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[3];
tmp[2] = arg[2];
tmp[3] = arg[1];
tmp[4] = arg[0];
tmp[2] = call tmp[4] (tmp[3], tmp[2]), live: (tmp[0], tmp[1], arg[0], arg[1], arg[2], arg[3]);
tcall apply_1 (tmp[2], tmp[1]);
};
false: {
tmp[1] = arg[3];
tmp[2] = arg[2];
tmp[3] = arg[1];
tmp[4] = arg[0];
tmp[3] = call tmp[4] (tmp[3]), live: (tmp[0], tmp[1], tmp[2], arg[0], arg[1], arg[2], arg[3]);
tcall apply_2 (tmp[3], tmp[2], tmp[1]);
};
n = tmp[1];
tmp[1] = n;
tmp[2] = 3;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[3];
tmp[2] = arg[2];
tmp[3] = arg[1];
tmp[4] = arg[0];
tcall tmp[4] (tmp[3], tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 2;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[3];
tmp[2] = arg[2];
tmp[3] = arg[1];
tmp[4] = arg[0];
tmp[2] = call tmp[4] (tmp[3], tmp[2]), live: (tmp[0], tmp[1], arg[0], arg[1], arg[2], arg[3]);
tcall apply_1 (tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 1;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[3];
tmp[2] = arg[2];
tmp[3] = arg[1];
tmp[4] = arg[0];
tmp[3] = call tmp[4] (tmp[3]), live: (tmp[0], tmp[1], tmp[2], arg[0], arg[1], arg[2], arg[3]);
tcall apply_2 (tmp[3], tmp[2], tmp[1]);
};
false: {
prealloc 7, live: (tmp[0], arg[0], arg[1], arg[2], arg[3]);
tmp[1] = arg[3];
tmp[2] = arg[2];
tmp[3] = arg[1];
tmp[4] = arg[0];
tmp[1] = cextend tmp[4] (tmp[3], tmp[2], tmp[1]);
ret tmp[1];
};
};
};
@ -133,72 +129,70 @@ function apply_3(*, *, *, *) : * {
function apply_4(*, *, *, *, *) : * {
tmp[1] = arg[0];
tmp[1] = argsnum tmp[1];
{
n = tmp[1];
tmp[1] = n;
tmp[2] = 4;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tcall tmp[5] (tmp[4], tmp[3], tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 4;
tmp[1] = lt tmp[2] tmp[1];
br tmp[1] {
true: {
prealloc 7, live: (tmp[0], arg[0], arg[1], arg[2], arg[3], arg[4]);
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tmp[1] = cextend tmp[5] (tmp[4], tmp[3], tmp[2], tmp[1]);
ret tmp[1];
};
false: {
tmp[1] = n;
tmp[2] = 3;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tmp[2] = call tmp[5] (tmp[4], tmp[3], tmp[2]), live: (tmp[0], tmp[1], arg[0], arg[1], arg[2], arg[3], arg[4]);
tcall apply_1 (tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 2;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tmp[3] = call tmp[5] (tmp[4], tmp[3]), live: (tmp[0], tmp[1], tmp[2], arg[0], arg[1], arg[2], arg[3], arg[4]);
tcall apply_2 (tmp[3], tmp[2], tmp[1]);
};
false: {
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tmp[4] = call tmp[5] (tmp[4]), live: (tmp[0], tmp[1], tmp[2], tmp[3], arg[0], arg[1], arg[2], arg[3], arg[4]);
tcall apply_3 (tmp[4], tmp[3], tmp[2], tmp[1]);
};
n = tmp[1];
tmp[1] = n;
tmp[2] = 4;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tcall tmp[5] (tmp[4], tmp[3], tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 3;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tmp[2] = call tmp[5] (tmp[4], tmp[3], tmp[2]), live: (tmp[0], tmp[1], arg[0], arg[1], arg[2], arg[3], arg[4]);
tcall apply_1 (tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 2;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tmp[3] = call tmp[5] (tmp[4], tmp[3]), live: (tmp[0], tmp[1], tmp[2], arg[0], arg[1], arg[2], arg[3], arg[4]);
tcall apply_2 (tmp[3], tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 1;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tmp[4] = call tmp[5] (tmp[4]), live: (tmp[0], tmp[1], tmp[2], tmp[3], arg[0], arg[1], arg[2], arg[3], arg[4]);
tcall apply_3 (tmp[4], tmp[3], tmp[2], tmp[1]);
};
false: {
prealloc 7, live: (tmp[0], arg[0], arg[1], arg[2], arg[3], arg[4]);
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tmp[1] = cextend tmp[5] (tmp[4], tmp[3], tmp[2], tmp[1]);
ret tmp[1];
};
};
};

32
tests/Casm/Reg/positive/test039.jvr Normal file
View File

@ -0,0 +1,32 @@
-- calls in a branch
function f(integer) : integer {
tmp[0] = add arg[0] 1;
ret tmp[0];
}
function main() : integer {
tmp[0] = 10;
tmp[1] = 1;
tmp[2] = eq tmp[0] tmp[1];
br tmp[2], out: tmp[4] {
true: {
tmp[4] = 0;
};
false: {
tmp[3] = call f(tmp[1]);
tmp[4] = eq tmp[3] tmp[3];
br tmp[4], out: tmp[4] {
true: {
tmp[4] = call f(tmp[3]);
tmp[4] = call f(tmp[4]);
};
false: {
tmp[4] = 1;
};
};
};
};
tmp[5] = add tmp[4] tmp[0];
ret tmp[5];
}

286
tests/Reg/positive/test038.jvr
View File

@ -33,38 +33,36 @@ function apply_1(*, *) : * {
function apply_2(*, *, *) : * {
tmp[1] = arg[0];
tmp[1] = argsnum tmp[1];
{
n = tmp[1];
tmp[1] = n;
tmp[2] = 2;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[2];
tmp[2] = arg[1];
tmp[3] = arg[0];
tcall tmp[3] (tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 1;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[2];
tmp[2] = arg[1];
tmp[3] = arg[0];
tmp[2] = call tmp[3] (tmp[2]), live: (tmp[0], tmp[1], arg[0], arg[1], arg[2]);
tcall apply_1 (tmp[2], tmp[1]);
};
false: {
prealloc 7, live: (tmp[0], arg[0], arg[1], arg[2]);
tmp[1] = arg[2];
tmp[2] = arg[1];
tmp[3] = arg[0];
tmp[1] = cextend tmp[3] (tmp[2], tmp[1]);
ret tmp[1];
};
n = tmp[1];
tmp[1] = n;
tmp[2] = 2;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[2];
tmp[2] = arg[1];
tmp[3] = arg[0];
tcall tmp[3] (tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 1;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[2];
tmp[2] = arg[1];
tmp[3] = arg[0];
tmp[2] = call tmp[3] (tmp[2]), live: (tmp[0], tmp[1], arg[0], arg[1], arg[2]);
tcall apply_1 (tmp[2], tmp[1]);
};
false: {
prealloc 7, live: (tmp[0], arg[0], arg[1], arg[2]);
tmp[1] = arg[2];
tmp[2] = arg[1];
tmp[3] = arg[0];
tmp[1] = cextend tmp[3] (tmp[2], tmp[1]);
ret tmp[1];
};
};
};
@ -74,54 +72,52 @@ function apply_2(*, *, *) : * {
function apply_3(*, *, *, *) : * {
tmp[1] = arg[0];
tmp[1] = argsnum tmp[1];
{
n = tmp[1];
tmp[1] = n;
tmp[2] = 3;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[3];
tmp[2] = arg[2];
tmp[3] = arg[1];
tmp[4] = arg[0];
tcall tmp[4] (tmp[3], tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 3;
tmp[1] = lt tmp[2] tmp[1];
br tmp[1] {
true: {
prealloc 7, live: (tmp[0], arg[0], arg[1], arg[2], arg[3]);
tmp[1] = arg[3];
tmp[2] = arg[2];
tmp[3] = arg[1];
tmp[4] = arg[0];
tmp[1] = cextend tmp[4] (tmp[3], tmp[2], tmp[1]);
ret tmp[1];
};
false: {
tmp[1] = n;
tmp[2] = 2;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[3];
tmp[2] = arg[2];
tmp[3] = arg[1];
tmp[4] = arg[0];
tmp[2] = call tmp[4] (tmp[3], tmp[2]), live: (tmp[0], tmp[1], arg[0], arg[1], arg[2], arg[3]);
tcall apply_1 (tmp[2], tmp[1]);
};
false: {
tmp[1] = arg[3];
tmp[2] = arg[2];
tmp[3] = arg[1];
tmp[4] = arg[0];
tmp[3] = call tmp[4] (tmp[3]), live: (tmp[0], tmp[1], tmp[2], arg[0], arg[1], arg[2], arg[3]);
tcall apply_2 (tmp[3], tmp[2], tmp[1]);
};
n = tmp[1];
tmp[1] = n;
tmp[2] = 3;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[3];
tmp[2] = arg[2];
tmp[3] = arg[1];
tmp[4] = arg[0];
tcall tmp[4] (tmp[3], tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 2;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[3];
tmp[2] = arg[2];
tmp[3] = arg[1];
tmp[4] = arg[0];
tmp[2] = call tmp[4] (tmp[3], tmp[2]), live: (tmp[0], tmp[1], arg[0], arg[1], arg[2], arg[3]);
tcall apply_1 (tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 1;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[3];
tmp[2] = arg[2];
tmp[3] = arg[1];
tmp[4] = arg[0];
tmp[3] = call tmp[4] (tmp[3]), live: (tmp[0], tmp[1], tmp[2], arg[0], arg[1], arg[2], arg[3]);
tcall apply_2 (tmp[3], tmp[2], tmp[1]);
};
false: {
prealloc 7, live: (tmp[0], arg[0], arg[1], arg[2], arg[3]);
tmp[1] = arg[3];
tmp[2] = arg[2];
tmp[3] = arg[1];
tmp[4] = arg[0];
tmp[1] = cextend tmp[4] (tmp[3], tmp[2], tmp[1]);
ret tmp[1];
};
};
};
@ -133,72 +129,70 @@ function apply_3(*, *, *, *) : * {
function apply_4(*, *, *, *, *) : * {
tmp[1] = arg[0];
tmp[1] = argsnum tmp[1];
{
n = tmp[1];
tmp[1] = n;
tmp[2] = 4;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tcall tmp[5] (tmp[4], tmp[3], tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 4;
tmp[1] = lt tmp[2] tmp[1];
br tmp[1] {
true: {
prealloc 7, live: (tmp[0], arg[0], arg[1], arg[2], arg[3], arg[4]);
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tmp[1] = cextend tmp[5] (tmp[4], tmp[3], tmp[2], tmp[1]);
ret tmp[1];
};
false: {
tmp[1] = n;
tmp[2] = 3;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tmp[2] = call tmp[5] (tmp[4], tmp[3], tmp[2]), live: (tmp[0], tmp[1], arg[0], arg[1], arg[2], arg[3], arg[4]);
tcall apply_1 (tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 2;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tmp[3] = call tmp[5] (tmp[4], tmp[3]), live: (tmp[0], tmp[1], tmp[2], arg[0], arg[1], arg[2], arg[3], arg[4]);
tcall apply_2 (tmp[3], tmp[2], tmp[1]);
};
false: {
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tmp[4] = call tmp[5] (tmp[4]), live: (tmp[0], tmp[1], tmp[2], tmp[3], arg[0], arg[1], arg[2], arg[3], arg[4]);
tcall apply_3 (tmp[4], tmp[3], tmp[2], tmp[1]);
};
n = tmp[1];
tmp[1] = n;
tmp[2] = 4;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tcall tmp[5] (tmp[4], tmp[3], tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 3;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tmp[2] = call tmp[5] (tmp[4], tmp[3], tmp[2]), live: (tmp[0], tmp[1], arg[0], arg[1], arg[2], arg[3], arg[4]);
tcall apply_1 (tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 2;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tmp[3] = call tmp[5] (tmp[4], tmp[3]), live: (tmp[0], tmp[1], tmp[2], arg[0], arg[1], arg[2], arg[3], arg[4]);
tcall apply_2 (tmp[3], tmp[2], tmp[1]);
};
false: {
tmp[1] = n;
tmp[2] = 1;
tmp[1] = eq tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tmp[4] = call tmp[5] (tmp[4]), live: (tmp[0], tmp[1], tmp[2], tmp[3], arg[0], arg[1], arg[2], arg[3], arg[4]);
tcall apply_3 (tmp[4], tmp[3], tmp[2], tmp[1]);
};
false: {
prealloc 7, live: (tmp[0], arg[0], arg[1], arg[2], arg[3], arg[4]);
tmp[1] = arg[4];
tmp[2] = arg[3];
tmp[3] = arg[2];
tmp[4] = arg[1];
tmp[5] = arg[0];
tmp[1] = cextend tmp[5] (tmp[4], tmp[3], tmp[2], tmp[1]);
ret tmp[1];
};
};
};

24
tests/Tree/positive/test038.jvt
View File

@ -32,11 +32,11 @@ function apply_3(*, *, *, *) : * {
save[n](argsnum(arg[0])) {
br(eq(3, n)) {
true: call(arg[0], arg[1], arg[2], arg[3])
false: br(lt(3, n)) {
true: cextend(arg[0], arg[1], arg[2], arg[3])
false: br(eq(2, n)) {
true: call[apply_1](call(arg[0], arg[1], arg[2]), arg[3])
false: call[apply_2](call(arg[0], arg[1]), arg[2], arg[3])
false: br(eq(2, n)) {
true: call[apply_1](call(arg[0], arg[1], arg[2]), arg[3])
false: br(eq(1, n)) {
true: call[apply_2](call(arg[0], arg[1]), arg[2], arg[3])
false: cextend(arg[0], arg[1], arg[2], arg[3])
}
}
}
@ -47,13 +47,13 @@ function apply_4(*, *, *, *, *) : * {
save[n](argsnum(arg[0])) {
br(eq(4, n)) {
true: call(arg[0], arg[1], arg[2], arg[3], arg[4])
false: br(lt(4, n)) {
true: cextend(arg[0], arg[1], arg[2], arg[3], arg[4])
false: br(eq(3, n)) {
true: call[apply_1](call(arg[0], arg[1], arg[2], arg[3]), arg[4])
false: br(eq(2, n)) {
true: call[apply_2](call(arg[0], arg[1], arg[2]), arg[3], arg[4])
false: call[apply_3](call(arg[0], arg[1]), arg[2], arg[3], arg[4])
false: br(eq(3, n)) {
true: call[apply_1](call(arg[0], arg[1], arg[2], arg[3]), arg[4])
false: br(eq(2, n)) {
true: call[apply_2](call(arg[0], arg[1], arg[2]), arg[3], arg[4])
false: br(eq(1, n)) {
true: call[apply_3](call(arg[0], arg[1]), arg[2], arg[3], arg[4])
false: cextend(arg[0], arg[1], arg[2], arg[3], arg[4])
}
}
}