Skip to content

Commit e502f16

Browse files
christiaanbchristiaanb
authored
Merge pull request #2153 from clash-lang/prim_eval_fixes
Prim eval fixes
2 parents cb93b41 + e6f8124 commit e502f16

File tree

22 files changed

+287
-90
lines changed

22 files changed

+287
-90
lines changed

‎changelog/2022-03-30T13_55_22+02_00_fix2154

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
FIXED: Simulation/Synthesis mismatch for X-exception to undefined bitvector conversion [#2154](https://github.com/clash-lang/clash-compiler/issues/2154)

‎clash-ghc/src-ghc/Clash/GHC/Evaluator.hs

Lines changed: 23 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
{-|
2-
Copyright : (C) 2017, Google Inc.,
3-
2021, QBayLogic B.V.
2+
Copyright : (C) 2017-2022, Google Inc.,
3+
2021 , QBayLogic B.V.
44
License : BSD2 (see the file LICENSE)
55
Maintainer : QBayLogic B.V. <[email protected]>
66
@@ -49,7 +49,7 @@ import Clash.Core.Util
4949
import Clash.Core.Var
5050
import Clash.Core.VarEnv
5151
import Clash.Debug
52-
import qualified Clash.Normalize.Primitives as NP (undefined)
52+
import qualified Clash.Normalize.Primitives as NP (removedArg, undefined, undefinedX)
5353
import Clash.Unique
5454
import Clash.Util (curLoc)
5555

@@ -165,8 +165,17 @@ stepApp x y m tcm =
165165
(m1,j) = newLetBinding tcm m0 a1
166166
in ghcPrimStep tcm (forcePrims m) p [] [Suspend (Var i), Suspend (Var j)] m1
167167

168-
(e':es) ->
169-
Just . setTerm e' $ stackPush (PrimApply p (rights args) [] es) m
168+
(e':es)
169+
| primName p `elem` (undefinedXPrims ++ undefinedPrims)
170+
-- The above primitives are (bottoming) values, whose arguments
171+
-- are never used anywhere in the rest of the compiler. So
172+
-- instead of pushing a PrimApply frame on the stack to evaluate
173+
-- those arguments, we instead just unwind the stack with the
174+
-- primitive value and leave its arguments in an unevaluated
175+
-- state (Suspend).
176+
-> ghcUnwind (PrimVal p (rights args) (map Suspend (e':es))) m tcm
177+
| otherwise
178+
-> Just . setTerm e' $ stackPush (PrimApply p (rights args) [] es) m
170179

171180
_ -> error "internal error"
172181

@@ -195,8 +204,9 @@ stepTyApp x ty m tcm =
195204
let tys = fst $ splitFunForallTy (primType p)
196205
in case compare (length args) (length tys) of
197206
EQ -> case lefts args of
198-
[] | primName p `elem` [ "Clash.Normalize.Primitives.removedArg"
199-
, "Clash.Normalize.Primitives.undefined" ] ->
207+
[] | primName p `elem` fmap primName [ NP.removedArg
208+
, NP.undefined
209+
, NP.undefinedX ] ->
200210
ghcUnwind (PrimVal p (rights args) []) m tcm
201211

202212
| otherwise ->
@@ -312,6 +322,8 @@ apply _tcm (Lambda x' e) x m =
312322
subst = extendIdSubst subst0 x' (Var x)
313323
subst0 = mkSubst $ extendInScopeSet (mScopeNames m) x
314324
apply tcm pVal@(PrimVal (PrimInfo{primType}) tys vs) x m
325+
| isUndefinedXPrimVal pVal
326+
= setTerm (TyApp (Prim NP.undefinedX) ty) m
315327
| isUndefinedPrimVal pVal
316328
= setTerm (TyApp (Prim NP.undefined) ty) m
317329
where
@@ -328,6 +340,8 @@ instantiate _tcm (TyLambda x e) ty m =
328340
subst0 = mkSubst iss0
329341
iss0 = mkInScopeSet (freeVarsOf e `unionUniqSet` freeVarsOf ty)
330342
instantiate tcm pVal@(PrimVal (PrimInfo{primType}) tys []) ty m
343+
| isUndefinedXPrimVal pVal
344+
= setTerm (TyApp (Prim NP.undefinedX) (piResultTys tcm primType (tys ++ [ty]))) m
331345
| isUndefinedPrimVal pVal
332346
= setTerm (TyApp (Prim NP.undefined) (piResultTys tcm primType (tys ++ [ty]))) m
333347

@@ -402,6 +416,8 @@ scrutinise (DC dc xs) _altTy alts m
402416
= setTerm altE m
403417

404418
scrutinise v@(PrimVal p _ vs) altTy alts m
419+
| isUndefinedXPrimVal v
420+
= setTerm (TyApp (Prim NP.undefinedX) altTy) m
405421
| isUndefinedPrimVal v
406422
= setTerm (TyApp (Prim NP.undefined) altTy) m
407423

‎clash-ghc/src-ghc/Clash/GHC/Evaluator/Primitive.hs

Lines changed: 74 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,8 @@
11
{-|
22
Copyright : (C) 2013-2016, University of Twente,
33
2016-2017, Myrtle Software Ltd,
4-
2017 , QBayLogic, Google Inc.,
5-
2021-2022, QBayLogic B.V.
4+
2017-2022, Google Inc.,
5+
2017-2022, QBayLogic B.V.
66
License : BSD2 (see the file LICENSE)
77
Maintainer : QBayLogic B.V. <[email protected]>
88
-}
@@ -20,6 +20,7 @@ module Clash.GHC.Evaluator.Primitive
2020
( ghcPrimStep
2121
, ghcPrimUnwind
2222
, isUndefinedPrimVal
23+
, isUndefinedXPrimVal
2324
) where
2425

2526
import Control.Concurrent.Supply (Supply,freshId)
@@ -88,15 +89,16 @@ import Clash.Core.Name
8889
import Clash.Core.Pretty (showPpr)
8990
import Clash.Core.Term
9091
(IsMultiPrim (..), Pat (..), PrimInfo (..), Term (..), WorkInfo (..), mkApps,
91-
PrimUnfolding(..))
92+
PrimUnfolding(..), collectArgs)
9293
import Clash.Core.Type
9394
(Type (..), ConstTy (..), LitTy (..), TypeView (..), mkFunTy, mkTyConApp,
9495
splitFunForallTy, tyView)
9596
import Clash.Core.TyCon
9697
(TyConMap, TyConName, tyConDataCons)
9798
import Clash.Core.TysPrim
9899
import Clash.Core.Util
99-
(mkRTree,mkVec,tyNatSize,dataConInstArgTys,primCo, mkSelectorCase,undefinedPrims)
100+
(mkRTree,mkVec,tyNatSize,dataConInstArgTys,primCo, mkSelectorCase,undefinedPrims,
101+
undefinedXPrims)
100102
import Clash.Core.Var (mkLocalId, mkTyVar)
101103
import Clash.Debug
102104
import Clash.GHC.GHC2Core (modNameM)
@@ -124,6 +126,11 @@ isUndefinedPrimVal (PrimVal (PrimInfo{primName}) _ _) =
124126
primName `elem` undefinedPrims
125127
isUndefinedPrimVal _ = False
126128

129+
isUndefinedXPrimVal :: Value -> Bool
130+
isUndefinedXPrimVal (PrimVal (PrimInfo{primName}) _ _) =
131+
primName `elem` undefinedXPrims
132+
isUndefinedXPrimVal _ = False
133+
127134
-- | Evaluation of primitive operations.
128135
ghcPrimUnwind :: PrimUnwind
129136
ghcPrimUnwind tcm p tys vs v [] m
@@ -132,6 +139,7 @@ ghcPrimUnwind tcm p tys vs v [] m
132139
, Text.pack (show 'NP.removedArg)
133140
, "GHC.Prim.MutableByteArray#"
134141
, Text.pack (show 'NP.undefined)
142+
, Text.pack (show 'NP.undefinedX)
135143
]
136144
-- The above primitives are actually values, and not operations.
137145
= ghcUnwind (PrimVal p tys (vs ++ [v])) m tcm
@@ -160,10 +168,18 @@ ghcPrimUnwind tcm p tys vs v [] m
160168
tmArgs = map (Left . valToTerm) (vs ++ [v])
161169
in Just $ flip setTerm m $ TyApp (Prim NP.undefined) $
162170
applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)
171+
| isUndefinedXPrimVal v
172+
= let tyArgs = map Right tys
173+
tmArgs = map (Left . valToTerm) (vs ++ [v])
174+
in Just $ flip setTerm m $ TyApp (Prim NP.undefinedX) $
175+
applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)
163176
| otherwise
164177
= ghcPrimStep tcm (forcePrims m) p tys (vs ++ [v]) m
165178

166179
ghcPrimUnwind tcm p tys vs v [e] m0
180+
-- Note [Lazy primitives]
181+
-- ~~~~~~~~~~~~~~~~~~~~~~
182+
--
167183
-- Primitives are usually considered undefined when one of their arguments is
168184
-- (unless they're unused). _Some_ primitives can still yield a result even
169185
-- though one of their arguments is undefined. It turns out that all primitives
@@ -174,6 +190,7 @@ ghcPrimUnwind tcm p tys vs v [e] m0
174190
, "Clash.Sized.Vector.replace_int"
175191
, "GHC.Classes.&&"
176192
, "GHC.Classes.||"
193+
, "Clash.Class.BitPack.Internal.xToBV"
177194
]
178195
= if isUndefinedPrimVal v then
179196
let tyArgs = map Right tys
@@ -1585,6 +1602,11 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of
15851602
| [Lit (NaturalLiteral n), _] <- args
15861603
-> reduce (Literal (NaturalLiteral n))
15871604

1605+
"GHC.TypeNats.someNatVal"
1606+
| [Lit (NaturalLiteral n)] <- args
1607+
-> let resTy = getResultTy tcm ty tys
1608+
in reduce (mkSomeNat tcm n resTy)
1609+
15881610
"GHC.Int.I8#"
15891611
| isSubj
15901612
, [Lit (IntLiteral i)] <- args
@@ -1790,6 +1812,29 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of
17901812
val = unpack (toBV i :: BitVector 64)
17911813
in reduce (mkDoubleCLit tcm val resTy)
17921814

1815+
"Clash.Class.BitPack.Internal.xToBV"
1816+
| isSubj
1817+
, Just (nTy, kn) <- extractKnownNat tcm tys
1818+
-- The second argument to `xToBV` is always going to be suspended.
1819+
-- See Note [Lazy primitives]
1820+
, [ _, (Suspend arg) ] <- args
1821+
, eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
1822+
, mach1@Machine{mStack=[],mTerm=argWHNF} <-
1823+
whnf eval tcm True (setTerm arg (stackClear mach))
1824+
, let undefBitVector =
1825+
Just $ mach1
1826+
{ mStack = mStack mach
1827+
, mTerm = mkBitVectorLit ty nTy kn (bit (fromInteger kn)-1) 0
1828+
}
1829+
-> case isX argWHNF of
1830+
Left _ -> undefBitVector
1831+
_ -> case collectArgs argWHNF of
1832+
(Prim p,_) | primName p `elem` undefinedXPrims -> undefBitVector
1833+
_ -> Just $ mach1
1834+
{ mStack = mStack mach
1835+
, mTerm = argWHNF
1836+
}
1837+
17931838
-- expIndex#
17941839
-- :: KnownNat m
17951840
-- => Index m
@@ -4213,6 +4258,31 @@ mkDoubleCLit tcm lit resTy =
42134258
(Just doubleTc) = lookupUniqMap doubleTcNm tcm
42144259
[doubleDc] = tyConDataCons doubleTc
42154260

4261+
mkSomeNat :: TyConMap -> Integer -> Type -> Term
4262+
mkSomeNat tcm lit resTy =
4263+
mkApps (Data someNatDc)
4264+
[ Right (LitTy (NumTy lit))
4265+
, Left (Literal (NaturalLiteral lit))
4266+
, Left proxy
4267+
]
4268+
where
4269+
-- Get the SomeNat data constructor
4270+
TyConApp someNatTcNm [] = tyView resTy
4271+
(Just someNatTc) = lookupUniqMap someNatTcNm tcm
4272+
[someNatDc] = tyConDataCons someNatTc
4273+
4274+
-- Get the Proxy data constructor
4275+
(_:_:Right (tyView -> TyConApp proxyTcNm [natTy,_]):_,_) =
4276+
splitFunForallTy (dcType someNatDc)
4277+
(Just proxyTc) = lookupUniqMap proxyTcNm tcm
4278+
[proxyDc] = tyConDataCons proxyTc
4279+
4280+
-- Build the Proxy argument
4281+
proxy = mkApps (Data proxyDc)
4282+
[ Right natTy
4283+
, Right (LitTy (NumTy lit))
4284+
]
4285+
42164286
-- From an argument list to function of type
42174287
-- forall n. KnownNat n => ...
42184288
-- extract (nTy,nInt)

‎clash-ghc/src-ghc/Clash/GHC/GHC2Core.hs

Lines changed: 31 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
{-|
22
Copyright : (C) 2013-2016, University of Twente,
33
2016-2017, Myrtle Software Ltd,
4-
2017-2818, Google Inc.
4+
2017-2022, Google Inc.
55
2021, QBayLogic B.V.,
66
License : BSD2 (see the file LICENSE)
77
Maintainer : QBayLogic B.V. <[email protected]>
@@ -159,8 +159,9 @@ import qualified Clash.Core.Name as C
159159
import qualified Clash.Core.Term as C
160160
import qualified Clash.Core.TyCon as C
161161
import qualified Clash.Core.Type as C
162-
import qualified Clash.Core.Util as C (undefinedTy)
162+
import qualified Clash.Core.Util as C (undefinedTy, undefinedXPrims)
163163
import qualified Clash.Core.Var as C
164+
import Clash.Normalize.Primitives as C
164165
import Clash.Primitives.Types
165166
import qualified Clash.Unique as C
166167
import Clash.Util
@@ -381,9 +382,6 @@ coreToTerm primMap unlocs = term
381382
go "GHC.Stack.withFrozenCallStack" args
382383
| length args == 3
383384
= term (App (args!!2) (args!!1))
384-
go "Clash.Class.BitPack.Internal.packXWith" args
385-
| [_nTy,_aTy,_kn,f] <- args
386-
= term f
387385
go "Clash.Sized.BitVector.Internal.checkUnpackUndef" args
388386
| [_nTy,_aTy,_kn,_typ,f] <- args
389387
= term f
@@ -461,9 +459,34 @@ coreToTerm primMap unlocs = term
461459
x' <- coreToIdSP sp x
462460
return (x',b')
463461

464-
term' (Case _ _ ty []) =
465-
C.TyApp (C.Prim (C.PrimInfo (pack "EmptyCase") C.undefinedTy C.WorkNever C.SingleResult C.NoUnfolding))
466-
<$> coreToType ty
462+
term' (Case s _ ty []) = do
463+
s' <- term' s
464+
ty' <- coreToType ty
465+
case C.collectArgs s' of
466+
(C.Prim p, _) | C.primName p `elem` C.undefinedXPrims ->
467+
-- GHC translates things like:
468+
--
469+
-- xToBV (Index.pack# (errorX @TY "QQ"))
470+
--
471+
-- to
472+
--
473+
-- xToBV (case (errorX @TY "QQ") of {})
474+
--
475+
--
476+
-- Here we then translate
477+
--
478+
-- case (errorX @TY "QQ") of {}
479+
--
480+
-- to
481+
--
482+
-- undefinedX @TY
483+
--
484+
-- So that the evaluator rule for 'xToBV' can recognize things that
485+
-- would normally throw XException
486+
return (C.TyApp (C.Prim C.undefinedX) ty')
487+
_ ->
488+
return (C.TyApp (C.Prim C.undefined) ty')
489+
467490
term' (Case e b ty alts) = do
468491
let usesBndr = any ( not . isEmptyVarSet . exprSomeFreeVars (== b))
469492
$ rhssOfAlts alts
@@ -550,7 +573,6 @@ coreToTerm primMap unlocs = term
550573
| f == "GHC.Magic.noinline" -> return (idTerm xType)
551574
| f == "GHC.Magic.lazy" -> return (idTerm xType)
552575
| f == "GHC.Magic.runRW#" -> return (runRWTerm xType)
553-
| f == "Clash.Class.BitPack.Internal.packXWith" -> return (packXWithTerm xType)
554576
| f == "Clash.Sized.Internal.BitVector.checkUnpackUndef" -> return (checkUnpackUndefTerm xType)
555577
| f == "Clash.Magic.prefixName"
556578
-> return (nameModTerm C.PrefixName xType)
@@ -1343,32 +1365,6 @@ runRWTerm (C.ForAllTy rTV (C.ForAllTy oTV funTy)) =
13431365

13441366
runRWTerm ty = error $ $(curLoc) ++ show ty
13451367

1346-
-- | Given type type:
1347-
--
1348-
-- @forall (n :: Nat) (a :: Type) .Knownnat n => (a -> BitVector n) -> a -> BitVector n@
1349-
--
1350-
-- Generate the term:
1351-
--
1352-
-- @/\(n:Nat)./\(a:TYPE r).\(kn:KnownNat n).\(f:a -> BitVector n).f@
1353-
packXWithTerm
1354-
:: C.Type
1355-
-> C.Term
1356-
packXWithTerm (C.ForAllTy nTV (C.ForAllTy aTV funTy)) =
1357-
C.TyLam nTV (
1358-
C.TyLam aTV (
1359-
C.Lam knId (
1360-
C.Lam fId (
1361-
C.Var fId))))
1362-
where
1363-
C.FunTy knTy rTy = C.tyView funTy
1364-
C.FunTy fTy _ = C.tyView rTy
1365-
knName = C.mkUnsafeSystemName "kn" 0
1366-
fName = C.mkUnsafeSystemName "f" 1
1367-
knId = C.mkLocalId knTy knName
1368-
fId = C.mkLocalId fTy fName
1369-
1370-
packXWithTerm ty = error $ $(curLoc) ++ show ty
1371-
13721368
-- | Given type type:
13731369
--
13741370
-- @forall (n :: Nat) (a :: Type) .Knownnat n => Typeable a => (BitVector n -> a) -> BitVector n -> a@

‎clash-ghc/src-ghc/Clash/GHC/PartialEval/Eval.hs

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-|
2-
Copyright : (C) 2020-2021, QBayLogic B.V.
2+
Copyright : (C) 2020-2021, QBayLogic B.V.,
3+
2022 , Google Inc.
34
License : BSD2 (see the file LICENSE)
45
Maintainer : QBayLogic B.V. <[email protected]>
56
@@ -49,7 +50,7 @@ import Clash.Core.Type
4950
import Clash.Core.TysPrim (integerPrimTy)
5051
import Clash.Core.Var
5152
import Clash.Driver.Types (Binding(..), IsPrim(..))
52-
import qualified Clash.Normalize.Primitives as NP (undefined)
53+
import qualified Clash.Normalize.Primitives as NP (undefined, undefinedX)
5354
import Clash.Unique (lookupUniqMap')
5455

5556
-- | Evaluate a term to WHNF.
@@ -290,7 +291,9 @@ caseCon subject ty alts = do
290291
forcedSubject <- keepLifted (forceEval subject)
291292

292293
-- If the subject is undefined, the whole expression is undefined.
293-
case isUndefined forcedSubject of
294+
case isUndefinedX forcedSubject of
295+
True -> eval (TyApp (Prim NP.undefinedX) ty)
296+
False -> case isUndefined forcedSubject of
294297
True -> eval (TyApp (Prim NP.undefined) ty)
295298
False ->
296299
case stripValue forcedSubject of

‎clash-lib/prims/common/Clash_Class_BitPack.primitives.yaml

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -26,3 +26,9 @@
2626
64 -> Double'
2727
template: ~ARG[0]
2828
workInfo: Never
29+
- BlackBox:
30+
name: Clash.Class.BitPack.Internal.xToBV
31+
kind: Expression
32+
type: 'xToBV :: KnownNat n => BitVector n -> BitVector n'
33+
template: ~ARG[1]
34+
workInfo: Never

‎clash-lib/prims/common/Clash_GHC_GHC2Core.primitives.yaml

Lines changed: 0 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,3 @@
1-
- BlackBox:
2-
name: EmptyCase
3-
kind: Expression
4-
template: ~ERRORO
5-
workInfo: Constant
61
- Primitive:
72
name: _CO_
83
primType: Constructor

0 commit comments

Comments
 (0)