aboutsummaryrefslogtreecommitdiff
path: root/src/Reflection/MapCastWithCastOp.v
diff options
context:
space:
mode:
authorGravatar Jason Gross <jgross@mit.edu>2017-01-19 19:35:24 -0500
committerGravatar Jason Gross <jgross@mit.edu>2017-01-19 19:35:24 -0500
commitfa027c4a37ed455a26a5bb12c6f3d54ae4bd8774 (patch)
tree4e6d08d6d36595a068f3facf2c70f540bae0e8b1 /src/Reflection/MapCastWithCastOp.v
parent320c013f0c5550aed168dd7fd25274dbb9756590 (diff)
Remove the Const constructor of exprf
We instead use the [Op] constructor for constants. This allows [exprf] to not depend on the interpretation function; this means we don't need to map over it to change the interpretation function. This saves us about 300 lines of code and about 30s of build time, total. After | File Name | Before || Change ----------------------------------------------------------------------------------------------------------- 18m11.34s | Total | 18m46.86s || -0m35.52s ----------------------------------------------------------------------------------------------------------- 0m19.99s | Specific/GF25519ReflectiveAddCoordinates | 0m31.78s || -0m11.79s 1m53.69s | Specific/GF25519Reflective/Reified/LadderStep | 2m01.32s || -0m07.62s 1m27.74s | Specific/GF25519Reflective/Reified/AddCoordinates | 1m34.03s || -0m06.29s 0m01.45s | Specific/GF25519Reflective | 0m06.31s || -0m04.85s 0m04.62s | Reflection/InlineInterp | 0m01.52s || +0m03.10s 1m19.68s | CompleteEdwardsCurve/ExtendedCoordinates | 1m21.19s || -0m01.50s 0m02.90s | Reflection/InlineWf | 0m01.80s || +0m01.09s N/A | Reflection/MapWithInterpInfo | 0m01.70s || -0m01.70s 1m32.32s | Test/Curve25519SpecTestVectors | 1m32.25s || +0m00.06s 1m12.79s | Experiments/Ed25519 | 1m13.17s || -0m00.38s 0m40.52s | ModularArithmetic/Conversion | 0m40.44s || +0m00.08s 0m34.57s | Spec/Ed25519 | 0m34.53s || +0m00.03s 0m30.82s | ModularArithmetic/ModularBaseSystemProofs | 0m30.89s || -0m00.07s 0m30.11s | Specific/GF25519Bounded | 0m30.21s || -0m00.10s 0m23.20s | Experiments/MontgomeryCurve | 0m23.26s || -0m00.06s 0m22.16s | Reflection/Z/Interpretations128/Relations | 0m21.72s || +0m00.44s 0m21.69s | ModularArithmetic/Pow2BaseProofs | 0m21.58s || +0m00.11s 0m20.25s | Algebra | 0m20.27s || -0m00.01s 0m19.81s | Specific/GF25519 | 0m19.83s || -0m00.01s 0m18.82s | Reflection/Z/Interpretations64/Relations | 0m18.50s || +0m00.32s 0m18.19s | EdDSARepChange | 0m18.26s || -0m00.07s 0m17.08s | CompleteEdwardsCurve/CompleteEdwardsCurveTheorems | 0m17.16s || -0m00.08s 0m14.10s | Util/ZUtil | 0m14.03s || +0m00.07s 0m10.05s | Testbit | 0m10.02s || +0m00.03s 0m08.95s | Specific/GF25519BoundedCommon | 0m08.90s || +0m00.04s 0m08.87s | BoundedArithmetic/ArchitectureToZLikeProofs | 0m08.81s || +0m00.05s 0m08.80s | Assembly/GF25519 | 0m08.82s || -0m00.01s 0m08.80s | ModularArithmetic/Montgomery/ZProofs | 0m08.87s || -0m00.06s 0m08.51s | Encoding/PointEncoding | 0m08.53s || -0m00.01s 0m08.37s | BoundedArithmetic/Double/Proofs/Multiply | 0m08.39s || -0m00.02s 0m08.34s | Specific/GF1305 | 0m08.31s || +0m00.02s 0m07.85s | BoundedArithmetic/Double/Proofs/ShiftRightDoubleWordImmediate | 0m07.86s || -0m00.01s 0m07.60s | Specific/GF25519Reflective/Reified/Mul | 0m07.52s || +0m00.08s 0m07.13s | MxDHRepChange | 0m07.08s || +0m00.04s 0m06.85s | BoundedArithmetic/Double/Proofs/SpreadLeftImmediate | 0m06.77s || +0m00.08s 0m06.62s | Reflection/Z/InterpretationsGen | 0m06.62s || +0m00.00s 0m05.69s | Reflection/Z/Interpretations64/RelationsCombinations | 0m05.60s || +0m00.09s 0m05.68s | Reflection/Z/Interpretations128/RelationsCombinations | 0m05.67s || +0m00.00s 0m05.48s | Specific/SC25519 | 0m05.38s || +0m00.10s 0m05.40s | BoundedArithmetic/Double/Proofs/RippleCarryAddSub | 0m05.36s || +0m00.04s 0m04.93s | ModularArithmetic/ModularBaseSystemListProofs | 0m04.96s || -0m00.03s 0m04.87s | WeierstrassCurve/Pre | 0m04.83s || +0m00.04s 0m04.45s | Specific/GF25519Reflective/Reified/PreFreeze | 0m04.56s || -0m00.10s 0m04.33s | Specific/GF25519Reflective/CommonBinOp | 0m04.55s || -0m00.21s 0m03.95s | ModularArithmetic/BarrettReduction/ZHandbook | 0m03.98s || -0m00.02s 0m03.87s | Specific/GF25519Reflective/CommonUnOp | 0m04.08s || -0m00.20s 0m03.86s | Encoding/PointEncodingPre | 0m03.88s || -0m00.02s 0m03.84s | BaseSystemProofs | 0m03.88s || -0m00.04s 0m03.75s | Specific/GF25519Reflective/CommonUnOpWireToFE | 0m03.96s || -0m00.20s 0m03.64s | CompleteEdwardsCurve/Pre | 0m03.60s || +0m00.04s 0m03.51s | BoundedArithmetic/InterfaceProofs | 0m03.42s || +0m00.08s 0m03.41s | ModularArithmetic/Tutorial | 0m03.38s || +0m00.03s 0m03.30s | Reflection/LinearizeWf | 0m04.24s || -0m00.94s 0m03.20s | Specific/GF25519Reflective/Reified/CarrySub | 0m03.28s || -0m00.07s 0m03.14s | ModularArithmetic/ZBoundedZ | 0m03.14s || +0m00.00s 0m03.14s | ModularArithmetic/BarrettReduction/ZGeneralized | 0m03.14s || +0m00.00s 0m02.95s | Specific/GF25519Reflective/Reified/CarryAdd | 0m02.93s || +0m00.02s 0m02.92s | Specific/GF25519Reflective/Common9_4Op | 0m02.89s || +0m00.02s 0m02.82s | Specific/GF25519Reflective/Reified/CarryOpp | 0m02.95s || -0m00.13s 0m02.82s | BoundedArithmetic/Double/Proofs/Decode | 0m02.90s || -0m00.08s 0m02.69s | BoundedArithmetic/Double/Proofs/ShiftRight | 0m02.69s || +0m00.00s 0m02.66s | ModularArithmetic/ModularArithmeticTheorems | 0m02.67s || -0m00.00s 0m02.63s | Specific/FancyMachine256/Montgomery | 0m02.24s || +0m00.38s 0m02.61s | Specific/GF25519Reflective/CommonUnOpFEToWire | 0m02.76s || -0m00.14s 0m02.58s | BoundedArithmetic/Double/Proofs/ShiftLeft | 0m02.58s || +0m00.00s 0m02.56s | Specific/GF25519Reflective/Common | 0m02.60s || -0m00.04s 0m02.52s | Specific/FancyMachine256/Barrett | 0m02.20s || +0m00.31s 0m02.50s | Specific/GF25519BoundedAddCoordinates | 0m02.60s || -0m00.10s 0m02.39s | ModularArithmetic/BarrettReduction/ZBounded | 0m02.31s || +0m00.08s 0m02.34s | ModularArithmetic/ModularBaseSystemOpt | 0m02.31s || +0m00.02s 0m02.02s | Specific/GF25519Reflective/Reified/Sub | 0m02.01s || +0m00.01s 0m01.98s | Reflection/WfReflective | 0m02.54s || -0m00.56s 0m01.94s | Specific/GF25519Reflective/Reified/Pack | 0m02.07s || -0m00.12s 0m01.93s | Assembly/Evaluables | 0m01.93s || +0m00.00s 0m01.92s | Specific/GF25519Reflective/Reified/Unpack | 0m02.04s || -0m00.12s 0m01.90s | Specific/FancyMachine256/Core | 0m01.79s || +0m00.10s 0m01.79s | ModularArithmetic/Montgomery/ZBounded | 0m01.86s || -0m00.07s 0m01.77s | Specific/GF25519ExtendedAddCoordinates | 0m01.76s || +0m00.01s 0m01.68s | Specific/GF25519Reflective/Reified/Add | 0m01.69s || -0m00.01s 0m01.67s | Specific/GF25519BoundedExtendedAddCoordinates | 0m01.79s || -0m00.12s 0m01.63s | Experiments/Ed25519Extraction | 0m01.66s || -0m00.03s 0m01.62s | Specific/GF25519Reflective/Reified/Opp | 0m01.72s || -0m00.09s 0m01.54s | Specific/GF25519Reflective/Reified/GeModulus | 0m01.59s || -0m00.05s 0m01.50s | Reflection/TestCase | 0m01.42s || +0m00.08s 0m01.47s | ModularArithmetic/BarrettReduction/Z | 0m01.47s || +0m00.00s 0m01.43s | Assembly/Compile | 0m01.46s || -0m00.03s 0m01.33s | Reflection/WfProofs | 0m01.95s || -0m00.61s 0m01.26s | ModularArithmetic/PrimeFieldTheorems | 0m01.28s || -0m00.02s 0m01.20s | Assembly/Conversions | 0m01.19s || +0m00.01s 0m01.16s | ModularArithmetic/ExtendedBaseVector | 0m01.22s || -0m00.06s 0m01.16s | BaseSystem | 0m01.15s || +0m00.01s 0m01.09s | BoundedArithmetic/Double/Repeated/Proofs/Decode | 0m01.11s || -0m00.02s 0m00.99s | Util/NumTheoryUtil | 0m00.96s || +0m00.03s 0m00.96s | Assembly/HL | 0m00.96s || +0m00.00s 0m00.94s | Assembly/LL | 0m00.99s || -0m00.05s 0m00.94s | Assembly/Pipeline | 0m00.92s || +0m00.01s 0m00.88s | Reflection/WfInversion | 0m01.21s || -0m00.32s 0m00.86s | Assembly/PhoasCommon | 0m00.91s || -0m00.05s 0m00.86s | Specific/GF25519Reflective/CommonUnOpFEToZ | 0m01.02s || -0m00.16s 0m00.85s | BoundedArithmetic/Double/Proofs/LoadImmediate | 0m00.86s || -0m00.01s 0m00.84s | BoundedArithmetic/Double/Proofs/BitwiseOr | 0m00.91s || -0m00.07s 0m00.82s | BoundedArithmetic/X86ToZLikeProofs | 0m00.85s || -0m00.03s 0m00.79s | Util/IterAssocOp | 0m00.82s || -0m00.02s 0m00.75s | Reflection/Z/Syntax | 0m00.67s || +0m00.07s 0m00.73s | Util/PartiallyReifiedProp | 0m00.73s || +0m00.00s 0m00.70s | Encoding/ModularWordEncodingTheorems | 0m00.76s || -0m00.06s 0m00.70s | Specific/GF25519Reflective/Reified | 0m00.72s || -0m00.02s 0m00.66s | BoundedArithmetic/Double/Repeated/Proofs/Multiply | 0m00.62s || +0m00.04s 0m00.66s | ModularArithmetic/PseudoMersenneBaseParamProofs | 0m00.66s || +0m00.00s 0m00.64s | Encoding/ModularWordEncodingPre | 0m00.63s || +0m00.01s 0m00.61s | ModularArithmetic/ModularBaseSystem | 0m00.66s || -0m00.05s 0m00.61s | Util/AdditionChainExponentiation | 0m00.64s || -0m00.03s 0m00.60s | ModularArithmetic/ExtPow2BaseMulProofs | 0m00.64s || -0m00.04s 0m00.60s | Reflection/MultiSizeTest2 | 0m00.71s || -0m00.10s 0m00.60s | Spec/EdDSA | 0m00.65s || -0m00.05s 0m00.59s | BoundedArithmetic/Double/Repeated/Proofs/RippleCarryAddSub | 0m00.51s || +0m00.07s 0m00.58s | BoundedArithmetic/Interface | 0m00.60s || -0m00.02s 0m00.58s | ModularArithmetic/ModularBaseSystemList | 0m00.61s || -0m00.03s 0m00.55s | Spec/ModularWordEncoding | 0m00.63s || -0m00.07s 0m00.55s | BoundedArithmetic/Double/Repeated/Proofs/ShiftLeftRight | 0m00.50s || +0m00.05s 0m00.55s | Reflection/InterpWfRel | 0m00.58s || -0m00.02s 0m00.54s | BoundedArithmetic/X86ToZLike | 0m00.55s || -0m00.01s 0m00.54s | BoundedArithmetic/Double/Repeated/Proofs/SelectConditional | 0m00.53s || +0m00.01s 0m00.54s | BoundedArithmetic/Double/Proofs/SelectConditional | 0m00.62s || -0m00.07s 0m00.54s | Reflection/WfReflectiveGen | 0m00.58s || -0m00.03s 0m00.52s | BoundedArithmetic/ArchitectureToZLike | 0m00.41s || +0m00.11s 0m00.51s | BoundedArithmetic/Double/Core | 0m00.48s || +0m00.03s 0m00.50s | BoundedArithmetic/Double/Repeated/Proofs/BitwiseOr | 0m00.51s || -0m00.01s 0m00.49s | Spec/WeierstrassCurve | 0m00.42s || +0m00.07s 0m00.48s | BoundedArithmetic/Double/Repeated/Proofs/LoadImmediate | 0m00.54s || -0m00.06s 0m00.47s | BoundedArithmetic/Double/Repeated/Proofs/ShiftRightDoubleWordImmediate | 0m00.58s || -0m00.10s 0m00.47s | Reflection/InterpWf | 0m00.50s || -0m00.03s 0m00.47s | ModularArithmetic/Pre | 0m00.48s || -0m00.01s 0m00.47s | BoundedArithmetic/Double/Repeated/Core | 0m00.46s || +0m00.00s 0m00.46s | Reflection/Z/Interpretations64 | 0m00.49s || -0m00.02s 0m00.45s | Reflection/InputSyntax | 0m00.42s || +0m00.03s N/A | Reflection/MapInterpWf | 0m00.44s || -0m00.44s 0m00.44s | Spec/CompleteEdwardsCurve | 0m00.39s || +0m00.04s 0m00.44s | BoundedArithmetic/Double/Proofs/ShiftLeftRightTactic | 0m00.42s || +0m00.02s 0m00.44s | Reflection/Z/Interpretations128 | 0m00.52s || -0m00.08s 0m00.44s | ModularArithmetic/ZBounded | 0m00.45s || -0m00.01s 0m00.42s | BoundedArithmetic/StripCF | 0m00.42s || +0m00.00s 0m00.42s | Reflection/Z/Reify | 0m00.43s || -0m00.01s 0m00.42s | ModularArithmetic/ModularBaseSystemListZOperationsProofs | 0m00.47s || -0m00.04s 0m00.41s | Reflection/Named/DeadCodeElimination | 0m00.43s || -0m00.02s 0m00.41s | ModularArithmetic/PseudoMersenneBaseParams | 0m00.38s || +0m00.02s 0m00.41s | Spec/ModularArithmetic | 0m00.34s || +0m00.06s 0m00.41s | Reflection/Named/RegisterAssign | 0m00.37s || +0m00.03s 0m00.41s | Reflection/Reify | 0m00.39s || +0m00.01s 0m00.40s | ModularArithmetic/Pow2Base | 0m00.42s || -0m00.01s 0m00.40s | Reflection/Named/EstablishLiveness | 0m00.33s || +0m00.07s 0m00.40s | Reflection/ExprInversion | 0m00.57s || -0m00.16s 0m00.40s | Reflection/Named/Syntax | 0m00.40s || +0m00.00s 0m00.38s | Reflection/Named/Compile | 0m00.34s || +0m00.03s N/A | Reflection/MapInterp | 0m00.38s || -0m00.38s 0m00.38s | ModularArithmetic/Montgomery/Z | 0m00.39s || -0m00.01s 0m00.38s | ModularArithmetic/ModularBaseSystemWord | 0m00.36s || +0m00.02s N/A | Reflection/WfRel | 0m00.38s || -0m00.38s 0m00.38s | Reflection/Tuple | N/A || +0m00.38s 0m00.37s | Spec/MxDH | 0m00.39s || -0m00.02s 0m00.37s | BoundedArithmetic/Eta | 0m00.36s || +0m00.01s 0m00.36s | Reflection/Named/ContextOn | 0m00.37s || -0m00.01s 0m00.34s | Reflection/FilterLive | 0m00.34s || +0m00.00s 0m00.34s | Reflection/LinearizeInterp | 0m00.53s || -0m00.19s 0m00.33s | Reflection/Relations | N/A || +0m00.33s 0m00.32s | Reflection/Equality | 0m00.41s || -0m00.08s 0m00.30s | Reflection/Syntax | 0m00.52s || -0m00.22s 0m00.30s | Reflection/InterpProofs | 0m00.47s || -0m00.17s 0m00.30s | Reflection/ApplicationLemmas | 0m00.43s || -0m00.13s 0m00.30s | Reflection/CommonSubexpressionElimination | 0m00.50s || -0m00.20s 0m00.28s | Reflection/Inline | 0m00.37s || -0m00.08s 0m00.28s | Reflection/Conversion | 0m00.44s || -0m00.15s 0m00.27s | Reflection/MapCastWithCastOp | 0m00.38s || -0m00.10s 0m00.26s | Reflection/MapCast | 0m00.40s || -0m00.14s 0m00.26s | Reflection/ApplicationRelations | 0m00.35s || -0m00.08s 0m00.24s | Reflection/Application | 0m00.38s || -0m00.14s 0m00.23s | Reflection/Linearize | 0m00.35s || -0m00.11s 0m00.20s | Reflection/CountLets | 0m00.33s || -0m00.13s 0m00.20s | Reflection/Named/NameUtil | 0m00.36s || -0m00.15s 0m00.09s | Util/PointedProp | 0m00.08s || +0m00.00s 0m00.05s | Util/LetIn | 0m00.06s || -0m00.00s 0m00.03s | Util/Notations | 0m00.03s || +0m00.00s 0m00.03s | Util/AutoRewrite | 0m00.03s || +0m00.00s
Diffstat (limited to 'src/Reflection/MapCastWithCastOp.v')
-rw-r--r--src/Reflection/MapCastWithCastOp.v98
1 files changed, 62 insertions, 36 deletions
diff --git a/src/Reflection/MapCastWithCastOp.v b/src/Reflection/MapCastWithCastOp.v
index 189399fad..ae41e1181 100644
--- a/src/Reflection/MapCastWithCastOp.v
+++ b/src/Reflection/MapCastWithCastOp.v
@@ -10,7 +10,6 @@ Local Open Scope ctype_scope.
Local Open Scope expr_scope.
Section language.
Context {base_type_code1 base_type_code2 : Type}
- {interp_base_type1 : base_type_code1 -> Type}
{interp_base_type2 : base_type_code2 -> Type}
{op1 : flat_type base_type_code1 -> flat_type base_type_code1 -> Type}
{op2 : flat_type base_type_code2 -> flat_type base_type_code2 -> Type}
@@ -18,40 +17,44 @@ Section language.
(base_type_code1_beq : base_type_code1 -> base_type_code1 -> bool)
(base_type_code1_bl : forall x y, base_type_code1_beq x y = true -> x = y)
(base_type_code1_lb : forall x y, x = y -> base_type_code1_beq x y = true)
- (failv : forall {t}, interp_base_type1 t)
+ (failv : forall {var t}, @exprf base_type_code1 op1 var (Tbase t))
(new_base_type : forall t, interp_base_type2 t -> base_type_code1)
- (transfer_base_const : forall t1 t2 (x1 : interp_base_type1 t1) (x2 : interp_base_type2 t2),
- interp_base_type1 (new_base_type t2 x2))
- (Cast : forall var t1 t2, @exprf base_type_code1 interp_base_type1 op1 var (Tbase t1)
- -> @exprf base_type_code1 interp_base_type1 op1 var (Tbase t2))
+ (Cast : forall var t1 t2, @exprf base_type_code1 op1 var (Tbase t1)
+ -> @exprf base_type_code1 op1 var (Tbase t2))
(is_cast : forall t1 t2, op1 t1 t2 -> bool).
Local Notation new_flat_type (*: forall t, interp_flat_type interp_base_type2 t -> flat_type base_type_code1*)
:= (@SmartFlatTypeMap2 _ _ interp_base_type2 (fun t v => Tbase (new_base_type t v))).
Local Notation new_type := (@new_type base_type_code1 base_type_code2 interp_base_type2 new_base_type).
Context (new_op : forall ovar src1 dst1 src2 dst2 (opc1 : op1 src1 dst1) (opc2 : op2 src2 dst2)
- args2,
- option { new_src : _ & (@exprf base_type_code1 interp_base_type1 op1 ovar new_src
- -> @exprf base_type_code1 interp_base_type1 op1 ovar (new_flat_type (interpf interp_op2 (Op opc2 args2))))%type }).
+ args2,
+ option { new_src : _ & (@exprf base_type_code1 op1 ovar new_src
+ -> @exprf base_type_code1 op1 ovar (new_flat_type (interpf interp_op2 (Op opc2 args2))))%type }).
+ Local Notation SmartFail
+ := (SmartValf _ (@failv _)).
+ Local Notation failf t (* {t} : @exprf base_type_code1 op1 ovar t*)
+ := (SmartPairf (SmartFail t)).
- Fixpoint VarBound {var} T1 T2 : interp_flat_type var T1 -> exprf _ interp_base_type1 op1 (var:=var) T2
- := match T1, T2 return interp_flat_type var T1 -> exprf _ _ _ T2 with
+ Fixpoint VarBound {var} T1 T2 : interp_flat_type var T1 -> exprf _ op1 (var:=var) T2
+ := match T1, T2 return interp_flat_type var T1 -> exprf _ _ T2 with
| Tbase T1', Tbase T2' => fun v : var T1' => Cast _ _ _ (Var v)
+ | _, Unit => fun _ => TT
| Prod A1 B1, Prod A2 B2
=> fun xy
=> Pair (@VarBound _ _ _ (fst xy)) (@VarBound _ _ _ (snd xy))
| Tbase _, _
| Prod _ _, _
- => fun _ => Const (SmartValf _ (@failv) _)
+ | Unit, _
+ => fun _ => failf _
end.
- Fixpoint SmartBound {var t1 t2} (v : @exprf _ interp_base_type1 op1 var t1) : @exprf _ interp_base_type1 op1 var t2.
+ Fixpoint SmartBound {var t1 t2} (v : @exprf _ op1 var t1) : @exprf _ op1 var t2.
Proof.
refine match Sumbool.sumbool_of_bool (flat_type_beq _ base_type_code1_beq t1 t2) with
- | left pf => match flat_type_dec_bl _ _ base_type_code1_bl _ _ pf in (_ = y) return exprf _ _ _ y with
+ | left pf => match flat_type_dec_bl _ _ base_type_code1_bl _ _ pf in (_ = y) return exprf _ _ y with
| eq_refl => v
end
| right _ => _
end.
- refine (match v in exprf _ _ _ t1, t2 return (exprf _ _ _ _ -> exprf _ _ _ t2) -> exprf _ _ _ t2 with
+ refine (match v in exprf _ _ t1, t2 return (exprf _ _ _ -> exprf _ _ t2) -> exprf _ _ t2 with
| Op t1 tR opc args, _
=> if is_cast _ _ opc
then fun _ => @SmartBound _ _ _ args
@@ -59,12 +62,14 @@ Section language.
| Pair _ ex _ ey, Prod _ _ => fun _ => Pair (@SmartBound _ _ _ ex) (@SmartBound _ _ _ ey)
| v', _ => fun default => default v'
end _).
- refine (match t1, t2 return exprf _ _ _ t1 -> exprf _ _ _ t2 with
+ refine (match t1, t2 return exprf _ _ t1 -> exprf _ _ t2 with
| Tbase t1', Tbase t2' => Cast _ _ _
+ | _, Unit => fun _ => TT
| Prod A1 B1, Prod A2 B2 => fun x => LetIn x (VarBound _ _)
| Tbase _, _
| Prod _ _, _
- => fun _ => Const (SmartValf _ (@failv) _)
+ | Unit, _
+ => fun _ => failf _
end).
Defined.
Definition bound_op ovar
@@ -72,28 +77,29 @@ Section language.
(opc1 : op1 src1 dst1)
(opc2 : op2 src2 dst2)
: forall args2
- (args' : @exprf base_type_code1 interp_base_type1 op1 ovar (@new_flat_type _ (interpf interp_op2 args2))),
- @exprf base_type_code1 interp_base_type1 op1 ovar (@new_flat_type _ (interpf interp_op2 (Op opc2 args2)))
+ (args' : @exprf base_type_code1 op1 ovar (@new_flat_type _ (interpf interp_op2 args2))),
+ @exprf base_type_code1 op1 ovar (@new_flat_type _ (interpf interp_op2 (Op opc2 args2)))
:= if is_cast _ _ opc1
then fun _ x => SmartBound x
else fun args2 args'
=> match new_op _ _ _ _ _ opc1 opc2 args2 with
| Some f => projT2 f (SmartBound args')
- | None => Const (SmartValf _ (@failv) _)
+ | None => failf _
end.
Section with_var.
Context {ovar : base_type_code1 -> Type}.
- Local Notation ivar t := (@exprf base_type_code1 interp_base_type1 op1 ovar (Tbase t)) (only parsing).
+ Local Notation ivar t := (@exprf base_type_code1 op1 ovar (Tbase t)) (only parsing).
Local Notation ivarf := (fun t => ivar t).
Fixpoint bound_var tx1 tx2 tC1
{struct tx2}
- : forall (f : interp_flat_type ivarf tx1 -> exprf _ interp_base_type1 op1 (var:=ovar) tC1)
+ : forall (f : interp_flat_type ivarf tx1 -> exprf _ op1 (var:=ovar) tC1)
(v : interp_flat_type ivarf tx2),
- exprf _ interp_base_type1 op1 (var:=ovar) tC1
+ exprf _ op1 (var:=ovar) tC1
:= match tx1, tx2 return (interp_flat_type _ tx1 -> _) -> interp_flat_type _ tx2 -> _ with
| Tbase T1, Tbase T2 => fun f v => f (SmartBound v)
+ | Unit, _ => fun f _ => f tt
| Prod A1 B1, Prod A2 B2
=> fun f v
=> @bound_var
@@ -102,30 +108,50 @@ Section language.
(fst v)
| Tbase _, _
| Prod _ _, _
- => fun f _ => f (SmartValf _ (fun t => Const (t:=Tbase _) (@failv t)) _)
+ => fun f _ => f (SmartValf _ (fun t => failf _) _)
end.
Definition mapf_interp_cast_with_cast_op
- {t1} (e1 : @exprf base_type_code1 interp_base_type1 op1 ivarf t1)
- {t2} (e2 : @exprf base_type_code2 interp_base_type2 op2 interp_base_type2 t2)
- : @exprf base_type_code1 interp_base_type1 op1 ovar (@new_flat_type _ (interpf interp_op2 e2))
+ {t1} (e1 : @exprf base_type_code1 op1 ivarf t1)
+ {t2} (e2 : @exprf base_type_code2 op2 interp_base_type2 t2)
+ : @exprf base_type_code1 op1 ovar (@new_flat_type _ (interpf interp_op2 e2))
:= @mapf_interp_cast
- base_type_code1 base_type_code2 interp_base_type1 interp_base_type2 op1 op2
- interp_op2 (@failv) new_base_type transfer_base_const bound_op
+ base_type_code1 base_type_code2 interp_base_type2 op1 op2
+ interp_op2 (@failv) new_base_type bound_op
ovar bound_var
t1 e1 t2 e2.
Definition map_interp_cast_with_cast_op
- {t1} (e1 : @expr base_type_code1 interp_base_type1 op1 ivarf t1)
- {t2} (e2 : @expr base_type_code2 interp_base_type2 op2 interp_base_type2 t2)
+ {t1} (e1 : @expr base_type_code1 op1 ivarf t1)
+ {t2} (e2 : @expr base_type_code2 op2 interp_base_type2 t2)
: forall (args2 : interp_all_binders_for' t2 interp_base_type2),
- @expr base_type_code1 interp_base_type1 op1 ovar (@new_type _ args2 (interp interp_op2 e2))
+ @expr base_type_code1 op1 ovar (@new_type _ args2 (interp interp_op2 e2))
:= @map_interp_cast
- base_type_code1 base_type_code2 interp_base_type1 interp_base_type2 op1 op2
- interp_op2 (@failv) new_base_type transfer_base_const bound_op
+ base_type_code1 base_type_code2 interp_base_type2 op1 op2
+ interp_op2 (@failv) new_base_type bound_op
ovar bound_var
t1 e1 t2 e2.
End with_var.
End language.
-Global Arguments mapf_interp_cast_with_cast_op {_ _ _ _ _ _ _} base_type_code1_beq base_type_code1_bl failv {_} transfer_base_const Cast is_cast new_op {ovar} {t1} e1 {t2} e2.
-Global Arguments map_interp_cast_with_cast_op {_ _ _ _ _ _ _} base_type_code1_beq base_type_code1_bl failv {_} transfer_base_const Cast is_cast new_op {ovar} {t1} e1 {t2} e2 args2.
+Global Arguments mapf_interp_cast_with_cast_op {_ _ _ _ _ _} base_type_code1_beq base_type_code1_bl failv {_} Cast is_cast new_op {ovar} {t1} e1 {t2} e2.
+Global Arguments map_interp_cast_with_cast_op {_ _ _ _ _ _} base_type_code1_beq base_type_code1_bl failv {_} Cast is_cast new_op {ovar} {t1} e1 {t2} e2 args2.
+
+Section homogenous.
+ Context {base_type_code : Type}
+ {interp_base_type2 : base_type_code -> Type}
+ {op : flat_type base_type_code -> flat_type base_type_code -> Type}
+ (interp_op2 : forall src dst, op src dst -> interp_flat_type interp_base_type2 src -> interp_flat_type interp_base_type2 dst)
+ (base_type_code_beq : base_type_code -> base_type_code -> bool)
+ (base_type_code_bl : forall x y, base_type_code_beq x y = true -> x = y)
+ (base_type_code_lb : forall x y, x = y -> base_type_code_beq x y = true)
+ (failv : forall {var t}, @exprf base_type_code op var (Tbase t))
+ {new_base_type : forall t, interp_base_type2 t -> base_type_code}
+ (Cast : forall var t1 t2, @exprf base_type_code op var (Tbase t1)
+ -> @exprf base_type_code op var (Tbase t2))
+ (is_cast : forall t1 t2, op t1 t2 -> bool).
+ Definition MapInterpCastWithCastOp
+ new_op
+ {t} (e : Expr base_type_code op t) args
+ : Expr base_type_code op (new_type (@new_base_type) args (Interp interp_op2 e))
+ := fun var => map_interp_cast_with_cast_op base_type_code_beq base_type_code_bl (@failv) Cast is_cast new_op (e _) (e _) args.
+End homogenous.
generated by cgit v1.2.3 (git 2.39.1) at 2024-10-15 23:53:40 +0000